mirror of
https://github.com/mrkkrp/megaparsec.git
synced 2024-12-02 16:11:03 +03:00
Merge pull request #86 from mrkkrp/recovery-feature
Implement the recovery feature
This commit is contained in:
Mark Karpov
commit
a8bb4d9e10
18
CHANGELOG.md
18
CHANGELOG.md
@ -3,14 +3,24 @@
|
||||
* Now state returned on failure is the exact state of parser at the moment
|
||||
when it failed, which makes incremental parsing feature much better and
|
||||
opens possibilities for features like “on-the-fly” recovering from parse
|
||||
errors. This made `<|>` operator slower, it's now about 9 % slower than
|
||||
equivalent Parsec's operator and 28 % slower than previous version of
|
||||
Megaparsec. However, other combinators showed no performance degradation
|
||||
and Megaparsec is still generally faster than Parsec.
|
||||
errors.
|
||||
|
||||
* The `count` combinator now works with `Applicative` instances (previously
|
||||
it worked only with instances of `Alternative`). It's now also faster.
|
||||
|
||||
* `tokens` and parsers built upon it (such as `string` and `string'`)
|
||||
backtrack automatically on failure now, that is, when they fail, they
|
||||
never consume any input. This is done to make their consumption model
|
||||
match how error messages are reported (which becomes an important thing as
|
||||
user gets more control with primitives like `withRecovery`). This means,
|
||||
in particular, that it's no longer necessary to use `try` with
|
||||
`tokens`-based parsers. This new feature *does not* affect performance in
|
||||
any way.
|
||||
|
||||
* New primitive parser `withRecovery` added. The parser allows to recover
|
||||
from parse errors “on-the-fly” and continue parsing. Once parsing is
|
||||
finished, several parse errors may be reported or ignored altogether.
|
||||
|
||||
## Megaparsec 4.3.0
|
||||
|
||||
* Canonicalized `Applicative`/`Monad` instances. Thanks to Herbert Valerio
|
||||
|
||||
@ -76,6 +76,10 @@ via combination of these primitives:
|
||||
* `notFollowedBy` succeeds when its argument fails, it does not consume
|
||||
input.
|
||||
|
||||
* `withRecovery` allows to recover from parse errors “on-the-fly” and
|
||||
continue parsing. Once parsing is finished, several parse errors may be
|
||||
reported or ignored altogether.
|
||||
|
||||
* `eof` only succeeds at the end of input.
|
||||
|
||||
* `token` is used to parse single token.
|
||||
|
||||
@ -67,6 +67,7 @@ module Text.Megaparsec
|
||||
, try
|
||||
, lookAhead
|
||||
, notFollowedBy
|
||||
, withRecovery
|
||||
, eof
|
||||
, token
|
||||
, tokens
|
||||
|
||||
@ -100,10 +100,7 @@ endBy1 p sep = some (p <* sep)
|
||||
-- parser @end@ succeeds. Returns the list of values returned by @p@. This
|
||||
-- parser can be used to scan comments:
|
||||
--
|
||||
-- > simpleComment = string "<!--" >> manyTill anyChar (try $ string "-->")
|
||||
--
|
||||
-- Note that we need to use 'try' since parsers @anyChar@ and @string
|
||||
-- \"-->\"@ overlap and @string \"-->\"@ could consume input before failing.
|
||||
-- > simpleComment = string "<!--" >> manyTill anyChar (string "-->")
|
||||
|
||||
manyTill :: Alternative m => m a -> m end -> m [a]
|
||||
manyTill p end = ([] <$ end) <|> someTill p end
|
||||
|
||||
@ -73,9 +73,6 @@ data Operator m a
|
||||
-- > binary name f = InfixL (reservedOp name >> return f)
|
||||
-- > prefix name f = Prefix (reservedOp name >> return f)
|
||||
-- > postfix name f = Postfix (reservedOp name >> return f)
|
||||
--
|
||||
-- Please note that multi-character operators should use 'try' in order to
|
||||
-- be reported correctly in error messages.
|
||||
|
||||
makeExprParser :: MonadParsec s m t => m a -> [[Operator m a]] -> m a
|
||||
makeExprParser = foldl addPrecLevel
|
||||
|
||||
@ -148,7 +148,7 @@ skipLineComment :: MonadParsec s m Char
|
||||
=> String -- ^ Line comment prefix
|
||||
-> m ()
|
||||
skipLineComment prefix = p >> void (manyTill C.anyChar n)
|
||||
where p = try (C.string prefix)
|
||||
where p = C.string prefix
|
||||
n = lookAhead C.newline
|
||||
|
||||
-- | @skipBlockComment start end@ skips non-nested block comment starting
|
||||
@ -159,8 +159,8 @@ skipBlockComment :: MonadParsec s m Char
|
||||
-> String -- ^ End of block comment
|
||||
-> m ()
|
||||
skipBlockComment start end = p >> void (manyTill C.anyChar n)
|
||||
where p = try (C.string start)
|
||||
n = try (C.string end)
|
||||
where p = C.string start
|
||||
n = C.string end
|
||||
|
||||
-- Indentation
|
||||
|
||||
|
||||
@ -388,9 +388,9 @@ pZero = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->
|
||||
pPlus :: ParsecT s m a -> ParsecT s m a -> ParsecT s m a
|
||||
pPlus m n = ParsecT $ \s cok cerr eok eerr ->
|
||||
let meerr err ms =
|
||||
let ncerr err' s' = cerr (mergeError err' err) (longestMatch ms s')
|
||||
let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')
|
||||
neok x s' hs = eok x s' (toHints err <> hs)
|
||||
neerr err' s' = eerr (mergeError err' err) (longestMatch ms s')
|
||||
neerr err' s' = eerr (err' <> err) (longestMatch ms s')
|
||||
in unParser n s cok ncerr neok neerr
|
||||
in unParser m s cok cerr eok meerr
|
||||
{-# INLINE pPlus #-}
|
||||
@ -458,6 +458,11 @@ class (A.Alternative m, Monad m, Stream s t)
|
||||
-- 1:1:
|
||||
-- unexpected "le"
|
||||
-- expecting "let" or "lexical"
|
||||
--
|
||||
-- Please note that as of Megaparsec 4.4.0, 'string' backtracks
|
||||
-- automatically (see 'tokens'), so it does not need 'try'. However, the
|
||||
-- examples above demonstrate the idea behind 'try' so well that it was
|
||||
-- decided to keep them.
|
||||
|
||||
try :: m a -> m a
|
||||
|
||||
@ -474,6 +479,21 @@ class (A.Alternative m, Monad m, Stream s t)
|
||||
|
||||
notFollowedBy :: m a -> m ()
|
||||
|
||||
-- | @withRecovery r p@ allows continue parsing even if parser @p@
|
||||
-- fails. In this case @r@ is called with actual 'ParseError' as its
|
||||
-- argument. Typical usage is to return value signifying failure to parse
|
||||
-- this particular object and to consume some part of input up to start of
|
||||
-- next object.
|
||||
--
|
||||
-- Note that if @r@ fails, original error message is reported as if
|
||||
-- without 'withRecovery'. In no way recovering parser @r@ can influence
|
||||
-- error messages.
|
||||
|
||||
withRecovery
|
||||
:: (ParseError -> m a) -- ^ How to recover from failure
|
||||
-> m a -- ^ Original parser
|
||||
-> m a -- ^ Parser that can recover from failures
|
||||
|
||||
-- | This parser only succeeds at the end of the input.
|
||||
|
||||
eof :: m ()
|
||||
@ -509,6 +529,22 @@ class (A.Alternative m, Monad m, Stream s t)
|
||||
-- This can be used for example to write 'Text.Megaparsec.Char.string':
|
||||
--
|
||||
-- > string = tokens updatePosString (==)
|
||||
--
|
||||
-- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking
|
||||
-- primitive, which means that if it fails, it never consumes any
|
||||
-- input. This is done to make its consumption model match how error
|
||||
-- messages for this primitive are reported (which becomes an important
|
||||
-- thing as user gets more control with primitives like 'withRecovery'):
|
||||
--
|
||||
-- >>> parseTest (string "abc") "abd"
|
||||
-- 1:1:
|
||||
-- unexpected "abd"
|
||||
-- expecting "abc"
|
||||
--
|
||||
-- This means, in particular, that it's no longer necessary to use 'try'
|
||||
-- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and
|
||||
-- 'Text.Megaparsec.Char.string''. This new feature /does not/ affect
|
||||
-- performance in any way.
|
||||
|
||||
tokens :: Eq t
|
||||
=> (Int -> SourcePos -> [t] -> SourcePos)
|
||||
@ -533,6 +569,7 @@ instance Stream s t => MonadParsec s (ParsecT s m) t where
|
||||
try = pTry
|
||||
lookAhead = pLookAhead
|
||||
notFollowedBy = pNotFollowedBy
|
||||
withRecovery = pWithRecovery
|
||||
eof = pEof
|
||||
token = pToken
|
||||
tokens = pTokens
|
||||
@ -552,7 +589,8 @@ pLabel l p = ParsecT $ \s cok cerr eok eerr ->
|
||||
in unParser p s cok' cerr eok' eerr'
|
||||
|
||||
pTry :: ParsecT s m a -> ParsecT s m a
|
||||
pTry p = ParsecT $ \s cok _ eok eerr -> unParser p s cok eerr eok eerr
|
||||
pTry p = ParsecT $ \s cok _ eok eerr ->
|
||||
unParser p s cok eerr eok eerr
|
||||
{-# INLINE pTry #-}
|
||||
|
||||
pLookAhead :: ParsecT s m a -> ParsecT s m a
|
||||
@ -570,6 +608,26 @@ pNotFollowedBy p = ParsecT $ \s@(State input pos _) _ _ eok eerr ->
|
||||
eerr' _ _ = eok () s mempty
|
||||
in unParser p s cok' cerr' eok' eerr'
|
||||
|
||||
pWithRecovery :: Stream s t
|
||||
=> (ParseError -> ParsecT s m a)
|
||||
-> ParsecT s m a
|
||||
-> ParsecT s m a
|
||||
pWithRecovery r p = ParsecT $ \s cok cerr eok eerr ->
|
||||
let mcerr err ms =
|
||||
let rcok x s' _ = cok x s' mempty
|
||||
rcerr _ _ = cerr err ms
|
||||
reok x s' _ = eok x s' (toHints err)
|
||||
reerr _ _ = cerr err ms
|
||||
in unParser (r err) ms rcok rcerr reok reerr
|
||||
meerr err ms =
|
||||
let rcok x s' _ = cok x s' (toHints err)
|
||||
rcerr _ _ = eerr err ms
|
||||
reok x s' _ = eok x s' (toHints err)
|
||||
reerr _ _ = eerr err ms
|
||||
in unParser (r err) ms rcok rcerr reok reerr
|
||||
in unParser p s cok mcerr eok meerr
|
||||
{-# INLINE pWithRecovery #-}
|
||||
|
||||
pEof :: Stream s t => ParsecT s m ()
|
||||
pEof = label eoi $ ParsecT $ \s@(State input pos _) _ _ eok eerr ->
|
||||
case uncons input of
|
||||
@ -598,7 +656,7 @@ pTokens :: Stream s t
|
||||
-> [t]
|
||||
-> ParsecT s m [t]
|
||||
pTokens _ _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty
|
||||
pTokens nextpos test tts = ParsecT $ \s@(State input pos w) cok cerr _ eerr ->
|
||||
pTokens nextpos test tts = ParsecT $ \s@(State input pos w) cok _ _ eerr ->
|
||||
let r = showToken . reverse
|
||||
errExpect x = setErrorMessage (Expected $ showToken tts)
|
||||
(newErrorMessage (Unexpected x) pos)
|
||||
@ -607,13 +665,12 @@ pTokens nextpos test tts = ParsecT $ \s@(State input pos w) cok cerr _ eerr ->
|
||||
s' = State rs pos' w
|
||||
in cok (reverse is) s' mempty
|
||||
walk (t:ts) is rs =
|
||||
let errorCont = if null is then eerr else cerr
|
||||
what = if null is then eoi else r is
|
||||
let what = if null is then eoi else r is
|
||||
in case uncons rs of
|
||||
Nothing -> errorCont (errExpect what) s
|
||||
Nothing -> eerr (errExpect what) s
|
||||
Just (x,xs)
|
||||
| test t x -> walk ts (x:is) xs
|
||||
| otherwise -> errorCont (errExpect $ r (x:is)) s
|
||||
| otherwise -> eerr (errExpect $ r (x:is)) s
|
||||
in walk tts [] input
|
||||
{-# INLINE pTokens #-}
|
||||
|
||||
@ -830,13 +887,15 @@ parseFromFile p filename = runParser p filename <$> fromFile filename
|
||||
|
||||
instance (MonadPlus m, 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
|
||||
lookAhead (L.StateT m) = L.StateT $ \s ->
|
||||
(,s) . fst <$> lookAhead (m s)
|
||||
notFollowedBy (L.StateT m) = L.StateT $ \s ->
|
||||
notFollowedBy (fst <$> m s) >> return ((),s)
|
||||
failure = lift . failure
|
||||
withRecovery r (L.StateT m) = L.StateT $ \s ->
|
||||
withRecovery (\e -> L.runStateT (r e) s) (m s)
|
||||
eof = lift eof
|
||||
token f e = lift $ token f e
|
||||
tokens f e ts = lift $ tokens f e ts
|
||||
@ -845,13 +904,15 @@ instance (MonadPlus m, MonadParsec s m t) =>
|
||||
|
||||
instance (MonadPlus m, 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
|
||||
lookAhead (S.StateT m) = S.StateT $ \s ->
|
||||
(,s) . fst <$> lookAhead (m s)
|
||||
notFollowedBy (S.StateT m) = S.StateT $ \s ->
|
||||
notFollowedBy (fst <$> m s) >> return ((),s)
|
||||
failure = lift . failure
|
||||
withRecovery r (S.StateT m) = S.StateT $ \s ->
|
||||
withRecovery (\e -> S.runStateT (r e) s) (m s)
|
||||
eof = lift eof
|
||||
token f e = lift $ token f e
|
||||
tokens f e ts = lift $ tokens f e ts
|
||||
@ -860,11 +921,13 @@ instance (MonadPlus m, MonadParsec s m t)
|
||||
|
||||
instance (MonadPlus m, 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
|
||||
lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m
|
||||
notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m
|
||||
failure = lift . failure
|
||||
withRecovery r (L.ReaderT m) = L.ReaderT $ \s ->
|
||||
withRecovery (\e -> L.runReaderT (r e) s) (m s)
|
||||
eof = lift eof
|
||||
token f e = lift $ token f e
|
||||
tokens f e ts = lift $ tokens f e ts
|
||||
@ -873,13 +936,15 @@ instance (MonadPlus m, MonadParsec s m t)
|
||||
|
||||
instance (MonadPlus m, 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
|
||||
lookAhead (L.WriterT m) = L.WriterT $
|
||||
(,mempty) . fst <$> lookAhead m
|
||||
notFollowedBy (L.WriterT m) = L.WriterT $
|
||||
(,mempty) <$> notFollowedBy (fst <$> m)
|
||||
failure = lift . failure
|
||||
withRecovery r (L.WriterT m) = L.WriterT $
|
||||
withRecovery (L.runWriterT . r) m
|
||||
eof = lift eof
|
||||
token f e = lift $ token f e
|
||||
tokens f e ts = lift $ tokens f e ts
|
||||
@ -888,13 +953,15 @@ instance (MonadPlus m, Monoid w, MonadParsec s m t)
|
||||
|
||||
instance (MonadPlus m, 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
|
||||
lookAhead (S.WriterT m) = S.WriterT $
|
||||
(,mempty) . fst <$> lookAhead m
|
||||
notFollowedBy (S.WriterT m) = S.WriterT $
|
||||
(,mempty) <$> notFollowedBy (fst <$> m)
|
||||
failure = lift . failure
|
||||
withRecovery r (S.WriterT m) = S.WriterT $
|
||||
withRecovery (S.runWriterT . r) m
|
||||
eof = lift eof
|
||||
token f e = lift $ token f e
|
||||
tokens f e ts = lift $ tokens f e ts
|
||||
@ -903,11 +970,13 @@ instance (MonadPlus m, Monoid w, MonadParsec s m t)
|
||||
|
||||
instance (Monad m, 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
|
||||
lookAhead (IdentityT m) = IdentityT $ lookAhead m
|
||||
notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m
|
||||
failure = lift . failure
|
||||
withRecovery r (IdentityT m) = IdentityT $
|
||||
withRecovery (runIdentityT . r) m
|
||||
eof = lift eof
|
||||
token f e = lift $ token f e
|
||||
tokens f e ts = lift $ tokens f e ts
|
||||
|
||||
@ -144,10 +144,12 @@ test-suite tests
|
||||
, Prim
|
||||
, Util
|
||||
build-depends: base >= 4.6 && < 5
|
||||
, HUnit >= 1.2 && < 1.4
|
||||
, QuickCheck >= 2.4 && < 3
|
||||
, megaparsec >= 4.3
|
||||
, mtl == 2.*
|
||||
, test-framework >= 0.6 && < 1
|
||||
, test-framework-hunit >= 0.3 && < 0.4
|
||||
, test-framework-quickcheck2 >= 0.3 && < 0.4
|
||||
, transformers >= 0.4 && < 0.6
|
||||
default-extensions: CPP
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
|
||||
module Bugs.Bug9 (main) where
|
||||
|
||||
import Control.Applicative (empty)
|
||||
@ -41,7 +40,7 @@ integer :: Parser Integer
|
||||
integer = lexeme L.integer
|
||||
|
||||
operator :: String -> Parser String
|
||||
operator = try . L.symbol sc
|
||||
operator = L.symbol sc
|
||||
|
||||
parseTopLevel :: Parser Expr
|
||||
parseTopLevel = parseExpr <* eof
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
resolver: lts-4.0
|
||||
resolver: nightly-2016-02-08
|
||||
packages:
|
||||
- '.'
|
||||
|
||||
@ -131,8 +131,7 @@ prop_eol s = checkParser eol r s
|
||||
| "\r\n" `isPrefixOf` s = posErr 2 s [uneCh (s !! 2), exEof]
|
||||
| otherwise = posErr 0 s [ uneStr (take 2 s)
|
||||
, uneCh '\r'
|
||||
, exSpec "crlf newline"
|
||||
, exSpec "newline" ]
|
||||
, exSpec "end of line" ]
|
||||
|
||||
prop_tab :: String -> Property
|
||||
prop_tab = checkChar tab (== '\t') (Just "tab")
|
||||
|
||||
205
tests/Prim.hs
205
tests/Prim.hs
@ -34,7 +34,7 @@ import Control.Applicative
|
||||
import Data.Char (isLetter, toUpper)
|
||||
import Data.Foldable (asum)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (maybeToList, fromMaybe)
|
||||
import Data.Maybe (maybeToList)
|
||||
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Except
|
||||
@ -47,10 +47,13 @@ import qualified Control.Monad.Writer.Lazy as L
|
||||
import qualified Control.Monad.Writer.Strict as S
|
||||
|
||||
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 Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Combinator
|
||||
import Text.Megaparsec.Error
|
||||
import Text.Megaparsec.Pos
|
||||
import Text.Megaparsec.Prim
|
||||
@ -96,9 +99,26 @@ tests = testGroup "Primitive parser combinators"
|
||||
, testProperty "combinator lookAhead" prop_lookAhead_0
|
||||
, testProperty "combinator lookAhead hints" prop_lookAhead_1
|
||||
, testProperty "combinator lookAhead messages" prop_lookAhead_2
|
||||
, testCase "combinator lookAhead cerr" case_lookAhead_3
|
||||
, testProperty "combinator notFollowedBy" prop_notFollowedBy_0
|
||||
, testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1
|
||||
, testProperty "combinator notFollowedBy eof" prop_notFollowedBy_2
|
||||
, testCase "combinator notFollowedBy cerr" case_notFollowedBy_3a
|
||||
, testCase "combinator notFollowedBy cerr" case_notFollowedBy_3b
|
||||
, testCase "combinator notFollowedBy eerr" case_notFollowedBy_4a
|
||||
, testCase "combinator notFollowedBy eerr" case_notFollowedBy_4b
|
||||
, testProperty "combinator withRecovery" prop_withRecovery_0
|
||||
, testCase "combinator withRecovery eok" case_withRecovery_1
|
||||
, testCase "combinator withRecovery meerr-rcerr" case_withRecovery_2
|
||||
, testCase "combinator withRecovery meerr-reok" case_withRecovery_3a
|
||||
, testCase "combinator withRecovery meerr-reok" case_withRecovery_3b
|
||||
, testCase "combinator withRecovery mcerr-rcok" case_withRecovery_4a
|
||||
, testCase "combinator withRecovery mcerr-rcok" case_withRecovery_4b
|
||||
, testCase "combinator withRecovery mcerr-rcerr" case_withRecovery_5
|
||||
, testCase "combinator withRecovery mcerr-reok" case_withRecovery_6a
|
||||
, testCase "combinator withRecovery mcerr-reok" case_withRecovery_6b
|
||||
, testCase "combinator withRecovery mcerr-reerr" case_withRecovery_7
|
||||
, testCase "combinator eof return value" case_eof
|
||||
, testProperty "combinator token" prop_token
|
||||
, testProperty "combinator tokens" prop_tokens
|
||||
, testProperty "parser state position" prop_state_pos
|
||||
@ -152,7 +172,7 @@ prop_alternative_1 s0 s1
|
||||
| s0 `isPrefixOf` s1 =
|
||||
checkParser p (posErr s0l s1 [uneCh (s1 !! s0l), exEof]) s1
|
||||
| otherwise = checkParser p (Right s0) s0 .&&. checkParser p (Right s1) s1
|
||||
where p = try (string s0) <|> string s1
|
||||
where p = string s0 <|> string s1
|
||||
s0l = length s0
|
||||
|
||||
prop_alternative_2 :: Char -> Char -> Char -> Bool -> Property
|
||||
@ -166,8 +186,8 @@ prop_alternative_2 a b c l = checkParser p r s
|
||||
|
||||
prop_alternative_3 :: Property
|
||||
prop_alternative_3 = checkParser p r s
|
||||
where p = asum [empty, try (string ">>>"), empty, return "foo"] <?> "bar"
|
||||
p' = bsum [empty, try (string ">>>"), empty, return "foo"] <?> "bar"
|
||||
where p = asum [empty, string ">>>", empty, return "foo"] <?> "bar"
|
||||
p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"
|
||||
bsum = foldl (<|>) empty
|
||||
r = simpleParse p' s
|
||||
s = ">>"
|
||||
@ -203,7 +223,7 @@ prop_alternative_6 a b c = checkParser p r s
|
||||
r | c = posErr ab s $ [uneCh 'c', exEof] ++
|
||||
[exCh 'a' | not a && not b] ++ [exCh 'b' | not b]
|
||||
| otherwise = Right s
|
||||
s = abcRow' a b c
|
||||
s = abcRow a b c
|
||||
ab = fromEnum a + fromEnum b
|
||||
|
||||
-- Monad instance
|
||||
@ -333,24 +353,23 @@ prop_hidden_0 a' b' c' = checkParser p r s
|
||||
| otherwise = Right s
|
||||
s = abcRow a b c
|
||||
|
||||
prop_hidden_1 :: String -> NonEmptyList Char -> String -> Property
|
||||
prop_hidden_1 a c' s = checkParser p r s
|
||||
prop_hidden_1 :: NonEmptyList Char -> String -> Property
|
||||
prop_hidden_1 c' s = checkParser p r s
|
||||
where c = getNonEmpty c'
|
||||
p = fromMaybe a <$> optional (hidden $ string c)
|
||||
r | null s = Right a
|
||||
| c == s = Right s
|
||||
| head c /= head s = posErr 0 s [uneCh (head s), exEof]
|
||||
| otherwise = simpleParse (string c) s
|
||||
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]
|
||||
|
||||
prop_try :: String -> String -> String -> Property
|
||||
prop_try pre s1' s2' = checkParser p r s
|
||||
where s1 = pre ++ s1'
|
||||
s2 = pre ++ s2'
|
||||
p = try (string s1) <|> string s2
|
||||
r | s == s1 || s == s2 = Right s
|
||||
| otherwise = posErr 0 s $ (if null s then uneEof else uneStr pre)
|
||||
: [uneStr pre, exStr s1, exStr s2]
|
||||
s = pre
|
||||
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
|
||||
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
|
||||
@ -364,7 +383,7 @@ prop_lookAhead_0 a b c = checkParser p r s
|
||||
| h == 'b' = posErr 0 s [uneCh 'b', exCh 'a']
|
||||
| h == 'c' = posErr 0 s [uneCh 'c', exSpec "label"]
|
||||
| otherwise = posErr 1 s [uneCh (s !! 1), exEof]
|
||||
s = abcRow' a b c
|
||||
s = abcRow a b c
|
||||
|
||||
prop_lookAhead_1 :: String -> Property
|
||||
prop_lookAhead_1 s = checkParser p r s
|
||||
@ -380,7 +399,13 @@ prop_lookAhead_2 a b c = checkParser p r s
|
||||
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
|
||||
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
|
||||
emsg = "ops!"
|
||||
s = "abc"
|
||||
|
||||
prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int
|
||||
-> NonNegative Int -> Property
|
||||
@ -411,8 +436,101 @@ prop_notFollowedBy_2 a' b' c' = checkParser p r s
|
||||
| otherwise = posErr a s [uneEof, exCh 'a']
|
||||
s = abcRow a b c
|
||||
|
||||
-- We omit tests for 'eof' here because it's used virtually everywhere, it's
|
||||
-- already thoroughly tested.
|
||||
case_notFollowedBy_3a :: Assertion
|
||||
case_notFollowedBy_3a = parse p "" "ab" @?= Right ()
|
||||
where p = notFollowedBy (char 'a' *> char 'c')
|
||||
|
||||
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'
|
||||
s = "ab"
|
||||
|
||||
case_notFollowedBy_4a :: Assertion
|
||||
case_notFollowedBy_4a = parse p "" "ab" @?= Right ()
|
||||
where p = notFollowedBy (fail "ops!")
|
||||
|
||||
case_notFollowedBy_4b :: Assertion
|
||||
case_notFollowedBy_4b = parse p "" s @?= posErr 0 s [uneCh 'a', exCh 'c']
|
||||
where p = notFollowedBy (fail "ops!") <* char '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
|
||||
|
||||
case_withRecovery_1 :: Assertion
|
||||
case_withRecovery_1 = parse p "" "abc" @?= Right "foo"
|
||||
where p = withRecovery (const $ return "bar") (return "foo")
|
||||
|
||||
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")
|
||||
s = "abc"
|
||||
|
||||
case_withRecovery_3a :: Assertion
|
||||
case_withRecovery_3a = parse p "" "abc" @?= Right "abd"
|
||||
where p = withRecovery (const $ return "abd") (string "cba")
|
||||
|
||||
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']
|
||||
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_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"
|
||||
s = "abc"
|
||||
|
||||
case_withRecovery_5 :: Assertion
|
||||
case_withRecovery_5 = parse p "" s @?= posErr 1 s [msg emsg]
|
||||
where p :: Parser String
|
||||
p = withRecovery (\_ -> char 'b' *> fail emsg) (char 'a' *> fail 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_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']
|
||||
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')
|
||||
s = "abc"
|
||||
|
||||
case_eof :: Assertion
|
||||
case_eof = parse eof "" "" @?= Right ()
|
||||
|
||||
prop_token :: String -> Property
|
||||
prop_token s = checkParser p r s
|
||||
@ -523,15 +641,13 @@ stateFromInput s = State s (initialPos "") defaultTabWidth
|
||||
|
||||
-- IdentityT instance of MonadParsec
|
||||
|
||||
prop_IdentityT_try :: String -> String -> String -> Property
|
||||
prop_IdentityT_try pre s1' s2' = checkParser (runIdentityT p) r s
|
||||
where s1 = pre ++ s1'
|
||||
s2 = pre ++ s2'
|
||||
p = try (string s1) <|> string s2
|
||||
r | s == s1 || s == s2 = Right s
|
||||
| otherwise = posErr 0 s $ (if null s then uneEof else uneStr pre)
|
||||
: [uneStr pre, exStr s1, exStr s2]
|
||||
s = pre
|
||||
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
|
||||
@ -544,17 +660,16 @@ prop_IdentityT_notFollowedBy a' b' c' = checkParser (runIdentityT p) r s
|
||||
|
||||
-- ReaderT instance of MonadParsec
|
||||
|
||||
prop_ReaderT_try :: String -> String -> String -> Property
|
||||
prop_ReaderT_try pre s1' s2' = checkParser (runReaderT p (s1', s2')) r s
|
||||
where s1 = pre ++ s1'
|
||||
s2 = pre ++ s2'
|
||||
getS1 = asks ((pre ++) . fst)
|
||||
getS2 = asks ((pre ++) . snd)
|
||||
p = try (string =<< getS1) <|> (string =<< getS2)
|
||||
r | s == s1 || s == s2 = Right s
|
||||
| otherwise = posErr 0 s $ (if null s then uneEof else uneStr pre)
|
||||
: [uneStr pre, exStr s1, exStr s2]
|
||||
s = pre
|
||||
prop_ReaderT_try :: Char -> Char -> Char -> Property
|
||||
prop_ReaderT_try pre ch1 ch2 = checkParser (runReaderT p (s1, s2)) r s
|
||||
where s1 = pre : [ch1]
|
||||
s2 = pre : [ch2]
|
||||
getS1 = asks fst
|
||||
getS2 = asks snd
|
||||
p = try (g =<< getS1) <|> (g =<< getS2)
|
||||
g = sequence . fmap char
|
||||
r = posErr 1 s [uneEof, exCh ch1, exCh ch2]
|
||||
s = [pre]
|
||||
|
||||
prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int
|
||||
-> NonNegative Int -> Property
|
||||
|
||||
@ -34,7 +34,6 @@ module Util
|
||||
, (/=\)
|
||||
, (!=!)
|
||||
, abcRow
|
||||
, abcRow'
|
||||
, posErr
|
||||
, uneCh
|
||||
, uneStr
|
||||
@ -132,15 +131,9 @@ n !=! m = simpleParse n "" === simpleParse m ""
|
||||
-- @a@ times, character “b” repeated @b@ times, and finally character “c”
|
||||
-- repeated @c@ times.
|
||||
|
||||
abcRow :: Int -> Int -> Int -> String
|
||||
abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c'
|
||||
|
||||
-- | @abcRow' a b c@ generates string that includes character “a” if @a@ is
|
||||
-- 'True', then optionally character “b” if @b@ is 'True', then character
|
||||
-- “c” if @c@ is 'True'.
|
||||
|
||||
abcRow' :: Bool -> Bool -> Bool -> String
|
||||
abcRow' a b c = abcRow (fromEnum a) (fromEnum b) (fromEnum c)
|
||||
abcRow :: Enum a => a -> a -> a -> String
|
||||
abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c'
|
||||
where f x = replicate (fromEnum x)
|
||||
|
||||
-- | @posErr pos s ms@ is an easy way to model result of parser that
|
||||
-- fails. @pos@ is how many tokens (characters) has been consumed before
|
||||
|
||||
Loading…
Reference in New Issue
Block a user