mirror of
https://github.com/mrkkrp/megaparsec.git
synced 2024-11-23 19:38:05 +03:00
Merge branch 'improving-coverage'
This commit is contained in:
mrkkrp
commit
c99c4fa8ed
@ -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
|
||||
|
||||
@ -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 f ms = Just . f $ messageString <$> ms
|
||||
-- renderMsgs _ [] = Nothing
|
||||
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 [] = ""
|
||||
orList [x] = x
|
||||
orList [x,y] = x ++ " or " ++ y
|
||||
orList xs = intercalate ", " (init xs) ++ ", or " ++ last xs
|
||||
orList :: NonEmpty String -> String
|
||||
orList (x:|[]) = x
|
||||
orList (x:|[y]) = x ++ " or " ++ y
|
||||
orList xs = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs
|
||||
|
||||
@ -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)
|
||||
=> MonadParsec s m t | m -> s t where
|
||||
class (A.Alternative m, MonadPlus m, Stream s t)
|
||||
=> 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) =>
|
||||
MonadParsec s (L.StateT e m) t where
|
||||
instance MonadParsec s m t => 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)
|
||||
=> MonadParsec s (S.StateT e m) t where
|
||||
instance MonadParsec s m t => 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)
|
||||
=> MonadParsec s (L.ReaderT e m) t where
|
||||
instance MonadParsec s m t => 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)
|
||||
=> MonadParsec s (L.WriterT w m) t where
|
||||
instance (Monoid w, MonadParsec s m t) => 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)
|
||||
=> MonadParsec s (S.WriterT w m) t where
|
||||
instance (Monoid w, MonadParsec s m t) => 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)
|
||||
=> MonadParsec s (IdentityT m) t where
|
||||
instance MonadParsec s m t => MonadParsec s (IdentityT m) t where
|
||||
failure = lift . failure
|
||||
label n (IdentityT m) = IdentityT $ label n m
|
||||
try = IdentityT . try . runIdentityT
|
||||
|
||||
@ -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
|
||||
|
||||
280
tests/Prim.hs
280
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
|
||||
where p = unexpected m :: Parser ()
|
||||
r | null m = posErr 0 s []
|
||||
| otherwise = posErr 0 s [uneSpec m]
|
||||
prop_unexpected m = checkParser' p r s
|
||||
where p :: MonadParsec s m Char => m String
|
||||
p = unexpected 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
|
||||
, checkParser (runIdentityT p_IdentityT) r s
|
||||
, checkParser (runReaderT p_ReaderT ()) r s
|
||||
, 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 ()
|
||||
prop_failure msgs = checkParser' p r s
|
||||
where p :: MonadParsec s m Char => m String
|
||||
p = failure msgs
|
||||
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
|
||||
where [a,b,c] = getNonNegative <$> [a',b',c']
|
||||
prop_label a' b' c' l = checkParser' p r s
|
||||
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
|
||||
where [a,b,c] = getNonNegative <$> [a',b',c']
|
||||
prop_hidden_0 a' b' c' = checkParser' p r s
|
||||
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
|
||||
where c = getNonEmpty c'
|
||||
cn = length c
|
||||
prop_hidden_1 c' s = checkParser' p r s
|
||||
where p :: MonadParsec s m Char => m (Maybe String)
|
||||
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
|
||||
where s1 = sequence [char pre, char ch1]
|
||||
s2 = sequence [char pre, char ch2]
|
||||
p = try s1 <|> s2
|
||||
prop_try pre ch1 ch2 = checkParser' p r s
|
||||
where p :: MonadParsec s m Char => m String
|
||||
p = try (sequence [char pre, char ch1])
|
||||
<|> 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
|
||||
where p = do
|
||||
prop_lookAhead_0 a b c = checkParser' p r s
|
||||
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
|
||||
where p = lookAhead (some letterChar) >> fail "failed" :: Parser ()
|
||||
prop_lookAhead_1 s = checkParser' p r s
|
||||
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
|
||||
where p = lookAhead (some (char 'a')) >> char 'b'
|
||||
prop_lookAhead_2 a b c = checkParser' p r s
|
||||
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]
|
||||
where p = lookAhead (char 'a' *> fail emsg) :: Parser String
|
||||
case_lookAhead_3 = checkCase p r s
|
||||
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
|
||||
where [a,b,c] = getNonNegative <$> [a',b',c']
|
||||
prop_notFollowedBy_0 a' b' c' = checkParser' p r s
|
||||
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
|
||||
where [a,b,c] = getNonNegative <$> [a',b',c']
|
||||
p = many (char 'a') <* f (char 'c') <* many (char 'c')
|
||||
f = notFollowedBy . notFollowedBy -- = 'lookAhead' in this case
|
||||
prop_notFollowedBy_1 a' b' c' = checkParser' p r s
|
||||
where p :: MonadParsec s m Char => m String
|
||||
p = many (char 'a')
|
||||
<* (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
|
||||
where [a,b,c] = getNonNegative <$> [a',b',c']
|
||||
prop_notFollowedBy_2 a' b' c' = checkParser' p r s
|
||||
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 ()
|
||||
where p = notFollowedBy (char 'a' *> char 'c')
|
||||
case_notFollowedBy_3a = checkCase p r s
|
||||
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']
|
||||
where p = notFollowedBy (char 'a' *> char 'd') <* char 'c'
|
||||
case_notFollowedBy_3b = checkCase p r s
|
||||
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 ()
|
||||
where p = notFollowedBy (fail "ops!")
|
||||
case_notFollowedBy_4a = checkCase p r s
|
||||
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']
|
||||
where p = notFollowedBy (fail "ops!") <* char 'c'
|
||||
case_notFollowedBy_4b = checkCase p r s
|
||||
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
|
||||
prop_withRecovery_0 a' b' c' = checkParser p r s
|
||||
where [a,b,c] = getNonNegative <$> [a',b',c']
|
||||
p = v <$>
|
||||
withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'
|
||||
v (Right x) y = Right (x ++ y)
|
||||
v (Left m) _ = Left m
|
||||
g = count' 1 3 . char
|
||||
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 = posErr 0 s [uneCh 'c', exCh 'a']
|
||||
| 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 > 3 = posErr (b + 3) s [uneCh 'c', exEof]
|
||||
| a == 0 = Right (posErr 0 s [uneCh 'b', exCh 'a'])
|
||||
| a > 3 = posErr 3 s [uneCh 'a', exCh 'c']
|
||||
| b == 0 && c == 0 = posErr a s $ [uneEof, exCh 'c'] ++ ma
|
||||
| b == 0 && c > 3 = posErr (a + 3) s [uneCh 'c', exEof]
|
||||
| b == 0 = Right (Right s)
|
||||
| otherwise = posErr a s $ [uneCh 'b', exCh 'c'] ++ ma
|
||||
ma = [exCh 'a' | a < 3]
|
||||
s = abcRow a b c
|
||||
-> NonNegative Int -> Property
|
||||
prop_withRecovery_0 a' b' c' = checkParser' p r s
|
||||
where
|
||||
p :: MonadParsec s m Char => m (Either ParseError String)
|
||||
p = let g = count' 1 3 . char in v <$>
|
||||
withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'
|
||||
v (Right x) y = Right (x ++ y)
|
||||
v (Left m) _ = Left m
|
||||
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 = posErr 0 s [uneCh 'c', exCh 'a']
|
||||
| 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 > 3 = posErr (b + 3) s [uneCh 'c', exEof]
|
||||
| a == 0 = Right (posErr 0 s [uneCh 'b', exCh 'a'])
|
||||
| a > 3 = posErr 3 s [uneCh 'a', exCh 'c']
|
||||
| b == 0 && c == 0 = posErr a s $ [uneEof, exCh 'c'] ++ ma
|
||||
| b == 0 && c > 3 = posErr (a + 3) s [uneCh 'c', exEof]
|
||||
| b == 0 = Right (Right s)
|
||||
| otherwise = posErr a s $ [uneCh 'b', exCh 'c'] ++ ma
|
||||
ma = [exCh 'a' | a < 3]
|
||||
s = abcRow a b c
|
||||
[a,b,c] = getNonNegative <$> [a',b',c']
|
||||
|
||||
case_withRecovery_1 :: Assertion
|
||||
case_withRecovery_1 = parse p "" "abc" @?= Right "foo"
|
||||
where p = withRecovery (const $ return "bar") (return "foo")
|
||||
case_withRecovery_1 = checkCase p r s
|
||||
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"]
|
||||
where p = withRecovery (\_ -> char 'a' *> fail "ops!") (string "cba")
|
||||
case_withRecovery_2 = checkCase p r s
|
||||
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"
|
||||
where p = withRecovery (const $ return "abd") (string "cba")
|
||||
case_withRecovery_3a = checkCase p r s
|
||||
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
|
||||
where p = withRecovery (const $ return "abd") (string "cba") <* char 'd'
|
||||
r = [uneCh 'a', exStr "cba", exCh 'd']
|
||||
case_withRecovery_3b = checkCase p r s
|
||||
where p :: MonadParsec s m Char => m String
|
||||
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"
|
||||
where p = withRecovery (const $ string "bc") (char 'a' *> fail "ops!")
|
||||
case_withRecovery_4a = checkCase p r s
|
||||
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']
|
||||
where p = withRecovery (const $ string "bc") h <* char 'f'
|
||||
h = char 'a' *> char 'd' *> pure "foo"
|
||||
case_withRecovery_4b = checkCase p r s
|
||||
where p :: MonadParsec s m Char => m String
|
||||
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]
|
||||
where p :: Parser String
|
||||
case_withRecovery_5 = checkCase p r s
|
||||
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"
|
||||
where p = withRecovery (const $ return "abd") (char 'a' *> fail "ops!")
|
||||
case_withRecovery_6a = checkCase p r s
|
||||
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
|
||||
where p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f'
|
||||
r = [uneCh 'b', exCh 'd', exCh 'f']
|
||||
case_withRecovery_6b = checkCase p r s
|
||||
where p :: MonadParsec s m Char => m Char
|
||||
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']
|
||||
where p = withRecovery (const $ fail "ops!") (char 'a' *> char 'd')
|
||||
case_withRecovery_7 = checkCase p r s
|
||||
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
|
||||
where p = token updatePosChar testChar
|
||||
prop_token s = checkParser' p r s
|
||||
where p :: MonadParsec s m Char => m Char
|
||||
p = token updatePosChar testChar
|
||||
testChar x = if isLetter x
|
||||
then Right x
|
||||
else Left . pure . Unexpected . showToken $ x
|
||||
then Right 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)
|
||||
where f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w
|
||||
prop_state s1 s2 = checkParser' p r s
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user