Add tests for iterateM and unfoldrM

test for unfoldrM is not used yet

It required generalization of Arbitrary and TestData instances for
Writer monad

Author: Shimuuar

tests/Tests/Vector.hs

@@ -3,6 +3,7 @@ module Tests.Vector (tests) where
 import Boilerplater
 import Utilities as Util
 
+import Data.Functor.Identity
 import qualified Data.Traversable as T (Traversable(..))
 import Data.Foldable (Foldable(foldMap))
 
@@ -113,7 +114,7 @@ testPolymorphicFunctions _ = $(testProperties [
 
         -- Initialisation (FIXME)
         'prop_empty, 'prop_singleton, 'prop_replicate,
-        'prop_generate, 'prop_iterateN,
+        'prop_generate, 'prop_iterateN, 'prop_iterateNM,
 
         -- Monadic initialisation (FIXME)
         'prop_createT,
@@ -231,7 +232,8 @@ testPolymorphicFunctions _ = $(testProperties [
               = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate
     prop_iterateN  :: P (Int -> (a -> a) -> a -> v a)
               = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f)
-
+    prop_iterateNM :: P (Int -> (a -> Writer [Int] a) -> a -> Writer [Int] (v a))
+              = (\n _ _ -> n < 1000) ===> V.iterateNM `eq` Util.iterateNM
     prop_createT :: P ((a, v a) -> (a, v a))
     prop_createT = (\v -> V.createT (T.mapM V.thaw v)) `eq` id
 
@@ -433,10 +435,18 @@ testPolymorphicFunctions _ = $(testProperties [
     limitUnfolds f (theirs, ours) | ours >= 0
                                   , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1))
                                   | otherwise                       = Nothing
+    limitUnfoldsM f (theirs, ours)
+        | ours >= 0 = do r <- f theirs
+                         return $ (\(a,b) -> (a,(b,ours - 1))) `fmap` r
+        | otherwise = return Nothing
+
+
     prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a)
          = (\n f a -> V.unfoldr (limitUnfolds f) (a, n))
            `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n))
-
+    prop_unfoldrM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a))
+         = (\n f a -> V.unfoldrM (limitUnfoldsM f) (a,n))
+           `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n))
     prop_constructN  = \f -> forAll (choose (0,20)) $ \n -> unP prop n f
       where
         prop :: P (Int -> (v a -> a) -> v a) = V.constructN `eq` constructN []

tests/Utilities.hs

@@ -52,8 +52,10 @@ instance Arbitrary a => Arbitrary (S.Bundle v a) where
 instance CoArbitrary a => CoArbitrary (S.Bundle v a) where
     coarbitrary = coarbitrary . S.toList
 
-instance Arbitrary a => Arbitrary (Writer a ()) where
-    arbitrary = fmap (writer . ((,) ())) arbitrary
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Writer a b) where
+    arbitrary = do b <- arbitrary
+                   a <- arbitrary
+                   return $ writer (b,a)
 
 instance CoArbitrary a => CoArbitrary (Writer a ()) where
     coarbitrary = coarbitrary . runWriter
@@ -148,13 +150,13 @@ instance (Eq a, TestData a) => TestData (Identity a) where
   type EqTest (Identity a) = Property
   equal = (property .) . on (==) runIdentity
 
-instance (Eq a, TestData a, Monoid a) => TestData (Writer a ()) where
-  type Model (Writer a ()) = Writer (Model a) ()
+instance (Eq a, TestData a, Eq b, TestData b, Monoid a) => TestData (Writer a b) where
+  type Model (Writer a b) = Writer (Model a) (Model b)
   model = mapWriter model
   unmodel = mapWriter unmodel
 
-  type EqTest (Writer a ()) = Property
-  equal = (property .) . on (==) execWriter
+  type EqTest (Writer a b) = Property
+  equal = (property .) . on (==) runWriter
 
 instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where
   type Model (a,b) = (Model a, Model b)
@@ -325,3 +327,18 @@ maxIndex = fst . foldr1 imax . zip [0..]
     imax (i,x) (j,y) | x >= y    = (i,x)
                      | otherwise = (j,y)
 
+iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a]
+iterateNM n f x
+    | n <= 0    = return []
+    | n == 1    = return [x]
+    | otherwise =  do x' <- f x
+                      xs <- iterateNM (n-1) f x'
+                      return (x : xs)
+
+unfoldrM :: Monad m => (b -> m (Maybe (a,b))) -> b -> m [a]
+unfoldrM step b0 = do
+    r <- step b0
+    case r of
+      Nothing    -> return []
+      Just (a,b) -> do as <- unfoldrM step b
+                       return (a : as)