Merge pull request #9 from bgwines/master

Defined `takeWhileM` and set up a testing framework.

Author: mokus0

Tests/test-monad-loops.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main (main) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Control.Monad.Loops
+
+testTakeWhileM :: Assertion
+testTakeWhileM = do
+    actual      <- takeWhileM (return . id) [True, True, False]
+    let expected = takeWhile  (         id) [True, True, False]
+    actual @?= expected
+
+testTakeWhileMEdgeCase1 :: Assertion
+testTakeWhileMEdgeCase1 = do
+    actual      <- takeWhileM (return . id) []
+    let expected = takeWhile  (         id) []
+    actual @?= expected
+
+testTakeWhileMEdgeCase2 :: Assertion
+testTakeWhileMEdgeCase2 = do
+    actual      <- takeWhileM (return . id) [False, False, False]
+    let expected = takeWhile  (         id) [False, False, False]
+    actual @?= expected
+
+testTakeWhileMEdgeCase3 :: Assertion
+testTakeWhileMEdgeCase3 = do
+    let emptyList :: [Int] = []
+    actual      <- takeWhileM (const undefined) emptyList
+    let expected = takeWhile  (const undefined) emptyList
+    actual @?= expected
+
+tests :: TestTree
+tests = testGroup "unit tests"
+    [ testCase
+        "Testing `takeWhileM`"
+        testTakeWhileM
+    , testCase
+        "Testing `takeWhileM (edge case 1)`"
+        testTakeWhileMEdgeCase1
+    , testCase
+        "Testing `takeWhileM (edge case 2)`"
+        testTakeWhileMEdgeCase2
+    , testCase
+        "Testing `takeWhileM (edge case 3)`"
+        testTakeWhileMEdgeCase3
+    ]
+
+main :: IO ()
+main = defaultMain tests

monad-loops.cabal

@@ -3,7 +3,7 @@ version:                0.4.2.1
 stability:              provisional
 license:                PublicDomain
 
-cabal-version:          >= 1.6
+cabal-version:          >= 1.8
 build-type:             Simple
 
 author:                 James Cook <[email protected]>
@@ -36,6 +36,15 @@ Library
   exposed-modules:      Control.Monad.Loops
   if flag(base4)
     cpp-options:        -Dbase4
-    build-depends:      base >= 4 && <5
+    build-depends:      base >= 4 && < 5
   else
     build-depends:      base >= 2 && < 4
+
+Test-Suite test-monad-loops
+    type:       exitcode-stdio-1.0
+    main-is:    Tests/test-monad-loops.hs
+    if flag(base4)
+      cpp-options:        -Dbase4
+      build-depends:      base >= 4 && < 5, tasty, tasty-hunit, monad-loops
+    else
+      build-depends:      base >= 2 && < 4, tasty, tasty-hunit, monad-loops

src/Control/Monad/Loops.hs

@@ -367,6 +367,16 @@ allM p (x:xs)   = do
                 then allM p xs
                 else return False
 
+-- | Monadic 'takeWhile'.
+takeWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
+takeWhileM _ []     = return []
+takeWhileM p (x:xs) = do
+        q <- p x
+        if q
+                then (takeWhileM p xs) >>= (return . (:) x)
+                else return []
+
+-- | Monadic 'dropWhile'.
 dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
 dropWhileM _ []     = return []
 dropWhileM p (x:xs) = do