Add MonadFix instance for boxed vectors

Data/Vector.hs

@@ -176,11 +176,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,
@@ -381,6 +382,24 @@ instance MonadZip Vector where
   {-# INLINE munzip #-}
   munzip = unzip
 
+instance MonadFix Vector where
+  -- We take care to dispose of v0 as soon as possible.
+  -- We also avoid setting up the result vector to refer to
+  -- itself. These measures should prevent memory leaks.
+  -- It's perfectly safe to use non-monadic indexing within
+  -- each element, as the result of indexing will be demanded
+  -- as soon as the vector is produced.
+  {-# INLINE mfix #-}
+  mfix f
+    | null v0 = empty
+    | otherwise = runST $ do
+        h <- headM v0
+        return $ cons h $
+          generate (lv0 - 1) $
+            \i -> fix (\a -> f a ! (i + 1))
+    where
+      v0 = fix (f . head)
+      !lv0 = length v0
 
 instance Applicative.Applicative Vector where
   {-# INLINE pure #-}

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)