Merge branch 'improving-coverage'

CHANGELOG.md

@@ -30,6 +30,12 @@
   `isUnexpected`, `isExpected`, and `isMessage` are defined in
   `Text.Megaparsec.Error`.
 
+* Minor tweak in signature of `MonadParsec` type class. Collection of
+  constraints changed from `Alternative m, Monad m, Stream s t` to
+  `Alternative m, MonadPlus m, Stream s t`. This is done to make it easier
+  to write more abstract code with older GHC where such primitives as
+  `guard` are defined for instances of `MonadPlus`, not `Alternative`.
+
 ## Megaparsec 4.3.0
 
 * Canonicalized `Applicative`/`Monad` instances. Thanks to Herbert Valerio

Text/Megaparsec/Error.hs

@@ -34,11 +34,14 @@ module Text.Megaparsec.Error
 where
 
 import Control.Exception (Exception)
-import Data.Foldable (find)
+import Data.Foldable (find, concat)
 import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (fromMaybe, fromJust)
 import Data.Semigroup (Semigroup((<>)))
 import Data.Typeable (Typeable)
+import Prelude hiding (concat)
+import qualified Data.List.NonEmpty as NE
 
 import Text.Megaparsec.Pos
 
@@ -203,24 +206,23 @@ showMessages ms = tail $ foldMap (fromMaybe "") (zipWith f ns rs)
         f prefix m = (prefix ++) <$> m
         ns = ["\nunexpected ","\nexpecting ","\n"]
         rs = (renderMsgs orList <$> [unexpected, expected]) ++
-             [renderMsgs (intercalate "\n") messages]
+             [renderMsgs (concat . NE.intersperse "\n") messages]
 
 -- | Render collection of messages. If the collection is empty, return
 -- 'Nothing', otherwise return textual representation of the messages inside
 -- 'Just'.
 
 renderMsgs
-  :: ([String] -> String) -- ^ Function to combine results
+  :: (NonEmpty String -> String) -- ^ Function to combine results
   -> [Message]         -- ^ Collection of messages to render
   -> Maybe String      -- ^ Result, if any
-renderMsgs _ [] = Nothing
+-- renderMsgs _ [] = Nothing
-renderMsgs f ms = Just . f $ messageString <$> ms
+renderMsgs f ms = f . fmap messageString <$> NE.nonEmpty ms
 
 -- | Print a pretty list where items are separated with commas and the word
 -- “or” according to rules of English punctuation.
 
-orList :: [String] -> String
+orList :: NonEmpty String -> String
-orList []    = ""
+orList (x:|[])  = x
-orList [x]   = x
+orList (x:|[y]) = x ++ " or " ++ y
-orList [x,y] = x ++ " or " ++ y
+orList xs       = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs
-orList xs    = intercalate ", " (init xs) ++ ", or " ++ last xs

Text/Megaparsec/Prim.hs

@@ -413,8 +413,8 @@ instance MonadTrans (ParsecT s) where
 
 -- | Type class describing parsers independent of input type.
 
-class (A.Alternative m, Monad m, Stream s t)
+class (A.Alternative m, MonadPlus m, Stream s t)
-      => MonadParsec s m t | m -> s t where
+  => MonadParsec s m t | m -> s t where
 
   -- | The most general way to stop parsing and report 'ParseError'.
   --
@@ -901,8 +901,7 @@ parseFromFile p filename = runParser p filename <$> fromFile filename
 ----------------------------------------------------------------------------
 -- Instances of 'MonadParsec'
 
-instance (MonadPlus m, MonadParsec s m t) =>
+instance MonadParsec s m t => MonadParsec s (L.StateT e m) t where
-         MonadParsec s (L.StateT e m) t where
   failure                    = lift . failure
   label n       (L.StateT m) = L.StateT $ label n . m
   try           (L.StateT m) = L.StateT $ try . m
@@ -918,8 +917,7 @@ instance (MonadPlus m, MonadParsec s m t) =>
   getParserState             = lift getParserState
   updateParserState f        = lift $ updateParserState f
 
-instance (MonadPlus m, MonadParsec s m t)
+instance MonadParsec s m t => MonadParsec s (S.StateT e m) t where
-         => MonadParsec s (S.StateT e m) t where
   failure                    = lift . failure
   label n       (S.StateT m) = S.StateT $ label n . m
   try           (S.StateT m) = S.StateT $ try . m
@@ -935,8 +933,7 @@ instance (MonadPlus m, MonadParsec s m t)
   getParserState             = lift getParserState
   updateParserState f        = lift $ updateParserState f
 
-instance (MonadPlus m, MonadParsec s m t)
+instance MonadParsec s m t => MonadParsec s (L.ReaderT e m) t where
-         => MonadParsec s (L.ReaderT e m) t where
   failure                     = lift . failure
   label n       (L.ReaderT m) = L.ReaderT $ label n . m
   try           (L.ReaderT m) = L.ReaderT $ try . m
@@ -950,8 +947,7 @@ instance (MonadPlus m, MonadParsec s m t)
   getParserState              = lift getParserState
   updateParserState f         = lift $ updateParserState f
 
-instance (MonadPlus m, Monoid w, MonadParsec s m t)
+instance (Monoid w, MonadParsec s m t) => MonadParsec s (L.WriterT w m) t where
-         => MonadParsec s (L.WriterT w m) t where
   failure                     = lift . failure
   label n       (L.WriterT m) = L.WriterT $ label n m
   try           (L.WriterT m) = L.WriterT $ try m
@@ -967,8 +963,7 @@ instance (MonadPlus m, Monoid w, MonadParsec s m t)
   getParserState              = lift getParserState
   updateParserState f         = lift $ updateParserState f
 
-instance (MonadPlus m, Monoid w, MonadParsec s m t)
+instance (Monoid w, MonadParsec s m t) => MonadParsec s (S.WriterT w m) t where
-         => MonadParsec s (S.WriterT w m) t where
   failure                     = lift . failure
   label n       (S.WriterT m) = S.WriterT $ label n m
   try           (S.WriterT m) = S.WriterT $ try m
@@ -984,8 +979,7 @@ instance (MonadPlus m, Monoid w, MonadParsec s m t)
   getParserState              = lift getParserState
   updateParserState f         = lift $ updateParserState f
 
-instance (Monad m, MonadParsec s m t)
+instance MonadParsec s m t => MonadParsec s (IdentityT m) t where
-         => MonadParsec s (IdentityT m) t where
   failure                     = lift . failure
   label n       (IdentityT m) = IdentityT $ label n m
   try                         = IdentityT . try . runIdentityT

tests/Perm.hs

@@ -36,6 +36,7 @@ import Test.Framework.Providers.QuickCheck2 (testProperty)
 import Test.QuickCheck
 
 import Text.Megaparsec.Char
+import Text.Megaparsec.Lexer (integer)
 import Text.Megaparsec.Perm
 
 import Util
@@ -43,7 +44,8 @@ import Util
 tests :: Test
 tests = testGroup "Permutation phrases parsers"
   [ testProperty "permutation parser pure" prop_pure
-  , testProperty "permutation test 0"      prop_perm_0 ]
+  , testProperty "permutation test 0"      prop_perm_0
+  , testProperty "combinator (<$$>)"       prop_ddcomb ]
 
 data CharRows = CharRows
   { getChars :: (Char, Char, Char)
@@ -92,3 +94,10 @@ prop_perm_0 a' c' v = checkParser (makePermParser p) r s
         cis  = elemIndices c s
         prec = take (cis !! 1) s
         s    = getInput v
+
+prop_ddcomb :: NonNegative Integer -> Property
+prop_ddcomb n' = checkParser (makePermParser p) r s
+  where p = succ <$$> integer
+        r = Right (succ n)
+        n = getNonNegative n'
+        s = show n

tests/Prim.hs

@@ -26,6 +26,7 @@
 -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 -- POSSIBILITY OF SUCH DAMAGE.
 
+{-# LANGUAGE Rank2Types       #-}
 {-# OPTIONS -fno-warn-orphans #-}
 
 module Prim (tests) where
@@ -40,7 +41,6 @@ import Control.Monad.Cont
 import Control.Monad.Except
 import Control.Monad.Identity
 import Control.Monad.Reader
-import Control.Monad.Trans.Identity
 import qualified Control.Monad.State.Lazy    as L
 import qualified Control.Monad.State.Strict  as S
 import qualified Control.Monad.Writer.Lazy   as L
@@ -50,7 +50,7 @@ import Test.Framework
 import Test.Framework.Providers.HUnit (testCase)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 import Test.QuickCheck hiding (label)
-import Test.HUnit (Assertion, (@?=))
+import Test.HUnit (Assertion)
 
 import Text.Megaparsec.Char
 import Text.Megaparsec.Combinator
@@ -131,8 +131,6 @@ tests = testGroup "Primitive parser combinators"
   , testProperty "state on failure (tab)"           prop_stOnFail_1
   , testProperty "state on failure (eof)"           prop_stOnFail_2
   , testProperty "state on failure (notFollowedBy)" prop_stOnFail_3
-  , testProperty "IdentityT try"            prop_IdentityT_try
-  , testProperty "IdentityT notFollowedBy"  prop_IdentityT_notFollowedBy
   , testProperty "ReaderT try"              prop_ReaderT_try
   , testProperty "ReaderT notFollowedBy"    prop_ReaderT_notFollowedBy
   , testProperty "StateT alternative (<|>)" prop_StateT_alternative
@@ -303,35 +301,24 @@ prop_monad_error_catch a b =
 -- Primitive combinators
 
 prop_unexpected :: String -> Property
-prop_unexpected m = checkParser p r s
+prop_unexpected m = checkParser' p r s
-  where p = unexpected m :: Parser ()
+  where p :: MonadParsec s m Char => m String
-        r | null m    = posErr 0 s []
+        p = unexpected m
-          | otherwise = posErr 0 s [uneSpec m]
+        r = posErr 0 s $ if null m then [] else [uneSpec m]
         s = ""
 
 prop_failure :: [Message] -> Property
-prop_failure msgs = conjoin [ checkParser p r s
+prop_failure msgs = checkParser' p r s
-                            , checkParser (runIdentityT p_IdentityT) r s
+  where p :: MonadParsec s m Char => m String
-                            , checkParser (runReaderT p_ReaderT ()) r s
+        p = failure msgs
-                            , checkParser (L.evalStateT p_lStateT ()) r s
-                            , checkParser (S.evalStateT p_sStateT ()) r s
-                            , checkParser (L.runWriterT p_lWriterT) r s
-                            , checkParser (S.runWriterT p_sWriterT) r s ]
-  where p = failure msgs :: Parser ()
-        p_IdentityT = failure msgs :: IdentityT Parser ()
-        p_ReaderT   = failure msgs :: ReaderT () Parser ()
-        p_lStateT   = failure msgs :: L.StateT () Parser ()
-        p_sStateT   = failure msgs :: S.StateT () Parser ()
-        p_lWriterT  = failure msgs :: L.WriterT [Integer] Parser ()
-        p_sWriterT  = failure msgs :: S.WriterT [Integer] Parser ()
         r | null msgs = posErr 0 s []
           | otherwise = Left $ newErrorMessages msgs (initialPos "")
         s = ""
 
 prop_label :: NonNegative Int -> NonNegative Int
            -> NonNegative Int -> String -> Property
-prop_label a' b' c' l = checkParser p r s
+prop_label a' b' c' l = checkParser' p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
+  where p :: MonadParsec s m Char => m String
         p = (++) <$> many (char 'a') <*> (many (char 'b') <?> l)
         r | null s = Right s
           | c > 0 = posErr (a + b) s $ [uneCh 'c', exEof]
@@ -341,39 +328,43 @@ prop_label a' b' c' l = checkParser p r s
                         else exSpec $ "rest of " ++ l]
           | otherwise = Right s
         s = abcRow a b c
+        [a,b,c] = getNonNegative <$> [a',b',c']
 
 prop_hidden_0 :: NonNegative Int -> NonNegative Int
               -> NonNegative Int -> Property
-prop_hidden_0 a' b' c' = checkParser p r s
+prop_hidden_0 a' b' c' = checkParser' p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
+  where p :: MonadParsec s m Char => m String
         p = (++) <$> many (char 'a') <*> hidden (many (char 'b'))
         r | null s = Right s
           | c > 0  = posErr (a + b) s $ [uneCh 'c', exEof]
                      ++ [exCh 'a' | b == 0]
           | otherwise = Right s
         s = abcRow a b c
+        [a,b,c] = getNonNegative <$> [a',b',c']
 
 prop_hidden_1 :: NonEmptyList Char -> String -> Property
-prop_hidden_1 c' s = checkParser p r s
+prop_hidden_1 c' s = checkParser' p r s
-  where c = getNonEmpty c'
+  where p :: MonadParsec s m Char => m (Maybe String)
-        cn = length c
         p = optional (hidden $ string c)
         r | null s           = Right Nothing
           | c == s           = Right (Just s)
           | c `isPrefixOf` s = posErr cn s [uneCh (s !! cn), exEof]
           | otherwise        = posErr 0 s [uneCh (head s), exEof]
+        c = getNonEmpty c'
+        cn = length c
 
 prop_try :: Char -> Char -> Char -> Property
-prop_try pre ch1 ch2 = checkParser p r s
+prop_try pre ch1 ch2 = checkParser' p r s
-  where s1 = sequence [char pre, char ch1]
+  where p :: MonadParsec s m Char => m String
-        s2 = sequence [char pre, char ch2]
+        p = try (sequence [char pre, char ch1])
-        p = try s1 <|> s2
+          <|> sequence [char pre, char ch2]
         r = posErr 1 s [uneEof, exCh ch1, exCh ch2]
         s = [pre]
 
 prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property
-prop_lookAhead_0 a b c = checkParser p r s
+prop_lookAhead_0 a b c = checkParser' p r s
-  where p = do
+  where p :: MonadParsec s m Char => m Char
+        p = do
           l <- lookAhead (oneOf "ab" <?> "label")
           guard (l == h)
           char 'a'
@@ -386,158 +377,199 @@ prop_lookAhead_0 a b c = checkParser p r s
         s = abcRow a b c
 
 prop_lookAhead_1 :: String -> Property
-prop_lookAhead_1 s = checkParser p r s
+prop_lookAhead_1 s = checkParser' p r s
-  where p = lookAhead (some letterChar) >> fail "failed" :: Parser ()
+  where p :: MonadParsec s m Char => m ()
+        p = lookAhead (some letterChar) >> fail "failed"
         h = head s
         r | null s     = posErr 0 s [uneEof, exSpec "letter"]
           | isLetter h = posErr 0 s [msg "failed"]
           | otherwise  = posErr 0 s [uneCh h, exSpec "letter"]
 
 prop_lookAhead_2 :: Bool -> Bool -> Bool -> Property
-prop_lookAhead_2 a b c = checkParser p r s
+prop_lookAhead_2 a b c = checkParser' p r s
-  where p = lookAhead (some (char 'a')) >> char 'b'
+  where p :: MonadParsec s m Char => m Char
+        p = lookAhead (some (char 'a')) >> char 'b'
         r | null s    = posErr 0 s [uneEof, exCh 'a']
           | a         = posErr 0 s [uneCh 'a', exCh 'b']
           | otherwise = posErr 0 s [uneCh (head s), exCh 'a']
         s = abcRow a b c
 
 case_lookAhead_3 :: Assertion
-case_lookAhead_3 = parse p "" s @?= posErr 1 s [msg emsg]
+case_lookAhead_3 = checkCase p r s
-  where p    = lookAhead (char 'a' *> fail emsg) :: Parser String
+  where p :: MonadParsec s m Char => m String
+        p = lookAhead (char 'a' *> fail emsg)
+        r = posErr 1 s [msg emsg]
         emsg = "ops!"
-        s    = "abc"
+        s = "abc"
 
 prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int
                      -> NonNegative Int -> Property
-prop_notFollowedBy_0 a' b' c' = checkParser p r s
+prop_notFollowedBy_0 a' b' c' = checkParser' p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
+  where p :: MonadParsec s m Char => m String
         p = many (char 'a') <* notFollowedBy (char 'b') <* many (char 'c')
-        r | b > 0 = posErr a s [uneCh 'b', exCh 'a']
+        r | b > 0     = posErr a s [uneCh 'b', exCh 'a']
           | otherwise = Right (replicate a 'a')
         s = abcRow a b c
+        [a,b,c] = getNonNegative <$> [a',b',c']
 
 prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int
                      -> NonNegative Int -> Property
-prop_notFollowedBy_1 a' b' c' = checkParser p r s
+prop_notFollowedBy_1 a' b' c' = checkParser' p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
+  where p :: MonadParsec s m Char => m String
-        p = many (char 'a') <* f (char 'c') <* many (char 'c')
+        p = many (char 'a')
-        f = notFollowedBy . notFollowedBy -- = 'lookAhead' in this case
+          <* (notFollowedBy . notFollowedBy) (char 'c')
+          <* many (char 'c')
         r | b == 0 && c > 0 = Right (replicate a 'a')
           | b > 0           = posErr a s [uneCh 'b', exCh 'a']
           | otherwise       = posErr a s [uneEof, exCh 'a']
         s = abcRow a b c
+        [a,b,c] = getNonNegative <$> [a',b',c']
 
 prop_notFollowedBy_2 :: NonNegative Int -> NonNegative Int
                      -> NonNegative Int -> Property
-prop_notFollowedBy_2 a' b' c' = checkParser p r s
+prop_notFollowedBy_2 a' b' c' = checkParser' p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
+  where p :: MonadParsec s m Char => m String
         p = many (char 'a') <* notFollowedBy eof <* many anyChar
         r | b > 0 || c > 0 = Right (replicate a 'a')
           | otherwise      = posErr a s [uneEof, exCh 'a']
         s = abcRow a b c
+        [a,b,c] = getNonNegative <$> [a',b',c']
 
 case_notFollowedBy_3a :: Assertion
-case_notFollowedBy_3a = parse p "" "ab" @?= Right ()
+case_notFollowedBy_3a = checkCase p r s
-  where p = notFollowedBy (char 'a' *> char 'c')
+  where p :: MonadParsec s m Char => m ()
+        p = notFollowedBy (char 'a' *> char 'c')
+        r = Right ()
+        s = "ab"
 
 case_notFollowedBy_3b :: Assertion
-case_notFollowedBy_3b = parse p "" s @?= posErr 0 s [uneCh 'a', exCh 'c']
+case_notFollowedBy_3b = checkCase p r s
-  where p = notFollowedBy (char 'a' *> char 'd') <* char 'c'
+  where p :: MonadParsec s m Char => m ()
+        p = notFollowedBy (char 'a' *> char 'd') <* char 'c'
+        r = posErr 0 s [uneCh 'a', exCh 'c']
         s = "ab"
 
 case_notFollowedBy_4a :: Assertion
-case_notFollowedBy_4a = parse p "" "ab" @?= Right ()
+case_notFollowedBy_4a = checkCase p r s
-  where p = notFollowedBy (fail "ops!")
+  where p :: MonadParsec s m Char => m ()
+        p = notFollowedBy mzero
+        r = Right ()
+        s = "ab"
 
 case_notFollowedBy_4b :: Assertion
-case_notFollowedBy_4b = parse p "" s @?= posErr 0 s [uneCh 'a', exCh 'c']
+case_notFollowedBy_4b = checkCase p r s
-  where p = notFollowedBy (fail "ops!") <* char 'c'
+  where p :: MonadParsec s m Char => m ()
+        p = notFollowedBy mzero <* char 'c'
+        r = posErr 0 s [uneCh 'a', exCh 'c']
         s = "ab"
 
 prop_withRecovery_0 :: NonNegative Int -> NonNegative Int
-                  -> NonNegative Int -> Property
+                    -> NonNegative Int -> Property
-prop_withRecovery_0 a' b' c' = checkParser p r s
+prop_withRecovery_0 a' b' c' = checkParser' p r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
+  where
-        p = v <$>
+    p :: MonadParsec s m Char => m (Either ParseError String)
-          withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'
+    p = let g = count' 1 3 . char in v <$>
-        v (Right x) y = Right (x ++ y)
+      withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'
-        v (Left  m) _ = Left m
+    v (Right x) y = Right (x ++ y)
-        g = count' 1 3 . char
+    v (Left  m) _ = Left m
-        r | a == 0 && b == 0 && c == 0 = posErr 0 s [uneEof, exCh 'a']
+    r | a == 0 && b == 0 && c == 0 = posErr 0 s [uneEof, exCh 'a']
-          | a == 0 && b == 0 && c >  3 = posErr 0 s [uneCh 'c', exCh 'a']
+      | a == 0 && b == 0 && c >  3 = posErr 0 s [uneCh 'c', exCh 'a']
-          | a == 0 && b == 0           = posErr 0 s [uneCh 'c', exCh 'a']
+      | a == 0 && b == 0           = posErr 0 s [uneCh 'c', exCh 'a']
-          | a == 0 && b >  3           = posErr 3 s [uneCh 'b', exCh 'a', exCh 'c']
+      | a == 0 && b >  3           = posErr 3 s [uneCh 'b', exCh 'a', exCh 'c']
-          | a == 0 &&           c == 0 = posErr b s [uneEof, exCh 'a', exCh 'c']
+      | a == 0 &&           c == 0 = posErr b s [uneEof, exCh 'a', exCh 'c']
-          | a == 0 &&           c >  3 = posErr (b + 3) s [uneCh 'c', exEof]
+      | a == 0 &&           c >  3 = posErr (b + 3) s [uneCh 'c', exEof]
-          | a == 0                     = Right (posErr 0 s [uneCh 'b', exCh 'a'])
+      | a == 0                     = Right (posErr 0 s [uneCh 'b', exCh 'a'])
-          | a >  3                     = posErr 3 s [uneCh 'a', exCh 'c']
+      | a >  3                     = posErr 3 s [uneCh 'a', exCh 'c']
-          |           b == 0 && c == 0 = posErr a s $ [uneEof, exCh 'c'] ++ ma
+      |           b == 0 && c == 0 = posErr a s $ [uneEof, exCh 'c'] ++ ma
-          |           b == 0 && c >  3 = posErr (a + 3) s [uneCh 'c', exEof]
+      |           b == 0 && c >  3 = posErr (a + 3) s [uneCh 'c', exEof]
-          |           b == 0           = Right (Right s)
+      |           b == 0           = Right (Right s)
-          | otherwise                  = posErr a s $ [uneCh 'b', exCh 'c'] ++ ma
+      | otherwise                  = posErr a s $ [uneCh 'b', exCh 'c'] ++ ma
-        ma = [exCh 'a' | a < 3]
+    ma = [exCh 'a' | a < 3]
-        s = abcRow a b c
+    s = abcRow a b c
+    [a,b,c] = getNonNegative <$> [a',b',c']
 
 case_withRecovery_1 :: Assertion
-case_withRecovery_1 = parse p "" "abc" @?= Right "foo"
+case_withRecovery_1 = checkCase p r s
-  where p = withRecovery (const $ return "bar") (return "foo")
+  where p :: MonadParsec s m Char => m String
+        p = withRecovery (const $ return "bar") (return "foo")
+        r = Right "foo"
+        s = "abc"
 
 case_withRecovery_2 :: Assertion
-case_withRecovery_2 = parse p "" s @?= posErr 0 s [uneCh 'a', exStr "cba"]
+case_withRecovery_2 = checkCase p r s
-  where p = withRecovery (\_ -> char 'a' *> fail "ops!") (string "cba")
+  where p :: MonadParsec s m Char => m String
+        p = withRecovery (\_ -> char 'a' *> mzero) (string "cba")
+        r = posErr 0 s [uneCh 'a', exStr "cba"]
         s = "abc"
 
 case_withRecovery_3a :: Assertion
-case_withRecovery_3a = parse p "" "abc" @?= Right "abd"
+case_withRecovery_3a = checkCase p r s
-  where p = withRecovery (const $ return "abd") (string "cba")
+  where p :: MonadParsec s m Char => m String
+        p = withRecovery (const $ return "abd") (string "cba")
+        r = Right "abd"
+        s = "abc"
 
 case_withRecovery_3b :: Assertion
-case_withRecovery_3b = parse p "" s @?= posErr 0 s r
+case_withRecovery_3b = checkCase p r s
-  where p = withRecovery (const $ return "abd") (string "cba") <* char 'd'
+  where p :: MonadParsec s m Char => m String
-        r = [uneCh 'a', exStr "cba", exCh 'd']
+        p = withRecovery (const $ return "abd") (string "cba") <* char 'd'
+        r = posErr 0 s [uneCh 'a', exStr "cba", exCh 'd']
         s = "abc"
 
 case_withRecovery_4a :: Assertion
-case_withRecovery_4a = parse p "" "abc" @?= Right "bc"
+case_withRecovery_4a = checkCase p r s
-  where p = withRecovery (const $ string "bc") (char 'a' *> fail "ops!")
+  where p :: MonadParsec s m Char => m String
+        p = withRecovery (const $ string "bc") (char 'a' *> mzero)
+        r = Right "bc"
+        s = "abc"
 
 case_withRecovery_4b :: Assertion
-case_withRecovery_4b = parse p "" s @?= posErr 3 s [uneEof, exCh 'f']
+case_withRecovery_4b = checkCase p r s
-  where p = withRecovery (const $ string "bc") h <* char 'f'
+  where p :: MonadParsec s m Char => m String
-        h = char 'a' *> char 'd' *> pure "foo"
+        p = withRecovery (const $ string "bc")
+          (char 'a' *> char 'd' *> pure "foo") <* char 'f'
+        r = posErr 3 s [uneEof, exCh 'f']
         s = "abc"
 
 case_withRecovery_5 :: Assertion
-case_withRecovery_5 = parse p "" s @?= posErr 1 s [msg emsg]
+case_withRecovery_5 = checkCase p r s
-  where p :: Parser String
+  where p :: MonadParsec s m Char => m String
         p = withRecovery (\_ -> char 'b' *> fail emsg) (char 'a' *> fail emsg)
+        r = posErr 1 s [msg emsg]
         emsg = "ops!"
         s = "abc"
 
 case_withRecovery_6a :: Assertion
-case_withRecovery_6a = parse p "" "abc" @?= Right "abd"
+case_withRecovery_6a = checkCase p r s
-  where p = withRecovery (const $ return "abd") (char 'a' *> fail "ops!")
+  where p :: MonadParsec s m Char => m String
+        p = withRecovery (const $ return "abd") (char 'a' *> mzero)
+        r = Right "abd"
+        s = "abc"
 
 case_withRecovery_6b :: Assertion
-case_withRecovery_6b = parse p "" "abc" @?= posErr 1 s r
+case_withRecovery_6b = checkCase p r s
-  where p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f'
+  where p :: MonadParsec s m Char => m Char
-        r = [uneCh 'b', exCh 'd', exCh 'f']
+        p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f'
+        r = posErr 1 s [uneCh 'b', exCh 'd', exCh 'f']
         s = "abc"
 
 case_withRecovery_7 :: Assertion
-case_withRecovery_7 = parse p "" s @?= posErr 1 s [uneCh 'b', exCh 'd']
+case_withRecovery_7 = checkCase p r s
-  where p = withRecovery (const $ fail "ops!") (char 'a' *> char 'd')
+  where p :: MonadParsec s m Char => m Char
+        p = withRecovery (const mzero) (char 'a' *> char 'd')
+        r = posErr 1 s [uneCh 'b', exCh 'd']
         s = "abc"
 
 case_eof :: Assertion
-case_eof = parse eof "" "" @?= Right ()
+case_eof = checkCase eof (Right ()) ""
 
 prop_token :: String -> Property
-prop_token s = checkParser p r s
+prop_token s = checkParser' p r s
-  where p = token updatePosChar testChar
+  where p :: MonadParsec s m Char => m Char
+        p = token updatePosChar testChar
         testChar x = if isLetter x
-                     then Right x
+          then Right x
-                     else Left . pure . Unexpected . showToken $ x
+          else Left . pure . Unexpected . showToken $ x
         h = head s
         r | null s = posErr 0 s [uneEof]
           | isLetter h && length s == 1 = Right (head s)
@@ -570,14 +602,17 @@ prop_state_tab w = p /=\ w
   where p = setTabWidth w >> getTabWidth
 
 prop_state :: State String -> State String -> Property
-prop_state s1 s2 = runParser p "" "" === Right (f s2 s1)
+prop_state s1 s2 = checkParser' p r s
-  where f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w
+  where p :: MonadParsec String m Char => m (State String)
         p = do
           st <- getParserState
-          guard (st == State "" (initialPos "") defaultTabWidth)
+          guard (st == State s (initialPos "") defaultTabWidth)
           setParserState s1
           updateParserState (f s2)
-          getParserState
+          liftM2 const getParserState (setInput "")
+        f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w
+        r = Right (f s2 s1)
+        s = ""
 
 -- Running a parser
 
@@ -639,25 +674,6 @@ prop_stOnFail_3 s = runParser' p (stateFromInput s) === (i, r)
 stateFromInput :: Stream s t => s -> State s
 stateFromInput s = State s (initialPos "") defaultTabWidth
 
--- IdentityT instance of MonadParsec
-
-prop_IdentityT_try :: Char -> Char -> Char -> Property
-prop_IdentityT_try pre ch1 ch2 = checkParser (runIdentityT p) r s
-  where s1 = sequence [char pre, char ch1]
-        s2 = sequence [char pre, char ch2]
-        p = try s1 <|> s2
-        r = posErr 1 s [uneEof, exCh ch1, exCh ch2]
-        s = [pre]
-
-prop_IdentityT_notFollowedBy :: NonNegative Int -> NonNegative Int
-                             -> NonNegative Int -> Property
-prop_IdentityT_notFollowedBy a' b' c' = checkParser (runIdentityT p) r s
-  where [a,b,c] = getNonNegative <$> [a',b',c']
-        p = many (char 'a') <* notFollowedBy eof <* many anyChar
-        r | b > 0 || c > 0 = Right (replicate a 'a')
-          | otherwise      = posErr a s [uneEof, exCh 'a']
-        s = abcRow a b c
-
 -- ReaderT instance of MonadParsec
 
 prop_ReaderT_try :: Char -> Char -> Char -> Property

tests/Util.hs

@@ -26,8 +26,12 @@
 -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 -- POSSIBILITY OF SUCH DAMAGE.
 
+{-# LANGUAGE Rank2Types #-}
+
 module Util
   ( checkParser
+  , checkParser'
+  , checkCase
   , simpleParse
   , checkChar
   , checkString
@@ -47,9 +51,16 @@ module Util
   , showToken )
 where
 
+import Control.Monad.Reader
+import Control.Monad.Trans.Identity
 import Data.Maybe (maybeToList)
+import qualified Control.Monad.State.Lazy    as L
+import qualified Control.Monad.State.Strict  as S
+import qualified Control.Monad.Writer.Lazy   as L
+import qualified Control.Monad.Writer.Strict as S
 
 import Test.QuickCheck
+import Test.HUnit (Assertion, (@?=))
 
 import Text.Megaparsec.Error
 import Text.Megaparsec.Pos
@@ -66,9 +77,51 @@ import Control.Applicative ((<$>), (<*))
 -- it should match, otherwise the property doesn't hold and the test fails.
 
 checkParser :: (Eq a, Show a)
-            => Parser a -> Either ParseError a -> String -> Property
+  => Parser a          -- ^ Parser to test
+  -> Either ParseError a -- ^ Expected result of parsing
+  -> String            -- ^ Input for the parser
+  -> Property          -- ^ Resulting property
 checkParser p r s = simpleParse p s === r
 
+-- | A variant of 'checkParser' that runs given parser code with all
+-- standard instances of 'MonadParsec'. Useful when testing primitive
+-- combinators.
+
+checkParser' :: (Eq a, Show a)
+  => (forall m. MonadParsec String m Char => m a) -- ^ Parser to test
+  -> Either ParseError a -- ^ Expected result of parsing
+  -> String            -- ^ Input for the parser
+  -> Property          -- ^ Resulting property
+checkParser' p r s = conjoin
+  [ checkParser p                   r s
+  , checkParser (runIdentityT p)    r s
+  , checkParser (runReaderT   p ()) r s
+  , checkParser (L.evalStateT p ()) r s
+  , checkParser (S.evalStateT p ()) r s
+  , checkParser (evalWriterTL p)    r s
+  , checkParser (evalWriterTS p)    r s ]
+
+-- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead.
+
+checkCase :: (Eq a, Show a)
+  => (forall m. MonadParsec String m Char => m a) -- ^ Parser to test
+  -> Either ParseError a -- ^ Expected result of parsing
+  -> String            -- ^ Input for the parser
+  -> Assertion         -- ^ Resulting assertion
+checkCase p r s = do
+  parse p                   "" s @?= r
+  parse (runIdentityT p)    "" s @?= r
+  parse (runReaderT   p ()) "" s @?= r
+  parse (L.evalStateT p ()) "" s @?= r
+  parse (S.evalStateT p ()) "" s @?= r
+  parse (evalWriterTL p)    "" s @?= r
+  parse (evalWriterTS p)    "" s @?= r
+
+evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a
+evalWriterTL = liftM fst . L.runWriterT
+evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a
+evalWriterTS = liftM fst . S.runWriterT
+
 -- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding
 -- result of type @Either ParseError a@, where @a@ is type of parsed
 -- value. This parser tries to parser end of file too and name of input file