megaparsec-5.2.0: tests/Text/Megaparsec/PrimSpec.hs
--
-- Tests for Megaparsec's primitive parser combinators.
--
-- Copyright © 2015–2017 Megaparsec contributors
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-}
module Text.Megaparsec.PrimSpec (spec) where
import Control.Applicative
import Control.Monad.Cont
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Char (toUpper, chr)
import Data.Foldable (asum, concat)
import Data.List (isPrefixOf, foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Data.Monoid
import Data.Proxy
import Data.Word (Word8)
import Prelude hiding (span, concat)
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.Hspec.Megaparsec.AdHoc
import Test.QuickCheck hiding (label)
import Text.Megaparsec.Char
import Text.Megaparsec.Combinator
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
import Text.Megaparsec.Prim
import Text.Megaparsec.String
import qualified Control.Monad.RWS.Lazy as L
import qualified Control.Monad.RWS.Strict as S
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 qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as E
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
#if !MIN_VERSION_QuickCheck(2,8,2)
instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where
arbitrary = E.fromList <$> arbitrary
shrink = fmap E.fromList . shrink . E.toList
#endif
spec :: Spec
spec = do
describe "non-String instances of Stream" $ do
context "lazy ByteString" $ do
it "unconses correctly" $
property $ \ch' n -> do
let p = many (char ch) :: Parsec Dec BL.ByteString String
s = replicate (getNonNegative n) ch
ch = byteToChar ch'
parse p "" (BL.pack s) `shouldParse` s
it "updates position like with String" $
property $ \w pos ch ->
updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe`
updatePos (Proxy :: Proxy String) w pos ch
context "strict ByteString" $ do
it "unconses correctly" $
property $ \ch' n -> do
let p = many (char ch) :: Parsec Dec B.ByteString String
s = replicate (getNonNegative n) ch
ch = byteToChar ch'
parse p "" (B.pack s) `shouldParse` s
it "updates position like with String" $
property $ \w pos ch ->
updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe`
updatePos (Proxy :: Proxy String) w pos ch
context "lazy Text" $ do
it "unconses correctly" $
property $ \ch n -> do
let p = many (char ch) :: Parsec Dec TL.Text String
s = replicate (getNonNegative n) ch
parse p "" (TL.pack s) `shouldParse` s
it "updates position like with String" $
property $ \w pos ch ->
updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe`
updatePos (Proxy :: Proxy String) w pos ch
context "strict Text" $ do
it "unconses correctly" $
property $ \ch n -> do
let p = many (char ch) :: Parsec Dec T.Text String
s = replicate (getNonNegative n) ch
parse p "" (T.pack s) `shouldParse` s
it "updates position like with String" $
property $ \w pos ch ->
updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe`
updatePos (Proxy :: Proxy String) w pos ch
describe "position in custom stream" $ do
describe "eof" $
it "updates position in stream correctly" $
property $ \st -> (not . null . stateInput) st ==> do
let p = eof :: CustomParser ()
h = head (stateInput st)
apos = let (_:|z) = statePos st in spanStart h :| z
runParser' p st `shouldBe`
( st { statePos = apos }
, Left (err apos $ utok h <> eeof) )
describe "token" $ do
context "when input stream is empty" $
it "signals correct parse error" $
property $ \st'@State {..} span -> do
let p = pSpan span
st = (st' :: State [Span]) { stateInput = [] }
runParser' p st `shouldBe`
( st
, Left (err statePos $ ueof <> etok span) )
context "when head of stream matches" $
it "updates parser state correctly" $
property $ \st'@State {..} span -> do
let p = pSpan span
st = st' { stateInput = span : stateInput }
npos = spanEnd span :| NE.tail statePos
runParser' p st `shouldBe`
( st { statePos = npos
, stateTokensProcessed = stateTokensProcessed + 1
, stateInput = stateInput }
, Right span )
context "when head of stream does not match" $ do
let checkIt s span =
let ms = listToMaybe s
in isJust ms && (spanBody <$> ms) /= Just (spanBody span)
it "signals correct parse error" $
property $ \st@State {..} span -> checkIt stateInput span ==> do
let p = pSpan span
h = head stateInput
apos = spanStart h :| NE.tail statePos
runParser' p st `shouldBe`
( st { statePos = apos }
, Left (err apos $ utok h <> etok span))
describe "tokens" $
it "updates position is stream correctly" $
property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do
let p = tokens compareTokens ts :: CustomParser [Span]
compareTokens x y = spanBody x == spanBody y
updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth
il = length . takeWhile id $ zipWith compareTokens stateInput ts
tl = length ts
consumed = take il stateInput
(apos, npos) =
let (pos:|z) = statePos
in ( spanStart (head stateInput) :| z
, foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z )
if | null ts -> runParser' p st `shouldBe` (st, Right [])
| null stateInput -> runParser' p st `shouldBe`
( st
, Left (err statePos $ ueof <> etoks ts) )
| il == tl -> runParser' p st `shouldBe`
( st { statePos = npos
, stateTokensProcessed = stateTokensProcessed + fromIntegral tl
, stateInput = drop (length ts) stateInput }
, Right consumed )
| otherwise -> runParser' p st `shouldBe`
( st { statePos = apos }
, Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) )
describe "ParsecT Functor instance" $ do
it "obeys identity law" $
property $ \n ->
prs (fmap id (pure (n :: Int))) "" ===
prs (id (pure n)) ""
it "obeys composition law" $
property $ \n m t ->
let f = (+ m)
g = (* t)
in prs (fmap (f . g) (pure (n :: Int))) "" ===
prs ((fmap f . fmap g) (pure n)) ""
describe "ParsecT Applicative instance" $ do
it "obeys identity law" $
property $ \n ->
prs (pure id <*> pure (n :: Int)) "" ===
prs (pure n) ""
it "obeys composition law" $
property $ \n m t ->
let u = pure (+ m)
v = pure (* t)
w = pure (n :: Int)
in prs (pure (.) <*> u <*> v <*> w) "" ===
prs (u <*> (v <*> w)) ""
it "obeys homomorphism law" $
property $ \x m ->
let f = (+ m)
in prs (pure f <*> pure (x :: Int)) "" ===
prs (pure (f x)) ""
it "obeys interchange law" $
property $ \n y ->
let u = pure (+ n)
in prs (u <*> pure (y :: Int)) "" ===
prs (pure ($ y) <*> u) ""
describe "(<*>)" $
context "when first parser succeeds without consuming" $
context "when second parser fails consuming input" $
it "fails consuming input" $ do
let p = m <*> n
m = return (\x -> 'a' : x)
n = string "bc" <* empty
s = "bc"
prs p s `shouldFailWith` err (posN (4 :: Int) s) mempty
prs' p s `failsLeaving` ""
describe "(*>)" $
it "works correctly" $
property $ \n m ->
let u = pure (+ (m :: Int))
v = pure (n :: Int)
in prs (u *> v) "" ===
prs (pure (const id) <*> u <*> v) ""
describe "(<*)" $
it "works correctly" $
property $ \n m ->
let u = pure (m :: Int)
v = pure (+ (n :: Int))
in prs (u <* v) "" === prs (pure const <*> u <*> v) ""
describe "ParsecT Alternative instance" $ do
describe "empty" $
it "always fails" $
property $ \n ->
prs (empty <|> pure n) "" `shouldParse` (n :: Integer)
describe "(<|>)" $ do
context "with two strings" $ do
context "stream begins with the first string" $
it "parses the string" $
property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do
let s' = s0 ++ s
p = string s0 <|> string s1
prs p s' `shouldParse` s0
prs' p s' `succeedsLeaving` s
context "stream begins with the second string" $
it "parses the string" $
property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do
let s' = s1 ++ s
p = string s0 <|> string s1
prs p s' `shouldParse` s1
prs' p s' `succeedsLeaving` s
context "when stream does not begin with either string" $
it "signals correct error message" $
property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do
let p = string s0 <|> string s1
z0' = toFirstMismatch (==) s0 s
z1' = toFirstMismatch (==) s1 s
prs p s `shouldFailWith` err posI
(etoks s0 <>
etoks s1 <>
(if null s then ueof else mempty) <>
(if null z0' then mempty else utoks z0') <>
(if null z1' then mempty else utoks z1'))
context "with two complex parsers" $ do
context "when stream begins with matching character" $
it "parses it" $
property $ \a b -> a /= b ==> do
let p = char a <|> (char b *> char a)
s = [a]
prs p s `shouldParse` a
prs' p s `succeedsLeaving` ""
context "when stream begins with only one matching character" $
it "signals correct parse error" $
property $ \a b c -> a /= b && a /= c ==> do
let p = char a <|> (char b *> char a)
s = [b,c]
prs p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a)
prs' p s `failsLeaving` [c]
context "when stream begins with not matching character" $
it "signals correct parse error" $
property $ \a b c -> a /= b && a /= c && b /= c ==> do
let p = char a <|> (char b *> char a)
s = [c,b]
prs p s `shouldFailWith` err posI (utok c <> etok a <> etok b)
prs' p s `failsLeaving` s
context "when stream is emtpy" $
it "signals correct parse error" $
property $ \a b -> do
let p = char a <|> (char b *> char a)
prs p "" `shouldFailWith` err posI (ueof <> etok a <> etok b)
it "associativity of fold over alternatives should not matter" $ do
let p = asum [empty, string ">>>", empty, return "foo"] <?> "bar"
p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"
bsum = foldl (<|>) empty
s = ">>"
prs p s `shouldBe` prs p' s
describe "many" $ do
context "when stream begins with things argument of many parses" $
it "they are parsed" $
property $ \a' b' c' -> do
let [a,b,c] = getNonNegative <$> [a',b',c']
p = many (char 'a')
s = abcRow a b c
prs p s `shouldParse` replicate a 'a'
prs' p s `succeedsLeaving` drop a s
context "when stream does not begin with thing argument of many parses" $
it "does nothing" $
property $ \a' b' c' -> do
let [a,b,c] = getNonNegative <$> [a',b',c']
p = many (char 'd')
s = abcRow a b c
prs p s `shouldParse` ""
prs' p s `succeedsLeaving` s
context "when stream is empty" $
it "succeeds parsing nothing" $ do
let p = many (char 'a')
prs p "" `shouldParse` ""
context "when there are two many combinators in a row that parse nothing" $
it "accumulated hints are reflected in parse error" $ do
let p = many (char 'a') *> many (char 'b') *> eof
prs p "c" `shouldFailWith` err posI
(utok 'c' <> etok 'a' <> etok 'b' <> eeof)
context "when the argument parser succeeds without consuming" $
it "is run nevertheless" $
property $ \n' -> do
let n = getSmall (getNonNegative n') :: Integer
p = void . many $ do
x <- S.get
if x < n then S.modify (+ 1) else empty
v :: S.State Integer (Either (ParseError Char Dec) ())
v = runParserT p "" ""
S.execState v 0 `shouldBe` n
describe "some" $ do
context "when stream begins with things argument of some parses" $
it "they are parsed" $
property $ \a' b' c' -> do
let a = getPositive a'
[b,c] = getNonNegative <$> [b',c']
p = some (char 'a')
s = abcRow a b c
prs p s `shouldParse` replicate a 'a'
prs' p s `succeedsLeaving` drop a s
context "when stream does not begin with thing argument of some parses" $
it "signals correct parse error" $
property $ \a' b' c' -> do
let [a,b,c] = getNonNegative <$> [a',b',c']
p = some (char 'd')
s = abcRow a b c ++ "g"
prs p s `shouldFailWith` err posI (utok (head s) <> etok 'd')
prs' p s `failsLeaving` s
context "when stream is empty" $
it "signals correct parse error" $
property $ \ch -> do
let p = some (char ch)
prs p "" `shouldFailWith` err posI (ueof <> etok ch)
context "optional" $ do
context "when stream begins with that optional thing" $
it "parses it" $
property $ \a b -> do
let p = optional (char a) <* char b
s = [a,b]
prs p s `shouldParse` Just a
prs' p s `succeedsLeaving` ""
context "when stream does not begin with that optional thing" $
it "succeeds parsing nothing" $
property $ \a b -> a /= b ==> do
let p = optional (char a) <* char b
s = [b]
prs p s `shouldParse` Nothing
prs' p s `succeedsLeaving` ""
context "when stream is empty" $
it "succeeds parsing nothing" $
property $ \a -> do
let p = optional (char a)
prs p "" `shouldParse` Nothing
describe "ParsecT Monad instance" $ do
it "satisfies left identity law" $
property $ \a k' -> do
let k = return . (+ k')
p = return (a :: Int) >>= k
prs p "" `shouldBe` prs (k a) ""
it "satisfies right identity law" $
property $ \a -> do
let m = return (a :: Int)
p = m >>= return
prs p "" `shouldBe` prs m ""
it "satisfies associativity law" $
property $ \m' k' h' -> do
let m = return (m' :: Int)
k = return . (+ k')
h = return . (* h')
p = m >>= (\x -> k x >>= h)
p' = (m >>= k) >>= h
prs p "" `shouldBe` prs p' ""
it "fails signals correct parse error" $
property $ \msg -> do
let p = fail msg :: Parsec Dec String ()
prs p "" `shouldFailWith` err posI (cstm (DecFail msg))
it "pure is the same as return" $
property $ \n ->
prs (pure (n :: Int)) "" `shouldBe` prs (return n) ""
it "(<*>) is the same as ap" $
property $ \m' k' -> do
let m = return (m' :: Int)
k = return (+ k')
prs (k <*> m) "" `shouldBe` prs (k `ap` m) ""
describe "ParsecT MonadFail instance" $
describe "fail" $
it "signals correct parse error" $
property $ \s msg -> do
let p = void (fail msg)
prs p s `shouldFailWith` err posI (cstm $ DecFail msg)
prs' p s `failsLeaving` s
describe "ParsecT MonadIO instance" $
it "liftIO works" $
property $ \n -> do
let p = liftIO (return n) :: ParsecT Dec String IO Integer
runParserT p "" "" `shouldReturn` Right n
describe "ParsecT MonadReader instance" $ do
describe "ask" $
it "returns correct value of context" $
property $ \n -> do
let p = ask :: ParsecT Dec String (Reader Integer) Integer
runReader (runParserT p "" "") n `shouldBe` Right n
describe "local" $
it "modifies reader context correctly" $
property $ \n k -> do
let p = local (+ k) ask :: ParsecT Dec String (Reader Integer) Integer
runReader (runParserT p "" "") n `shouldBe` Right (n + k)
describe "ParsecT MonadState instance" $ do
describe "get" $
it "returns correct state value" $
property $ \n -> do
let p = L.get :: ParsecT Dec String (L.State Integer) Integer
L.evalState (runParserT p "" "") n `shouldBe` Right n
describe "put" $
it "replaces state value" $
property $ \a b -> do
let p = L.put b :: ParsecT Dec String (L.State Integer) ()
L.execState (runParserT p "" "") a `shouldBe` b
describe "ParsecT MonadCont instance" $
describe "callCC" $
it "works properly" $
property $ \a b -> do
let p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer
p = callCC $ \e -> when (a > b) (e a) >> return b
runCont (runParserT p "" "") id `shouldBe` Right (max a b)
describe "ParsecT MonadError instance" $ do
describe "throwError" $
it "throws the error" $
property $ \a b -> do
let p :: ParsecT Dec String (Except Integer) Integer
p = throwError a >> return b
runExcept (runParserT p "" "") `shouldBe` Left a
describe "catchError" $
it "catches the error" $
property $ \a b -> do
let p :: ParsecT Dec String (Except Integer) Integer
p = (throwError a >> return b) `catchError` handler
handler e = return (e + b)
runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b)
describe "primitive combinators" $ do
describe "unexpected" $
it "signals correct parse error" $
property $ \item -> do
let p :: MonadParsec Dec String m => m ()
p = void (unexpected item)
grs p "" (`shouldFailWith` ParseError
{ errorPos = posI
, errorUnexpected = E.singleton item
, errorExpected = E.empty
, errorCustom = E.empty })
describe "failure" $
it "signals correct parse error" $
property $ \us ps xs -> do
let p :: MonadParsec Dec String m => m ()
p = void (failure us ps xs)
grs p "" (`shouldFailWith` ParseError
{ errorPos = posI
, errorUnexpected = us
, errorExpected = ps
, errorCustom = xs })
describe "label" $ do
context "when inner parser succeeds consuming input" $ do
context "inner parser does not produce any hints" $
it "collection of hints remains empty" $
property $ \lbl a -> not (null lbl) ==> do
let p :: MonadParsec Dec String m => m Char
p = label lbl (char a) <* empty
s = [a]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)
grs' p s (`failsLeaving` "")
context "inner parser produces hints" $
it "replaces the last hint with “rest of <label>”" $
property $ \lbl a -> not (null lbl) ==> do
let p :: MonadParsec Dec String m => m String
p = label lbl (many (char a)) <* empty
s = [a]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (elabel $ "rest of " ++ lbl))
grs' p s (`failsLeaving` "")
context "when inner parser consumes and fails" $
it "reports parse error without modification" $
property $ \lbl a b c -> not (null lbl) && b /= c ==> do
let p :: MonadParsec Dec String m => m Char
p = label lbl (char a *> char b)
s = [a,c]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))
grs' p s (`failsLeaving` [c])
context "when inner parser succeeds without consuming" $ do
context "inner parser does not produce any hints" $
it "collection of hints remains empty" $
property $ \lbl a -> not (null lbl) ==> do
let p :: MonadParsec Dec String m => m Char
p = label lbl (return a) <* empty
grs p "" (`shouldFailWith` err posI mempty)
context "inner parser produces hints" $
it "replaces the last hint with given label" $
property $ \lbl a -> not (null lbl) ==> do
let p :: MonadParsec Dec String m => m String
p = label lbl (many (char a)) <* empty
grs p "" (`shouldFailWith` err posI (elabel lbl))
context "when inner parser fails without consuming" $
it "is mentioned in parse error via its label" $
property $ \lbl -> not (null lbl) ==> do
let p :: MonadParsec Dec String m => m ()
p = label lbl empty
grs p "" (`shouldFailWith` err posI (elabel lbl))
describe "hidden" $ do
context "when inner parser succeeds consuming input" $ do
context "inner parser does not produce any hints" $
it "collection of hints remains empty" $
property $ \a -> do
let p :: MonadParsec Dec String m => m Char
p = hidden (char a) <* empty
s = [a]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)
grs' p s (`failsLeaving` "")
context "inner parser produces hints" $
it "hides the parser in the error message" $
property $ \a -> do
let p :: MonadParsec Dec String m => m String
p = hidden (many (char a)) <* empty
s = [a]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)
grs' p s (`failsLeaving` "")
context "when inner parser consumes and fails" $
it "reports parse error without modification" $
property $ \a b c -> b /= c ==> do
let p :: MonadParsec Dec String m => m Char
p = hidden (char a *> char b)
s = [a,c]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))
grs' p s (`failsLeaving` [c])
context "when inner parser succeeds without consuming" $ do
context "inner parser does not produce any hints" $
it "collection of hints remains empty" $
property $ \a -> do
let p :: MonadParsec Dec String m => m Char
p = hidden (return a) <* empty
grs p "" (`shouldFailWith` err posI mempty)
context "inner parser produces hints" $
it "hides the parser in the error message" $
property $ \a -> do
let p :: MonadParsec Dec String m => m String
p = hidden (many (char a)) <* empty
grs p "" (`shouldFailWith` err posI mempty)
context "when inner parser fails without consuming" $
it "hides the parser in the error message" $ do
let p :: MonadParsec Dec String m => m ()
p = hidden empty
grs p "" (`shouldFailWith` err posI mempty)
describe "try" $ do
context "when inner parser succeeds consuming" $
it "try has no effect" $
property $ \a -> do
let p :: MonadParsec Dec String m => m Char
p = try (char a)
s = [a]
grs p s (`shouldParse` a)
grs' p s (`succeedsLeaving` "")
context "when inner parser fails consuming" $
it "backtracks, it appears as if the parser has not consumed anything" $
property $ \a b c -> b /= c ==> do
let p :: MonadParsec Dec String m => m Char
p = try (char a *> char b)
s = [a,c]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))
grs' p s (`failsLeaving` s)
context "when inner parser succeeds without consuming" $
it "try has no effect" $
property $ \a -> do
let p :: MonadParsec Dec String m => m Char
p = try (return a)
grs p "" (`shouldParse` a)
context "when inner parser fails without consuming" $
it "try backtracks parser state anyway" $
property $ \w -> do
let p :: MonadParsec Dec String m => m Char
p = try (setTabWidth w *> empty)
grs p "" (`shouldFailWith` err posI mempty)
grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
describe "lookAhead" $ do
context "when inner parser succeeds consuming" $ do
it "result is returned but parser state is not changed" $
property $ \a w -> do
let p :: MonadParsec Dec String m => m Pos
p = lookAhead (setTabWidth w *> char a) *> getTabWidth
s = [a]
grs p s (`shouldParse` defaultTabWidth)
grs' p s (`succeedsLeaving` s)
it "hints are not preserved" $
property $ \a -> do
let p :: MonadParsec Dec String m => m String
p = lookAhead (many (char a)) <* empty
s = [a]
grs p s (`shouldFailWith` err posI mempty)
grs' p s (`failsLeaving` s)
context "when inner parser fails consuming" $
it "error message is reported as usual" $
property $ \a b c -> b /= c ==> do
let p :: MonadParsec Dec String m => m Char
p = lookAhead (char a *> char b)
s = [a,c]
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))
grs' p s (`failsLeaving` [c])
context "when inner parser succeeds without consuming" $ do
it "result is returned but parser state in not changed" $
property $ \a w -> do
let p :: MonadParsec Dec String m => m Pos
p = lookAhead (setTabWidth w *> char a) *> getTabWidth
s = [a]
grs p s (`shouldParse` defaultTabWidth)
grs' p s (`succeedsLeaving` s)
it "hints are not preserved" $
property $ \a b -> a /= b ==> do
let p :: MonadParsec Dec String m => m String
p = lookAhead (many (char a)) <* empty
s = [b]
grs p s (`shouldFailWith` err posI mempty)
grs' p s (`failsLeaving` s)
context "when inner parser fails without consuming" $
it "error message is reported as usual" $ do
let p :: MonadParsec Dec String m => m Char
p = lookAhead empty
grs p "" (`shouldFailWith` err posI mempty)
describe "notFollowedBy" $ do
context "when inner parser succeeds consuming" $
it "signals correct parse error" $
property $ \a w -> do
let p :: MonadParsec Dec String m => m ()
p = notFollowedBy (setTabWidth w <* char a)
s = [a]
grs p s (`shouldFailWith` err posI (utok a))
grs' p s (`failsLeaving` s)
grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
context "when inner parser fails consuming" $ do
it "succeeds without consuming" $
property $ \a b c w -> b /= c ==> do
let p :: MonadParsec Dec String m => m ()
p = notFollowedBy (setTabWidth w *> char a *> char b)
s = [a,c]
grs' p s (`succeedsLeaving` s)
grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
it "hints are not preserved" $
property $ \a b -> a /= b ==> do
let p :: MonadParsec Dec String m => m ()
p = notFollowedBy (char b *> many (char a) <* char a) <* empty
s = [b,b]
grs p s (`shouldFailWith` err posI mempty)
grs' p s (`failsLeaving` s)
context "when inner parser succeeds without consuming" $
it "signals correct parse error" $
property $ \a w -> do
let p :: MonadParsec Dec String m => m ()
p = notFollowedBy (setTabWidth w *> return a)
s = [a]
grs p s (`shouldFailWith` err posI (utok a))
grs' p s (`failsLeaving` s)
grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
context "when inner parser fails without consuming" $ do
it "succeeds without consuming" $
property $ \w -> do
let p :: MonadParsec Dec String m => m ()
p = notFollowedBy (setTabWidth w *> empty)
grs p "" (`shouldParse` ())
grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
it "hints are not preserved" $
property $ \a -> do
let p :: MonadParsec Dec String m => m ()
p = notFollowedBy (many (char a) <* char a) <* empty
s = ""
grs p s (`shouldFailWith` err posI mempty)
grs' p s (`failsLeaving` s)
describe "withRecovery" $ do
context "when inner parser succeeds consuming" $
it "the result is returned as usual" $
property $ \a as -> do
let p :: MonadParsec Dec String m => m (Maybe Char)
p = withRecovery (const $ return Nothing) (pure <$> char a)
s = a : as
grs p s (`shouldParse` Just a)
grs' p s (`succeedsLeaving` as)
context "when inner parser fails consuming" $ do
context "when recovering parser succeeds consuming input" $ do
it "its result is returned and position is advanced" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ string (c : as))
(Right <$> char a <* char b)
s = a : c : as
grs p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))
grs' p s (`succeedsLeaving` "")
it "hints are not preserved" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ string (c : as))
(Right <$> char a <* many (char b) <* char b) <* empty
s = a : c : as
grs p s (`shouldFailWith` err (posN (length s) s) mempty)
grs' p s (`failsLeaving` "")
context "when recovering parser fails consuming input" $
it "the original parse error (and state) is reported" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ char c <* empty)
(Right <$> char a <* char b)
s = a : c : as
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))
grs' p s (`failsLeaving` (c : as))
context "when recovering parser succeeds without consuming" $ do
it "its result is returned (and state)" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (return . Left) (Right <$> char a <* char b)
s = a : c : as
grs p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))
grs' p s (`succeedsLeaving` (c : as))
it "original hints are preserved" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (return . Left)
(Right <$> char a <* many (char b) <* char b) <* empty
s = a : c : as
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (etok b))
grs' p s (`failsLeaving` (c:as))
context "when recovering parser fails without consuming" $
it "the original parse error (and state) is reported" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ empty)
(Right <$> char a <* char b)
s = a : c : as
grs p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))
grs' p s (`failsLeaving` (c : as))
context "when inner parser succeeds without consuming" $
it "the result is returned as usual" $
property $ \a s -> do
let p :: MonadParsec Dec String m => m (Maybe Char)
p = withRecovery (const $ return Nothing) (return a)
grs p s (`shouldParse` a)
grs' p s (`succeedsLeaving` s)
context "when inner parser fails without consuming" $ do
context "when recovering parser succeeds consuming input" $
it "its result is returned and position is advanced" $
property $ \a as -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ string s) empty
s = a : as
grs p s (`shouldParse` Left (err posI mempty))
grs' p s (`succeedsLeaving` "")
context "when recovering parser fails consuming input" $
it "the original parse error (and state) is reported" $
property $ \a b as -> a /= b ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ char a <* char b <* empty)
(Right <$> empty)
s = a : as
grs p s (`shouldFailWith` err posI mempty)
grs' p s (`failsLeaving` s)
context "when recovering parser succeeds without consuming" $ do
it "its result is returned (and state)" $
property $ \s -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (return . Left) empty
grs p s (`shouldParse` Left (err posI mempty))
grs' p s (`succeedsLeaving` s)
it "original hints are preserved" $
property $ \a b as -> a /= b ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) String)
p = withRecovery (return . Left)
(Right <$> many (char a) <* empty) <* empty
s = b : as
grs p s (`shouldFailWith` err posI (etok a))
grs' p s (`failsLeaving` s)
context "when recovering parser fails without consuming" $
it "the original parse error (and state) is reported" $
property $ \s -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = withRecovery (\e -> Left e <$ empty) empty
grs p s (`shouldFailWith` err posI mempty)
grs' p s (`failsLeaving` s)
it "works in complex situations too" $
property $ \a' b' c' -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) 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
ma = if a < 3 then etok 'a' else mempty
s = abcRow a b c
[a,b,c] = getNonNegative <$> [a',b',c']
f = flip shouldFailWith
z = flip shouldParse
r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a'))
| a == 0 && b == 0 && c > 3 = f (err posI (utok 'c' <> etok 'a'))
| a == 0 && b == 0 = f (err posI (utok 'c' <> etok 'a'))
| a == 0 && b > 3 = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'a' <> etok 'c'))
| a == 0 && c == 0 = f (err (posN b s) (ueof <> etok 'a' <> etok 'c'))
| a == 0 && c > 3 = f (err (posN (b + 3) s) (utok 'c' <> eeof))
| a == 0 = z (Left (err posI (utok 'b' <> etok 'a')))
| a > 3 = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))
| b == 0 && c == 0 = f (err (posN a s) (ueof <> etok 'c' <> ma))
| b == 0 && c > 3 = f (err (posN (a + 3) s) (utok 'c' <> eeof))
| b == 0 = z (Right s)
| otherwise = f (err (posN a s) (utok 'b' <> etok 'c' <> ma))
grs (p <* eof) s r
describe "observing" $ do
context "when inner parser succeeds consuming" $
it "returns its result in Right" $
property $ \a as -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = observing (char a)
s = a : as
grs p s (`shouldParse` Right a)
grs' p s (`succeedsLeaving` as)
context "when inner parser fails consuming" $ do
it "returns its parse error in Left preserving state" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = observing (char a *> char b)
s = a : c : as
grs p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))
grs' p s (`succeedsLeaving` (c:as))
it "does not create any hints" $
property $ \a b c as -> b /= c ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = observing (char a *> char b) *> empty
s = a : c : as
grs p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)
grs' p s (`failsLeaving` (c:as))
context "when inner parser succeeds without consuming" $
it "returns its result in Right" $
property $ \a s -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = observing (return a)
grs p s (`shouldParse` Right a)
grs' p s (`succeedsLeaving` s)
context "when inner parser fails without consuming" $ do
it "returns its parse error in Left preserving state" $
property $ \s -> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) ())
p = observing empty
grs p s (`shouldParse` Left (err posI mempty))
grs' p s (`succeedsLeaving` s)
it "creates correct hints" $
property $ \a b as -> a /= b ==> do
let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)
p = observing (char a) <* empty
s = b : as
grs p s (`shouldFailWith` err posI (etok a))
grs' p s (`failsLeaving` (b:as))
describe "eof" $ do
context "when input stream is empty" $
it "succeeds" $
grs eof "" (`shouldParse` ())
context "when input stream is not empty" $
it "signals correct error message" $
property $ \a as -> do
let s = a : as
grs eof s (`shouldFailWith` err posI (utok a <> eeof))
grs' eof s (`failsLeaving` s)
describe "token" $ do
let f x = E.singleton (Tokens $ nes x)
testChar a x = if x == a then Right x else Left (f x, f a, E.empty)
context "when supplied predicate is satisfied" $
it "succeeds" $
property $ \a as mtok -> do
let p :: MonadParsec Dec String m => m Char
p = token (testChar a) mtok
s = a : as
grs p s (`shouldParse` a)
grs' p s (`succeedsLeaving` as)
context "when supplied predicate is not satisfied" $
it "signals correct parse error" $
property $ \a b as mtok -> a /= b ==> do
let p :: MonadParsec Dec String m => m Char
p = token (testChar b) mtok
s = a : as
grs p s (`shouldFailWith` ParseError
{ errorPos = posI
, errorUnexpected = E.singleton (Tokens $ nes a)
, errorExpected = E.singleton (Tokens $ nes b)
, errorCustom = E.empty })
grs' p s (`failsLeaving` s)
context "when stream is empty" $
it "signals correct parse error" $
property $ \a mtok -> do
let p :: MonadParsec Dec String m => m Char
p = token (testChar a) mtok
grs p "" (`shouldFailWith` ParseError
{ errorPos = posI
, errorUnexpected = E.singleton EndOfInput
, errorExpected = maybe E.empty (E.singleton . Tokens . nes) mtok
, errorCustom = E.empty })
describe "tokens" $ do
context "when stream is prefixed with given string" $
it "parses the string" $
property $ \str s -> do
let p :: MonadParsec Dec String m => m String
p = tokens (==) str
s' = str ++ s
grs p s' (`shouldParse` str)
grs' p s' (`succeedsLeaving` s)
context "when stream is not prefixed with given string" $
it "signals correct parse error" $
property $ \str s -> not (str `isPrefixOf` s) ==> do
let p :: MonadParsec Dec String m => m String
p = tokens (==) str
z = toFirstMismatch (==) str s
grs p s (`shouldFailWith` err posI (utoks z <> etoks str))
grs' p s (`failsLeaving` s)
describe "combinators for manipulating parser state" $ do
describe "setInput and getInput" $
it "sets input and gets it back" $
property $ \s -> do
let p = do
st0 <- getInput
guard (null st0)
setInput s
result <- string s
st1 <- getInput
guard (null st1)
return result
prs p "" `shouldParse` s
describe "setPosition and getPosition" $
it "sets position and gets it back" $
property $ \st pos -> do
let p :: Parser SourcePos
p = setPosition pos >> getPosition
f (State s (_:|xs) tp w) y = State s (y:|xs) tp w
runParser' p st `shouldBe` (f st pos, Right pos)
describe "pushPosition" $
it "adds a layer to position stack and parser continues on that level" $
property $ \st pos -> do
let p :: Parser ()
p = pushPosition pos
fst (runParser' p st) `shouldBe`
st { statePos = NE.cons pos (statePos st) }
describe "popPosition" $
it "removes a layer from position stack" $
property $ \st -> do
let p :: Parser ()
p = popPosition
pos = statePos st
fst (runParser' p st) `shouldBe`
st { statePos = fromMaybe pos (snd (NE.uncons pos)) }
describe "setTokensProcessed and getTokensProcessed" $
it "sets number of processed toknes and gets it back" $
property $ \tp -> do
let p = setTokensProcessed tp >> getTokensProcessed
prs p "" `shouldParse` tp
describe "setTabWidth and getTabWidth" $
it "sets tab width and gets it back" $
property $ \w -> do
let p = setTabWidth w >> getTabWidth
prs p "" `shouldParse` w
describe "setParserState and getParserState" $
it "sets parser state and gets it back" $
property $ \s1 s2 -> do
let p :: MonadParsec Dec String m => m (State String)
p = do
st <- getParserState
guard (st == State s posI 0 defaultTabWidth)
setParserState s1
updateParserState (f s2)
liftM2 const getParserState (setInput "")
f (State s1' pos tp w) (State s2' _ _ _) = State (max s1' s2') pos tp w
s = ""
grs p s (`shouldParse` f s2 s1)
describe "running a parser" $ do
describe "parseMaybe" $
it "returns result on success and Nothing on failure" $
property $ \s s' -> do
let p = string s' :: Parser String
parseMaybe p s `shouldBe`
if s == s' then Just s else Nothing
describe "runParser'" $
it "works" $
property $ \st s -> do
let p = string s
runParser' p st `shouldBe` emulateStrParsing st s
describe "runParserT'" $
it "works" $
property $ \st s -> do
let p = string s
runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s
describe "MonadParsec instance of ReaderT" $ do
describe "try" $
it "generally works" $
property $ \pre ch1 ch2 -> do
let s1 = pre : [ch1]
s2 = pre : [ch2]
getS1 = asks fst
getS2 = asks snd
p = try (g =<< getS1) <|> (g =<< getS2)
g = sequence . fmap char
s = [pre]
prs (runReaderT p (s1, s2)) s `shouldFailWith`
err (posN (1 :: Int) s) (ueof <> etok ch1 <> etok ch2)
describe "notFollowedBy" $
it "generally works" $
property $ \a' b' c' -> do
let p = many (char =<< ask) <* notFollowedBy eof <* many anyChar
[a,b,c] = getNonNegative <$> [a',b',c']
s = abcRow a b c
if b > 0 || c > 0
then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'
else prs (runReaderT p 'a') s `shouldFailWith`
err (posN a s) (ueof <> etok 'a')
describe "MonadParsec instance of lazy StateT" $ do
describe "(<|>)" $
it "generally works" $
property $ \n -> do
let p = L.put n >>
((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get
prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)
describe "lookAhead" $
it "generally works" $
property $ \n -> do
let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get
prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)
describe "notFollowedBy" $
it "generally works" $
property $ \n -> do
let p = do
L.put n
let notEof = notFollowedBy (L.modify (* 2) >> eof)
some (try (anyChar <* notEof)) <* char 'x'
prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)
describe "observing" $ do
context "when inner parser succeeds" $
it "can affect state" $
property $ \m n -> do
let p = do
L.put m
observing (L.modify (+ n))
prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)
context "when inner parser fails" $
it "cannot affect state" $
property $ \m n -> do
let p = do
L.put m
observing (L.modify (+ n) <* empty)
prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)
describe "MonadParsec instance of strict StateT" $ do
describe "(<|>)" $
it "generally works" $
property $ \n -> do
let p = S.put n >>
((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get
prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)
describe "lookAhead" $
it "generally works" $
property $ \n -> do
let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get
prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)
describe "notFollowedBy" $
it "generally works" $
property $ \n -> do
let p = do
S.put n
let notEof = notFollowedBy (S.modify (* 2) >> eof)
some (try (anyChar <* notEof)) <* char 'x'
prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)
describe "observing" $ do
context "when inner parser succeeds" $
it "can affect state" $
property $ \m n -> do
let p = do
S.put m
observing (L.modify (+ n))
prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)
context "when inner parser fails" $
it "cannot affect state" $
property $ \m n -> do
let p = do
S.put m
observing (L.modify (+ n) <* empty)
prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)
describe "MonadParsec instance of lazy WriterT" $ do
it "generally works" $
property $ \pre post -> do
let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x
loggedEof = eof >> L.tell "EOF"
p = do
L.tell pre
cs <- L.censor (fmap toUpper) $
some (try (loggedLetter <* notFollowedBy loggedEof))
L.tell post
void loggedLetter
return cs
prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")
describe "lookAhead" $
it "discards what writer tells inside it" $
property $ \w -> do
let p = lookAhead (L.tell [w])
prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
describe "notFollowedBy" $
it "discards what writer tells inside it" $
property $ \w -> do
let p = notFollowedBy (L.tell [w] <* char 'a')
prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
describe "observing" $ do
context "when inner parser succeeds" $
it "can affect log" $
property $ \n -> do
let p = observing (L.tell $ Sum n)
prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)
context "when inner parser fails" $
it "cannot affect log" $
property $ \n -> do
let p = observing (L.tell (Sum n) <* empty)
prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)
describe "MonadParsec instance of strict WriterT" $ do
it "generally works" $
property $ \pre post -> do
let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x
loggedEof = eof >> S.tell "EOF"
p = do
S.tell pre
cs <- L.censor (fmap toUpper) $
some (try (loggedLetter <* notFollowedBy loggedEof))
S.tell post
void loggedLetter
return cs
prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")
describe "lookAhead" $
it "discards what writer tells inside it" $
property $ \w -> do
let p = lookAhead (S.tell [w])
prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
describe "notFollowedBy" $
it "discards what writer tells inside it" $
property $ \w -> do
let p = notFollowedBy (S.tell [w] <* char 'a')
prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
describe "observing" $ do
context "when inner parser succeeds" $
it "can affect log" $
property $ \n -> do
let p = observing (S.tell $ Sum n)
prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)
context "when inner parser fails" $
it "cannot affect log" $
property $ \n -> do
let p = observing (S.tell (Sum n) <* empty)
prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)
describe "MonadParsec instance of lazy RWST" $ do
describe "label" $
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = label "a" ((,) <$> L.ask <*> L.get)
prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
describe "try" $
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = try ((,) <$> L.ask <*> L.get)
prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
describe "lookAhead" $ do
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = lookAhead ((,) <$> L.ask <*> L.get)
prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
it "discards what writer tells inside it" $
property $ \w -> do
let p = lookAhead (L.tell [w])
prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
((), 0, mempty :: [Int])
it "does not allow to influence state outside it" $
property $ \s0 s1 -> (s0 /= s1) ==> do
let p = lookAhead (L.put s1)
prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
((), s0, mempty :: [Int])
describe "notFollowedBy" $ do
it "discards what writer tells inside it" $
property $ \w -> do
let p = notFollowedBy (L.tell [w] <* char 'a')
prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
((), 0, mempty :: [Int])
it "does not allow to influence state outside it" $
property $ \s0 s1 -> (s0 /= s1) ==> do
let p = notFollowedBy (L.put s1 <* char 'a')
prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
((), s0, mempty :: [Int])
describe "withRecovery" $ do
it "allows main parser to access reader context and state inside it" $
property $ \r s -> do
let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)
prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
it "allows recovering parser to access reader context and state inside it" $
property $ \r s -> do
let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty
prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
describe "observing" $ do
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = observing ((,) <$> L.ask <*> L.get)
prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
(Right (r, s), s, mempty :: [Int])
context "when the inner parser fails" $
it "backtracks state" $
property $ \r s0 s1 -> (s0 /= s1) ==> do
let p = observing (L.put s1 <* empty)
prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`
(Left (err posI mempty), s0, mempty :: [Int])
describe "MonadParsec instance of strict RWST" $ do
describe "label" $
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = label "a" ((,) <$> S.ask <*> S.get)
prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
describe "try" $
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = try ((,) <$> S.ask <*> S.get)
prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
describe "lookAhead" $ do
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = lookAhead ((,) <$> S.ask <*> S.get)
prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
it "discards what writer tells inside it" $
property $ \w -> do
let p = lookAhead (S.tell [w])
prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
((), 0, mempty :: [Int])
it "does not allow to influence state outside it" $
property $ \s0 s1 -> (s0 /= s1) ==> do
let p = lookAhead (S.put s1)
prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
((), s0, mempty :: [Int])
describe "notFollowedBy" $ do
it "discards what writer tells inside it" $
property $ \w -> do
let p = notFollowedBy (S.tell [w] <* char 'a')
prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
((), 0, mempty :: [Int])
it "does not allow to influence state outside it" $
property $ \s0 s1 -> (s0 /= s1) ==> do
let p = notFollowedBy (S.put s1 <* char 'a')
prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
((), s0, mempty :: [Int])
describe "withRecovery" $ do
it "allows main parser to access reader context and state inside it" $
property $ \r s -> do
let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)
prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
it "allows recovering parser to access reader context and state inside it" $
property $ \r s -> do
let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty
prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
((r, s), s, mempty :: [Int])
describe "observing" $ do
it "allows to access reader context and state inside it" $
property $ \r s -> do
let p = observing ((,) <$> S.ask <*> S.get)
prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
(Right (r, s), s, mempty :: [Int])
context "when the inner parser fails" $
it "backtracks state" $
property $ \r s0 s1 -> (s0 /= s1) ==> do
let p = observing (S.put s1 <* empty)
prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`
(Left (err posI mempty), s0, mempty :: [Int])
describe "dbg" $ do
-- NOTE We don't test properties here to avoid flood of debugging output
-- when the test runs.
context "when inner parser succeeds consuming input" $ do
it "has no effect on how parser works" $ do
let p = dbg "char" (char 'a')
s = "ab"
prs p s `shouldParse` 'a'
prs' p s `succeedsLeaving` "b"
it "its hints are preserved" $ do
let p = dbg "many chars" (many (char 'a')) <* empty
s = "abcd"
prs p s `shouldFailWith` err (posN (1 :: Int) s) (etok 'a')
prs' p s `failsLeaving` "bcd"
context "when inner parser fails consuming input" $
it "has no effect on how parser works" $ do
let p = dbg "chars" (char 'a' *> char 'c')
s = "abc"
prs p s `shouldFailWith` err (posN (1 :: Int) s) (utok 'b' <> etok 'c')
prs' p s `failsLeaving` "bc"
context "when inner parser succeeds without consuming" $ do
it "has no effect on how parser works" $ do
let p = dbg "return" (return 'a')
s = "abc"
prs p s `shouldParse` 'a'
prs' p s `succeedsLeaving` s
it "its hints are preserved" $ do
let p = dbg "many chars" (many (char 'a')) <* empty
s = "bcd"
prs p s `shouldFailWith` err posI (etok 'a')
prs' p s `failsLeaving` "bcd"
context "when inner parser fails without consuming" $
it "has no effect on how parser works" $ do
let p = dbg "empty" (void empty)
s = "abc"
prs p s `shouldFailWith` err posI mempty
prs' p s `failsLeaving` s
----------------------------------------------------------------------------
-- Helpers
byteToChar :: Word8 -> Char
byteToChar = chr . fromIntegral
-- | This data type represents tokens in custom input stream.
data Span = Span
{ spanStart :: SourcePos
, spanEnd :: SourcePos
, spanBody :: NonEmpty Char
} deriving (Eq, Ord, Show)
instance Stream [Span] where
type Token [Span] = Span
uncons [] = Nothing
uncons (t:ts) = Just (t, ts)
updatePos _ _ _ (Span start end _) = (start, end)
instance Arbitrary Span where
arbitrary = do
start <- arbitrary
end <- arbitrary `suchThat` (> start)
Span start end <$>
#if !MIN_VERSION_QuickCheck(2,9,0)
(NE.fromList . getNonEmpty <$> arbitrary)
#else
arbitrary
#endif
instance ShowToken Span where
showTokens ts = concat (NE.toList . spanBody <$> ts)
type CustomParser = Parsec Dec [Span]
pSpan :: Span -> CustomParser Span
pSpan span = token testToken (Just span)
where
f = E.singleton . Tokens . nes
testToken x =
if spanBody x == spanBody span
then Right span
else Left (f x, f span , E.empty)
incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])
incCoincidence st ts = do
n <- getSmall <$> arbitrary
let (pre, post) = splitAt n (stateInput st)
pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts
return st { stateInput = pre' ++ post }
emulateStrParsing
:: State String
-> String
-> (State String, Either (ParseError Char Dec) String)
emulateStrParsing st@(State i (pos:|z) tp w) s =
if l == length s
then (State (drop l i) (updatePosString w pos s :| z) (tp + fromIntegral l) w, Right s)
else (st, Left $ err (pos:|z) (etoks s <> utoks (take (l + 1) i)))
where l = length (takeWhile id $ zipWith (==) s i)