diff --git a/Data/Vector.hs b/Data/Vector.hs index ab61f2a9..097ed489 100644 --- a/Data/Vector.hs +++ b/Data/Vector.hs @@ -177,11 +177,12 @@ import Control.DeepSeq ( NFData(rnf) ) import Control.Monad ( MonadPlus(..), liftM, ap ) -import Control.Monad.ST ( ST ) +import Control.Monad.ST ( ST, runST ) import Control.Monad.Primitive import qualified Control.Monad.Fail as Fail - +import Control.Monad.Fix ( MonadFix (mfix) ) import Control.Monad.Zip +import Data.Function ( fix ) import Prelude hiding ( length, null, replicate, (++), concat, @@ -382,6 +383,29 @@ instance MonadZip Vector where {-# INLINE munzip #-} munzip = unzip +-- | Instance has same semantics as one for lists +-- +-- @since 0.13.0.0 +instance MonadFix Vector where + -- We take care to dispose of v0 as soon as possible (see headM docs). + -- + -- It's perfectly safe to use non-monadic indexing within generate + -- call since intermediate vector won't be created until result's + -- value is demanded. + {-# INLINE mfix #-} + mfix f + | null v0 = empty + -- We take first element of resulting vector from v0 and create + -- rest using generate. Note that cons should fuse with generate + | otherwise = runST $ do + h <- headM v0 + return $ cons h $ + generate (lv0 - 1) $ + \i -> fix (\a -> f a ! (i + 1)) + where + -- Used to calculate size of resulting vector + v0 = fix (f . head) + !lv0 = length v0 instance Applicative.Applicative Vector where {-# INLINE pure #-} diff --git a/changelog.md b/changelog.md index 381df631..80cb4222 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,6 @@ # Changes in NEXT_VERSION + * Added `MonadFix` instance for boxed vectors * New functions: `unfoldrExactN` and `unfoldrExactNM` * `mkType` from `Data.Vector.Generic` is deprecated in favor of `Data.Data.mkNoRepType` diff --git a/tests/Tests/Vector/UnitTests.hs b/tests/Tests/Vector/UnitTests.hs index 162b1aae..a7fbe9a1 100644 --- a/tests/Tests/Vector/UnitTests.hs +++ b/tests/Tests/Vector/UnitTests.hs @@ -6,6 +6,8 @@ module Tests.Vector.UnitTests (tests) where import Control.Applicative as Applicative import Control.Exception import Control.Monad.Primitive +import Control.Monad.Fix (mfix) +import qualified Data.Vector as Vector import Data.Int import Data.Word import Data.Typeable @@ -80,6 +82,9 @@ tests = , testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take ] ] + , testGroup "Data.Vector" + [ testCase "MonadFix" checkMonadFix + ] ] testsSliceOutOfBounds :: @@ -157,3 +162,15 @@ _f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f) => Generic.Mutable v (PrimState f) a -> f (w a) _f v = Generic.convert `fmap` Generic.unsafeFreeze v #endif +checkMonadFix :: Assertion +checkMonadFix = assertBool "checkMonadFix" $ + Vector.toList fewV == fewL && + Vector.toList none == [] + where + facty _ 0 = 1; facty f n = n * f (n - 1) + fewV :: Vector.Vector Int + fewV = fmap ($ 12) $ mfix (\i -> Vector.fromList [facty i, facty (+1), facty (+2)]) + fewL :: [Int] + fewL = fmap ($ 12) $ mfix (\i -> [facty i, facty (+1), facty (+2)]) + none :: Vector.Vector Int + none = mfix (const Vector.empty)