megaparsec-tests 8.0.0 → 9.0.0
raw patch · 12 files changed
+3036/−2697 lines, 12 filesdep ~basedep ~megaparsecsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, megaparsec
API changes (from Hackage documentation)
Files
- Setup.hs +4/−0
- megaparsec-tests.cabal +79/−72
- src/Test/Hspec/Megaparsec/AdHoc.hs +166/−155
- tests/Text/Megaparsec/Byte/LexerSpec.hs +116/−97
- tests/Text/Megaparsec/ByteSpec.hs +130/−86
- tests/Text/Megaparsec/Char/LexerSpec.hs +241/−195
- tests/Text/Megaparsec/CharSpec.hs +150/−105
- tests/Text/Megaparsec/DebugSpec.hs +8/−11
- tests/Text/Megaparsec/ErrorSpec.hs +139/−115
- tests/Text/Megaparsec/PosSpec.hs +8/−8
- tests/Text/Megaparsec/StreamSpec.hs +219/−157
- tests/Text/MegaparsecSpec.hs +1776/−1696
Setup.hs view
@@ -1,2 +1,6 @@+module Main (main) where+ import Distribution.Simple++main :: IO () main = defaultMain
megaparsec-tests.cabal view
@@ -1,78 +1,85 @@-name: megaparsec-tests-version: 8.0.0-cabal-version: 1.18-tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1-license: BSD2-license-file: LICENSE.md-author: Megaparsec contributors-maintainer: Mark Karpov <markkarpov92@gmail.com>-homepage: https://github.com/mrkkrp/megaparsec-bug-reports: https://github.com/mrkkrp/megaparsec/issues-category: Parsing-synopsis: Test utilities and the test suite of Megaparsec-build-type: Simple-description: Test utilities and the test suite of Megaparsec.-extra-doc-files: README.md+cabal-version: 1.18+name: megaparsec-tests+version: 9.0.0+license: BSD2+license-file: LICENSE.md+maintainer: Mark Karpov <markkarpov92@gmail.com>+author: Megaparsec contributors+tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1+homepage: https://github.com/mrkkrp/megaparsec+bug-reports: https://github.com/mrkkrp/megaparsec/issues+synopsis: Test utilities and the test suite of Megaparsec+description: Test utilities and the test suite of Megaparsec.+category: Parsing+build-type: Simple+extra-doc-files: README.md flag dev- description: Turn on development settings.- manual: True- default: False+ description: Turn on development settings.+ default: False+ manual: True library- hs-source-dirs: src- build-depends: QuickCheck >= 2.10 && < 2.14- , base >= 4.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , containers >= 0.5 && < 0.7- , hspec >= 2.0 && < 3.0- , hspec-expectations >= 0.8 && < 0.9- , hspec-megaparsec >= 2.0 && < 3.0- , megaparsec == 8.0.0- , mtl >= 2.2.2 && < 3.0- , text >= 0.2 && < 1.3- , transformers >= 0.4 && < 0.6- exposed-modules: Test.Hspec.Megaparsec.AdHoc- if flag(dev)- ghc-options: -Wall -Werror -Wcompat- -Wincomplete-record-updates- -Wincomplete-uni-patterns- -Wnoncanonical-monad-instances- else- ghc-options: -O2 -Wall- default-language: Haskell2010+ exposed-modules: Test.Hspec.Megaparsec.AdHoc+ hs-source-dirs: src+ default-language: Haskell2010+ build-depends:+ QuickCheck >=2.10 && <2.15,+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ containers >=0.5 && <0.7,+ hspec >=2.0 && <3.0,+ hspec-expectations >=0.8 && <0.9,+ hspec-megaparsec >=2.0 && <3.0,+ megaparsec ==9.0.0,+ mtl >=2.2.2 && <3.0,+ text >=0.2 && <1.3,+ transformers >=0.4 && <0.6 + if flag(dev)+ ghc-options:+ -Wall -Werror -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances++ else+ ghc-options: -O2 -Wall+ test-suite tests- main-is: Spec.hs- hs-source-dirs: tests- type: exitcode-stdio-1.0- if flag(dev)- ghc-options: -O0 -Wall -Werror- else- ghc-options: -O2 -Wall- other-modules: Text.Megaparsec.Byte.LexerSpec- , Text.Megaparsec.ByteSpec- , Text.Megaparsec.Char.LexerSpec- , Text.Megaparsec.CharSpec- , Text.Megaparsec.DebugSpec- , Text.Megaparsec.ErrorSpec- , Text.Megaparsec.PosSpec- , Text.Megaparsec.StreamSpec- , Text.MegaparsecSpec- build-depends: QuickCheck >= 2.10 && < 2.14- , base >= 4.11 && < 5.0- , bytestring >= 0.2 && < 0.11- , case-insensitive >= 1.2 && < 1.3- , containers >= 0.5 && < 0.7- , hspec >= 2.0 && < 3.0- , hspec-expectations >= 0.8 && < 0.9- , hspec-megaparsec >= 2.0 && < 3.0- , megaparsec == 8.0.0- , megaparsec-tests- , mtl >= 2.2.2 && < 3.0- , parser-combinators >= 1.0 && < 2.0- , scientific >= 0.3.1 && < 0.4- , text >= 0.2 && < 1.3- , transformers >= 0.4 && < 0.6- build-tools: hspec-discover >= 2.0 && < 3.0- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tools: hspec-discover >=2.0 && <3.0+ hs-source-dirs: tests+ other-modules:+ Text.Megaparsec.Byte.LexerSpec+ Text.Megaparsec.ByteSpec+ Text.Megaparsec.Char.LexerSpec+ Text.Megaparsec.CharSpec+ Text.Megaparsec.DebugSpec+ Text.Megaparsec.ErrorSpec+ Text.Megaparsec.PosSpec+ Text.Megaparsec.StreamSpec+ Text.MegaparsecSpec++ default-language: Haskell2010+ build-depends:+ QuickCheck >=2.10 && <2.15,+ base >=4.12 && <5.0,+ bytestring >=0.2 && <0.11,+ case-insensitive >=1.2 && <1.3,+ containers >=0.5 && <0.7,+ hspec >=2.0 && <3.0,+ hspec-expectations >=0.8 && <0.9,+ hspec-megaparsec >=2.0 && <3.0,+ megaparsec ==9.0.0,+ megaparsec-tests -any,+ mtl >=2.2.2 && <3.0,+ parser-combinators >=1.0 && <2.0,+ scientific >=0.3.1 && <0.4,+ text >=0.2 && <1.3,+ transformers >=0.4 && <0.6++ if flag(dev)+ ghc-options: -O0 -Wall -Werror++ else+ ghc-options: -O2 -Wall
src/Test/Hspec/Megaparsec/AdHoc.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | -- Module : Test.Hspec.Megaparsec.AdHoc -- Copyright : © 2019–present Megaparsec contributors@@ -8,71 +15,67 @@ -- Portability : portable -- -- Ad-hoc helpers used in Megaparsec's test suite.--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}- module Test.Hspec.Megaparsec.AdHoc ( -- * Types- Parser+ Parser,+ -- * Helpers to run parsers- , prs- , prs'- , prs_- , grs- , grs'+ prs,+ prs',+ prs_,+ grs,+ grs',+ -- * Other- , nes- , abcRow- , rightOrder- , scaleDown- , getTabWidth- , setTabWidth- , strSourcePos+ nes,+ abcRow,+ rightOrder,+ scaleDown,+ getTabWidth,+ setTabWidth,+ strSourcePos,+ -- * Char and byte conversion- , toChar- , fromChar+ toChar,+ fromChar,+ -- * Proxies- , sproxy- , bproxy- , blproxy- , tproxy- , tlproxy )+ sproxy,+ bproxy,+ blproxy,+ tproxy,+ tlproxy,+ ) where +import qualified Control.Monad.RWS.Lazy as L+import qualified Control.Monad.RWS.Strict as S import Control.Monad.Reader+import qualified Control.Monad.State.Lazy as L+import qualified Control.Monad.State.Strict as S import Control.Monad.Trans.Identity+import qualified Control.Monad.Writer.Lazy as L+import qualified Control.Monad.Writer.Strict as S+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Char (chr, ord) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Proxy+import qualified Data.Set as E+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Data.Void import Data.Word (Word8) import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck import Text.Megaparsec-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 as B-import qualified Data.ByteString.Lazy 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 ---------------------------------------------------------------------------- -- Types -- | The type of parser that consumes a 'String'.- type Parser = Parsec Void String ----------------------------------------------------------------------------@@ -80,167 +83,163 @@ -- | Apply parser to given input. This is a specialized version of 'parse' -- that assumes empty file name.--prs- :: Parser a- -- ^ Parser to run- -> String- -- ^ Input for the parser- -> Either (ParseErrorBundle String Void) a- -- ^ Result of parsing+prs ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ String ->+ -- | Result of parsing+ Either (ParseErrorBundle String Void) a prs p = parse p "" -- | Just like 'prs', but allows to inspect the final state of the parser.--prs'- :: Parser a- -- ^ Parser to run- -> String- -- ^ Input for the parser- -> (State String Void, Either (ParseErrorBundle String Void) a)- -- ^ Result of parsing+prs' ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ String ->+ -- | Result of parsing+ (State String Void, Either (ParseErrorBundle String Void) a) prs' p s = runParser' p (initialState s) -- | Just like 'prs', but forces the parser to consume all input by adding -- 'eof': -- -- > prs_ p = parse (p <* eof) ""--prs_- :: Parser a- -- ^ Parser to run- -> String- -- ^ Input for the parser- -> Either (ParseErrorBundle String Void) a- -- ^ Result of parsing+prs_ ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ String ->+ -- | Result of parsing+ Either (ParseErrorBundle String Void) a prs_ p = parse (p <* eof) "" -- | Just like 'prs', but interprets given parser as various monads (tries -- all supported monads transformers in turn).--grs- :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run- -> String -- ^ Input for the parser- -> (Either (ParseErrorBundle String Void) a -> Expectation)- -- ^ How to check result of parsing- -> Expectation+grs ::+ -- | Parser to run+ (forall m. MonadParsec Void String m => m a) ->+ -- | Input for the parser+ String ->+ -- | How to check result of parsing+ (Either (ParseErrorBundle String Void) a -> Expectation) ->+ Expectation grs p s r = do r (prs p s)- r (prs (runIdentityT p) s)- r (prs (runReaderT p ()) s)+ r (prs (runIdentityT p) s)+ r (prs (runReaderT p ()) s) r (prs (L.evalStateT p ()) s) r (prs (S.evalStateT p ()) s)- r (prs (evalWriterTL p) s)- r (prs (evalWriterTS p) s)- r (prs (evalRWSTL p) s)- r (prs (evalRWSTS p) s)+ r (prs (evalWriterTL p) s)+ r (prs (evalWriterTS p) s)+ r (prs (evalRWSTL p) s)+ r (prs (evalRWSTS p) s) -- | 'grs'' to 'grs' is as 'prs'' to 'prs'.--grs'- :: (forall m. MonadParsec Void String m => m a) -- ^ Parser to run- -> String -- ^ Input for the parser- -> ((State String Void, Either (ParseErrorBundle String Void) a) -> Expectation)- -- ^ How to check result of parsing- -> Expectation+grs' ::+ -- | Parser to run+ (forall m. MonadParsec Void String m => m a) ->+ -- | Input for the parser+ String ->+ -- | How to check result of parsing+ ((State String Void, Either (ParseErrorBundle String Void) a) -> Expectation) ->+ Expectation grs' p s r = do r (prs' p s)- r (prs' (runIdentityT p) s)- r (prs' (runReaderT p ()) s)+ r (prs' (runIdentityT p) s)+ r (prs' (runReaderT p ()) s) r (prs' (L.evalStateT p ()) s) r (prs' (S.evalStateT p ()) s)- r (prs' (evalWriterTL p) s)- r (prs' (evalWriterTS p) s)- r (prs' (evalRWSTL p) s)- r (prs' (evalRWSTS p) s)+ r (prs' (evalWriterTL p) s)+ r (prs' (evalWriterTS p) s)+ r (prs' (evalRWSTL p) s)+ r (prs' (evalRWSTS p) s) evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a evalWriterTL = fmap fst . L.runWriterT+ evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a evalWriterTS = fmap fst . S.runWriterT evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a evalRWSTL m = do- (a,_,_) <- L.runRWST m () ()+ (a, _, _) <- L.runRWST m () () return a evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a evalRWSTS m = do- (a,_,_) <- S.runRWST m () ()+ (a, _, _) <- S.runRWST m () () return a ---------------------------------------------------------------------------- -- Other -- | Make a singleton non-empty list from a value.- nes :: a -> NonEmpty a nes x = x :| [] -- | @abcRow a b c@ generates string consisting of character “a” repeated -- @a@ times, character “b” repeated @b@ times, and character “c” repeated -- @c@ times.- abcRow :: Int -> Int -> Int -> String abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c' -- | Check that the given parser returns the list in the right order.--rightOrder- :: Parser String -- ^ The parser to test- -> String -- ^ Input for the parser- -> String -- ^ Expected result- -> Spec+rightOrder ::+ -- | The parser to test+ Parser String ->+ -- | Input for the parser+ String ->+ -- | Expected result+ String ->+ Spec rightOrder p s s' = it "produces the list in the right order" $ prs_ p s `shouldParse` s' -- | Get tab width from 'PosState'. Use with care only for testing.- getTabWidth :: MonadParsec e s m => m Pos getTabWidth = pstateTabWidth . statePosState <$> getParserState -- | Set tab width in 'PosState'. Use with care only for testing.- setTabWidth :: MonadParsec e s m => Pos -> m () setTabWidth w = updateParserState $ \st -> let pst = statePosState st- in st { statePosState = pst { pstateTabWidth = w } }+ in st {statePosState = pst {pstateTabWidth = w}} -- | Scale down.- scaleDown :: Gen a -> Gen a scaleDown = scale (`div` 4) -- | A helper function that is used to advance 'SourcePos' given a 'String'.- strSourcePos :: Pos -> SourcePos -> String -> SourcePos strSourcePos tabWidth ipos input = let (_, pst') = reachOffset maxBound pstate in pstateSourcePos pst' where- pstate = PosState- { pstateInput = input- , pstateOffset = 0- , pstateSourcePos = ipos- , pstateTabWidth = tabWidth- , pstateLinePrefix = ""- }+ pstate =+ PosState+ { pstateInput = input,+ pstateOffset = 0,+ pstateSourcePos = ipos,+ pstateTabWidth = tabWidth,+ pstateLinePrefix = ""+ } ---------------------------------------------------------------------------- -- Char and byte conversion -- | Convert a byte to char.- toChar :: Word8 -> Char toChar = chr . fromIntegral -- | Covert a char to byte.- fromChar :: Char -> Maybe Word8-fromChar x = let p = ord x in- if p > 0xff- then Nothing- else Just (fromIntegral p)+fromChar x =+ let p = ord x+ in if p > 0xff+ then Nothing+ else Just (fromIntegral p) ---------------------------------------------------------------------------- -- Proxies@@ -270,55 +269,67 @@ arbitrary = mkPos <$> (getSmall . getPositive <$> arbitrary) instance Arbitrary SourcePos where- arbitrary = SourcePos- <$> scaleDown arbitrary- <*> arbitrary- <*> arbitrary+ arbitrary =+ SourcePos+ <$> scaleDown arbitrary+ <*> arbitrary+ <*> arbitrary instance Arbitrary t => Arbitrary (ErrorItem t) where- arbitrary = oneof- [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)- , Label <$> (NE.fromList . getNonEmpty <$> arbitrary)- , return EndOfInput ]+ arbitrary =+ oneof+ [ Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary),+ Label <$> (NE.fromList . getNonEmpty <$> arbitrary),+ return EndOfInput+ ] instance Arbitrary (ErrorFancy a) where- arbitrary = oneof- [ ErrorFail <$> scaleDown arbitrary- , ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]+ arbitrary =+ oneof+ [ ErrorFail <$> scaleDown arbitrary,+ ErrorIndentation <$> arbitrary <*> arbitrary <*> arbitrary+ ] -instance (Arbitrary (Token s), Ord (Token s), Arbitrary e, Ord e)- => Arbitrary (ParseError s e) where- arbitrary = oneof- [ TrivialError- <$> (getNonNegative <$> arbitrary)- <*> arbitrary- <*> (E.fromList <$> scaleDown arbitrary)- , FancyError- <$> (getNonNegative <$> arbitrary)- <*> (E.fromList <$> scaleDown arbitrary) ]+instance+ (Arbitrary (Token s), Ord (Token s), Arbitrary e, Ord e) =>+ Arbitrary (ParseError s e)+ where+ arbitrary =+ oneof+ [ TrivialError+ <$> (getNonNegative <$> arbitrary)+ <*> arbitrary+ <*> (E.fromList <$> scaleDown arbitrary),+ FancyError+ <$> (getNonNegative <$> arbitrary)+ <*> (E.fromList <$> scaleDown arbitrary)+ ] instance Arbitrary s => Arbitrary (State s e) where arbitrary = do- input <- scaleDown arbitrary+ input <- scaleDown arbitrary offset <- choose (1, 10000) pstate :: PosState s <- arbitrary- return State- { stateInput = input- , stateOffset = offset- , statePosState = pstate- { pstateInput = input- , pstateOffset = offset+ return+ State+ { stateInput = input,+ stateOffset = offset,+ statePosState =+ pstate+ { pstateInput = input,+ pstateOffset = offset+ },+ stateParseErrors = [] }- , stateParseErrors = []- } instance Arbitrary s => Arbitrary (PosState s) where- arbitrary = PosState- <$> arbitrary- <*> choose (1, 10000)- <*> arbitrary- <*> (mkPos <$> choose (1, 20))- <*> scaleDown arbitrary+ arbitrary =+ PosState+ <$> arbitrary+ <*> choose (1, 10000)+ <*> arbitrary+ <*> (mkPos <$> choose (1, 20))+ <*> scaleDown arbitrary instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
tests/Text/Megaparsec/Byte/LexerSpec.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.Byte.LexerSpec (spec) where import Control.Applicative import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 import Data.Char (intToDigit, toUpper) import Data.Scientific (Scientific, fromFloatDigits) import Data.Void import Data.Word (Word8)-import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt)+import Numeric (showFFloatAlt, showHex, showInt, showIntAtBase, showOct) import Test.Hspec import Test.Hspec.Megaparsec import Test.QuickCheck import Text.Megaparsec+import qualified Text.Megaparsec.Byte as B import Text.Megaparsec.Byte.Lexer-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Text.Megaparsec.Byte as B #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -27,34 +27,37 @@ spec :: Spec spec = do- describe "skipLineComment" $ do context "when there is no newline at the end of line" $ it "is picked up successfully" $ do let p = space B.space1 (skipLineComment "//") empty <* eof s = " // this line comment doesn't have a newline at the end "- prs p s `shouldParse` ()+ prs p s `shouldParse` () prs' p s `succeedsLeaving` "" it "inner characters are labelled properly" $ do let p = skipLineComment "//" <* empty s = "// here we go"- prs p s `shouldFailWith` err (B.length s) (elabel "character")+ prs p s `shouldFailWith` err (B.length s) (elabel "character") prs' p s `failsLeaving` "" describe "skipBlockComment" $ it "skips a simple block comment" $ do let p = skipBlockComment "/*" "*/" s = "/* here we go */foo!"- prs p s `shouldParse` ()+ prs p s `shouldParse` () prs' p s `succeedsLeaving` "foo!" describe "skipBlockCommentNested" $ context "when it runs into nested block comments" $ it "parses them all right" $ do- let p = space B.space1 empty- (skipBlockCommentNested "/*" "*/") <* eof+ let p =+ space+ B.space1+ empty+ (skipBlockCommentNested "/*" "*/")+ <* eof s = " /* foo bar /* baz */ quux */ "- prs p s `shouldParse` ()+ prs p s `shouldParse` () prs' p s `succeedsLeaving` "" describe "decimal" $ do@@ -64,18 +67,19 @@ let p = decimal :: Parser Integer n = getNonNegative n' s = B8.pack (showInt n "")- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with decimal digits" $ it "signals correct parse error" $- property $ \a as -> not (isDigit a) ==> do- let p = decimal :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith` err 0 (utok a <> elabel "integer")+ property $ \a as ->+ not (isDigit a) ==> do+ let p = decimal :: Parser Integer+ s = B.pack (a : as)+ prs p s `shouldFailWith` err 0 (utok a <> elabel "integer") context "when stream is empty" $ it "signals correct parse error" $- prs (decimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "integer")+ prs (decimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "integer") describe "binary" $ do context "when stream begins with binary digits" $@@ -84,19 +88,20 @@ let p = binary :: Parser Integer n = getNonNegative n' s = B8.pack (showIntAtBase 2 intToDigit n "")- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with binary digits" $ it "signals correct parse error" $- property $ \a as -> a /= 48 && a /= 49 ==> do- let p = binary :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "binary integer")+ property $ \a as ->+ a /= 48 && a /= 49 ==> do+ let p = binary :: Parser Integer+ s = B.pack (a : as)+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "binary integer") context "when stream is empty" $ it "signals correct parse error" $- prs (binary :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "binary integer")+ prs (binary :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "binary integer") describe "octal" $ do context "when stream begins with octal digits" $@@ -105,19 +110,20 @@ let p = octal :: Parser Integer n = getNonNegative n' s = B8.pack (showOct n "")- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with octal digits" $ it "signals correct parse error" $- property $ \a as -> not (isOctDigit a) ==> do- let p = octal :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "octal integer")+ property $ \a as ->+ not (isOctDigit a) ==> do+ let p = octal :: Parser Integer+ s = B.pack (a : as)+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "octal integer") context "when stream is empty" $ it "signals correct parse error" $- prs (octal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "octal integer")+ prs (octal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "octal integer") describe "hexadecimal" $ do context "when stream begins with hexadecimal digits" $@@ -126,7 +132,7 @@ let p = hexadecimal :: Parser Integer n = getNonNegative n' s = B8.pack (showHex n "")- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream begins with hexadecimal digits (uppercase)" $ it "they are parsed as an integer" $@@ -134,29 +140,34 @@ let p = hexadecimal :: Parser Integer n = getNonNegative n' s = B8.pack (toUpper <$> showHex n "")- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with hexadecimal digits" $ it "signals correct parse error" $- property $ \a as -> not (isHexDigit a) ==> do- let p = hexadecimal :: Parser Integer- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "hexadecimal integer")+ property $ \a as ->+ not (isHexDigit a) ==> do+ let p = hexadecimal :: Parser Integer+ s = B.pack (a : as)+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "hexadecimal integer") context "when stream is empty" $ it "signals correct parse error" $- prs (hexadecimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "hexadecimal integer")+ prs (hexadecimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "hexadecimal integer") describe "scientific" $ do context "when stream begins with a number" $ it "parses it" $ property $ \n' -> do let p = scientific :: Parser Scientific- s = B8.pack $ either (show . getNonNegative) (show . getNonNegative)- (n' :: Either (NonNegative Integer) (NonNegative Double))+ s =+ B8.pack $+ either+ (show . getNonNegative)+ (show . getNonNegative)+ (n' :: Either (NonNegative Integer) (NonNegative Double)) prs p s `shouldParse` case n' of- Left x -> fromIntegral (getNonNegative x)+ Left x -> fromIntegral (getNonNegative x) Right x -> fromFloatDigits (getNonNegative x) prs' p s `succeedsLeaving` "" context "when fractional part is interrupted" $@@ -164,27 +175,29 @@ property $ \(NonNegative n) -> do let p = scientific <* empty :: Parser Scientific s = B8.pack (showFFloatAlt Nothing (n :: Double) "")- prs p s `shouldFailWith` err (B.length s)- (etok 69 <> etok 101 <> elabel "digit")+ prs p s+ `shouldFailWith` err+ (B.length s)+ (etok 69 <> etok 101 <> elabel "digit") prs' p s `failsLeaving` "" context "when whole part is followed by a dot without valid fractional part" $ it "parsing of fractional part is backtracked correctly" $ property $ \(NonNegative n) -> do let p = scientific :: Parser Scientific s = B8.pack $ showInt (n :: Integer) ".err"- prs p s `shouldParse` fromIntegral n+ prs p s `shouldParse` fromIntegral n prs' p s `succeedsLeaving` ".err" context "when number is followed by something starting with 'e'" $ it "parsing of exponent part is backtracked correctly" $ property $ \(NonNegative n) -> do let p = scientific :: Parser Scientific s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` fromFloatDigits n+ prs p s `shouldParse` fromFloatDigits n prs' p s `succeedsLeaving` "err!" context "when stream is empty" $ it "signals correct parse error" $- prs (scientific :: Parser Scientific) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")+ prs (scientific :: Parser Scientific) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") describe "float" $ do context "when stream begins with a float" $@@ -193,45 +206,49 @@ let p = float :: Parser Double n = getNonNegative n' s = B8.pack (show n)- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with a float" $ it "signals correct parse error" $- property $ \a as -> not (isDigit a) ==> do- let p = float :: Parser Double- s = B.pack (a : as)- prs p s `shouldFailWith`- err 0 (utok a <> elabel "digit")- prs' p s `failsLeaving` s+ property $ \a as ->+ not (isDigit a) ==> do+ let p = float :: Parser Double+ s = B.pack (a : as)+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "digit")+ prs' p s `failsLeaving` s context "when stream begins with an integer (decimal)" $ it "signals correct parse error" $ property $ \n' -> do let p = float :: Parser Double n = getNonNegative n' s = B8.pack $ show (n :: Integer)- prs p s `shouldFailWith` err (B.length s)- (ueof <> etok 46 <> etok 69 <> etok 101 <> elabel "digit")+ prs p s+ `shouldFailWith` err+ (B.length s)+ (ueof <> etok 46 <> etok 69 <> etok 101 <> elabel "digit") prs' p s `failsLeaving` "" context "when number is followed by something starting with 'e'" $ it "parsing of exponent part is backtracked correctly" $ property $ \(NonNegative n) -> do let p = float :: Parser Double s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "err!" context "when stream is empty" $ it "signals correct parse error" $- prs (float :: Parser Double) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")+ prs (float :: Parser Double) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") context "when there is float with just exponent" $- it "parses it all right" $ do- let p = float :: Parser Double- prs p "123e3" `shouldParse` 123e3- prs' p "123e3" `succeedsLeaving` ""- prs p "123e+3" `shouldParse` 123e+3- prs' p "123e+3" `succeedsLeaving` ""- prs p "123e-3" `shouldParse` 123e-3- prs' p "123e-3" `succeedsLeaving` ""+ it "parses it all right" $+ do+ let p = float :: Parser Double+ prs p "123e3" `shouldParse` 123e3+ prs' p "123e3" `succeedsLeaving` ""+ prs p "123e+3" `shouldParse` 123e+3+ prs' p "123e+3" `succeedsLeaving` ""+ prs p "123e-3" `shouldParse` 123e-3+ prs' p "123e-3" `succeedsLeaving` "" describe "signed" $ do context "with integer" $@@ -240,7 +257,7 @@ let p :: Parser Integer p = signed (hidden B.space) decimal s = B8.pack (show n)- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "with float" $ it "parses signed floats" $@@ -248,7 +265,7 @@ let p :: Parser Double p = signed (hidden B.space) float s = B8.pack (show n)- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "with scientific" $ it "parses singed scientific numbers" $@@ -256,7 +273,7 @@ let p = signed (hidden B.space) scientific s = B8.pack $ either show show (n :: Either Integer Double) prs p s `shouldParse` case n of- Left x -> fromIntegral x+ Left x -> fromIntegral x Right x -> fromFloatDigits x context "when number is prefixed with plus sign" $ it "parses the number" $@@ -265,7 +282,7 @@ p = signed (hidden B.space) decimal n = getNonNegative n' s = B8.pack ('+' : show n)- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when number is prefixed with white space" $ it "signals correct parse error" $@@ -273,36 +290,38 @@ let p :: Parser Integer p = signed (hidden B.space) decimal s = B8.pack (' ' : show (n :: Integer))- prs p s `shouldFailWith` err 0- (utok 32 <> etok 43 <> etok 45 <> elabel "integer")+ prs p s+ `shouldFailWith` err+ 0+ (utok 32 <> etok 43 <> etok 45 <> elabel "integer") prs' p s `failsLeaving` s context "when there is white space between sign and digits" $ it "parses it all right" $ do let p :: Parser Integer p = signed (hidden B.space) decimal s = "- 123"- prs p s `shouldParse` (-123)+ prs p s `shouldParse` (-123) prs' p s `succeedsLeaving` "" ---------------------------------------------------------------------------- -- Helpers -prs- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> Either (ParseErrorBundle ByteString Void) a- -- ^ Result of parsing+prs ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ ByteString ->+ -- | Result of parsing+ Either (ParseErrorBundle ByteString Void) a prs p = parse p "" -prs'- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> (State ByteString Void, Either (ParseErrorBundle ByteString Void) a)- -- ^ Result of parsing+prs' ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ ByteString ->+ -- | Result of parsing+ (State ByteString Void, Either (ParseErrorBundle ByteString Void) a) prs' p s = runParser' p (initialState s) isDigit :: Word8 -> Bool@@ -313,6 +332,6 @@ isHexDigit :: Word8 -> Bool isHexDigit w =- (w >= 48 && w <= 57) ||- (w >= 97 && w <= 102) ||- (w >= 65 && w <= 70)+ (w >= 48 && w <= 57)+ || (w >= 97 && w <= 102)+ || (w >= 65 && w <= 70)
tests/Text/Megaparsec/ByteSpec.hs view
@@ -1,21 +1,21 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.ByteSpec (spec) where import Control.Monad import Data.ByteString (ByteString)-import Data.Char+import qualified Data.ByteString as B+import Data.Char hiding (isSpace) import Data.Maybe (fromMaybe) import Data.Void import Data.Word (Word8) import Test.Hspec import Test.Hspec.Megaparsec-import Test.Hspec.Megaparsec.AdHoc hiding (prs, prs', Parser)+import Test.Hspec.Megaparsec.AdHoc hiding (Parser, prs, prs') import Test.QuickCheck import Text.Megaparsec import Text.Megaparsec.Byte-import qualified Data.ByteString as B #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -25,7 +25,6 @@ spec :: Spec spec = do- describe "newline" $ checkStrLit "newline" "\n" (tokenToChunk bproxy <$> newline) @@ -37,34 +36,42 @@ it "succeeds returning the newline" $ property $ \s -> do let s' = "\n" <> s- prs eol s' `shouldParse` "\n"+ prs eol s' `shouldParse` "\n" prs' eol s' `succeedsLeaving` s context "when stream begins with CRLF sequence" $ it "parses the CRLF sequence" $ property $ \s -> do let s' = "\r\n" <> s- prs eol s' `shouldParse` "\r\n"+ prs eol s' `shouldParse` "\r\n" prs' eol s' `succeedsLeaving` s context "when stream begins with '\\r', but it's not followed by '\\n'" $ it "signals correct parse error" $- property $ \ch -> ch /= 10 ==> do- let s = "\r" <> B.singleton ch- prs eol s `shouldFailWith`- err 0 (utoks s <> elabel "end of line")+ property $ \ch ->+ ch /= 10 ==> do+ let s = "\r" <> B.singleton ch+ prs eol s+ `shouldFailWith` err 0 (utoks s <> elabel "end of line") context "when input stream is '\\r'" $ it "signals correct parse error" $- prs eol "\r" `shouldFailWith` err 0- (utok 13 <> elabel "end of line")+ prs eol "\r"+ `shouldFailWith` err+ 0+ (utok 13 <> elabel "end of line") context "when stream does not begin with newline or CRLF sequence" $ it "signals correct parse error" $- property $ \ch s -> (ch /= 13 && ch /= 10) ==> do- let s' = B.singleton ch <> s- prs eol s' `shouldFailWith` err 0- (utoks (B.take 2 s') <> elabel "end of line")+ property $ \ch s ->+ (ch /= 13 && ch /= 10) ==> do+ let s' = B.singleton ch <> s+ prs eol s'+ `shouldFailWith` err+ 0+ (utoks (B.take 2 s') <> elabel "end of line") context "when stream is empty" $ it "signals correct parse error" $- prs eol "" `shouldFailWith` err 0- (ueof <> elabel "end of line")+ prs eol ""+ `shouldFailWith` err+ 0+ (ueof <> elabel "end of line") describe "tab" $ checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab)@@ -72,53 +79,79 @@ describe "space" $ it "consumes space up to first non-space character" $ property $ \s' -> do- let (s0,s1) = B.partition isSpace' s'+ let (s0, s1) = B.partition isSpace s' s = s0 <> s1- prs space s `shouldParse` ()+ prs space s `shouldParse` () prs' space s `succeedsLeaving` s1 + describe "hspace" $+ it "consumes space up to first non-space character" $+ property $ \s' -> do+ let (s0, s1) = B.partition isHSpace s'+ s = s0 <> s1+ prs hspace s `shouldParse` ()+ prs' hspace s `succeedsLeaving` s1+ describe "space1" $ do context "when stream does not start with a space character" $ it "signals correct parse error" $- property $ \ch s' -> not (isSpace' ch) ==> do- let (s0,s1) = B.partition isSpace' s'- s = B.singleton ch <> s0 <> s1- prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")- prs' space1 s `failsLeaving` s+ property $ \ch s' ->+ not (isSpace ch) ==> do+ let (s0, s1) = B.partition isSpace s'+ s = B.singleton ch <> s0 <> s1+ prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")+ prs' space1 s `failsLeaving` s context "when stream starts with a space character" $ it "consumes space up to first non-space character" $ property $ \s' -> do- let (s0,s1) = B.partition isSpace' s'+ let (s0, s1) = B.partition isSpace s' s = " " <> s0 <> s1- prs space1 s `shouldParse` ()+ prs space1 s `shouldParse` () prs' space1 s `succeedsLeaving` s1 context "when stream is empty" $ it "signals correct parse error" $ prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space") + describe "hspace1" $ do+ context "when stream does not start with a space character" $+ it "signals correct parse error" $+ property $ \ch s' ->+ not (isSpace ch) ==> do+ let (s0, s1) = B.partition isHSpace s'+ s = B.singleton ch <> s0 <> s1+ prs hspace1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")+ prs' hspace1 s `failsLeaving` s+ context "when stream starts with a space character" $+ it "consumes space up to first non-space character" $+ property $ \s' -> do+ let (s0, s1) = B.partition isHSpace s'+ s = " " <> s0 <> s1+ prs hspace1 s `shouldParse` ()+ prs' hspace1 s `succeedsLeaving` s1+ context "when stream is empty" $+ it "signals correct parse error" $+ prs hspace1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")+ describe "controlChar" $ checkCharPred "control character" (isControl . toChar) controlChar describe "spaceChar" $- checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar-- describe "alphaNumChar" $- checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar+ checkCharRange "white space" [9, 10, 11, 12, 13, 32, 160] spaceChar describe "printChar" $ checkCharPred "printable character" (isPrint . toChar) printChar describe "digitChar" $- checkCharRange "digit" [48..57] digitChar+ checkCharRange "digit" [48 .. 57] digitChar describe "binDigitChar" $- checkCharRange "binary digit" [48..49] binDigitChar+ checkCharRange "binary digit" [48 .. 49] binDigitChar describe "octDigitChar" $- checkCharRange "octal digit" [48..55] octDigitChar+ checkCharRange "octal digit" [48 .. 55] octDigitChar describe "hexDigitChar" $- checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar+ checkCharRange "hexadecimal digit" ([48 .. 57] ++ [97 .. 102] ++ [65 .. 70]) hexDigitChar describe "char'" $ do context "when stream begins with the character specified as argument" $@@ -127,24 +160,25 @@ let sl = B.cons (liftChar toLower ch) s su = B.cons (liftChar toUpper ch) s st = B.cons (liftChar toTitle ch) s- prs (char' ch) sl `shouldParse` liftChar toLower ch- prs (char' ch) su `shouldParse` liftChar toUpper ch- prs (char' ch) st `shouldParse` liftChar toTitle ch+ prs (char' ch) sl `shouldParse` liftChar toLower ch+ prs (char' ch) su `shouldParse` liftChar toUpper ch+ prs (char' ch) st `shouldParse` liftChar toTitle ch prs' (char' ch) sl `succeedsLeaving` s prs' (char' ch) su `succeedsLeaving` s prs' (char' ch) st `succeedsLeaving` s context "when stream does not begin with the character specified as argument" $ it "signals correct parse error" $- property $ \ch ch' s -> not (casei ch ch') ==> do- let s' = B.cons ch' s- ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)- prs (char' ch) s' `shouldFailWith` err 0 ms- prs' (char' ch) s' `failsLeaving` s'+ property $ \ch ch' s ->+ not (casei ch ch') ==> do+ let s' = B.cons ch' s+ ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)+ prs (char' ch) s' `shouldFailWith` err 0 ms+ prs' (char' ch) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \ch -> do let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)- prs (char' ch) "" `shouldFailWith` err 0 ms+ prs (char' ch) "" `shouldFailWith` err 0 ms ---------------------------------------------------------------------------- -- Helpers@@ -155,15 +189,16 @@ it ("parses the " ++ name) $ property $ \s -> do let s' = ts <> s- prs p s' `shouldParse` ts+ prs p s' `shouldParse` ts prs' p s' `succeedsLeaving` s context ("when stream does not begin with " ++ name) $ it "signals correct parse error" $- property $ \ch s -> ch /= B.head ts ==> do- let s' = B.cons ch s- us = B.take (B.length ts) s'- prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)- prs' p s' `failsLeaving` s'+ property $ \ch s ->+ ch /= B.head ts ==> do+ let s' = B.cons ch s+ us = B.take (B.length ts) s'+ prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)+ prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)@@ -172,16 +207,18 @@ checkCharPred name f p = do context ("when stream begins with " ++ name) $ it ("parses the " ++ name) $- property $ \ch s -> f ch ==> do- let s' = B.singleton ch <> s- prs p s' `shouldParse` ch- prs' p s' `succeedsLeaving` s+ property $ \ch s ->+ f ch ==> do+ let s' = B.singleton ch <> s+ prs p s' `shouldParse` ch+ prs' p s' `succeedsLeaving` s context ("when stream does not begin with " ++ name) $ it "signals correct parse error" $- property $ \ch s -> not (f ch) ==> do- let s' = B.singleton ch <> s- prs p s' `shouldFailWith` err 0 (utok ch <> elabel name)- prs' p s' `failsLeaving` s'+ property $ \ch s ->+ not (f ch) ==> do+ let s' = B.singleton ch <> s+ prs p s' `shouldFailWith` err 0 (utok ch <> elabel name)+ prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> elabel name)@@ -193,48 +230,55 @@ it ("parses the " ++ showTokens bproxy (nes tch)) $ property $ \s -> do let s' = B.singleton tch <> s- prs p s' `shouldParse` tch+ prs p s' `shouldParse` tch prs' p s' `succeedsLeaving` s context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> elabel name) -prs- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> Either (ParseErrorBundle ByteString Void) a- -- ^ Result of parsing+prs ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ ByteString ->+ -- | Result of parsing+ Either (ParseErrorBundle ByteString Void) a prs p = parse p "" -prs'- :: Parser a- -- ^ Parser to run- -> ByteString- -- ^ Input for the parser- -> (State ByteString Void, Either (ParseErrorBundle ByteString Void) a)- -- ^ Result of parsing+prs' ::+ -- | Parser to run+ Parser a ->+ -- | Input for the parser+ ByteString ->+ -- | Result of parsing+ (State ByteString Void, Either (ParseErrorBundle ByteString Void) a) prs' p s = runParser' p (initialState s) --- | 'Word8'-specialized version of 'isSpace'.--isSpace' :: Word8 -> Bool-isSpace' x+-- | 'Word8'-specialized version of 'Data.Char.isSpace'.+isSpace :: Word8 -> Bool+isSpace x | x >= 9 && x <= 13 = True- | x == 32 = True- | x == 160 = True- | otherwise = False+ | x == 32 = True+ | x == 160 = True+ | otherwise = False --- | Lift char transformation to byte transformation.+-- | Like 'isSpace', but does not accept newlines and carriage returns.+isHSpace :: Word8 -> Bool+isHSpace x+ | x == 9 = True+ | x == 11 = True+ | x == 12 = True+ | x == 32 = True+ | x == 160 = True+ | otherwise = False +-- | Lift char transformation to byte transformation. liftChar :: (Char -> Char) -> Word8 -> Word8 liftChar f x = (fromMaybe x . fromChar . f . toChar) x -- | Compare two characters case-insensitively.- casei :: Word8 -> Word8 -> Bool casei x y =- x == liftChar toLower y ||- x == liftChar toUpper y ||- x == liftChar toTitle y+ x == liftChar toLower y+ || x == liftChar toUpper y+ || x == liftChar toTitle y
tests/Text/Megaparsec/Char/LexerSpec.hs view
@@ -1,26 +1,26 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} module Text.Megaparsec.Char.LexerSpec (spec) where import Control.Monad+import qualified Data.CaseInsensitive as CI import Data.Char hiding (ord) import Data.List (isInfixOf) import Data.Maybe import Data.Scientific (Scientific, fromFloatDigits) import Data.Void (Void)-import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt)+import Numeric (showFFloatAlt, showHex, showInt, showIntAtBase, showOct) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec-import Text.Megaparsec.Char.Lexer-import qualified Data.CaseInsensitive as CI import qualified Text.Megaparsec.Char as C+import Text.Megaparsec.Char.Lexer #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -28,61 +28,67 @@ spec :: Spec spec = do- describe "space" $ it "consumes any sort of white space" $- property $ forAll mkWhiteSpace $ \s -> do- prs scn s `shouldParse` ()- prs' scn s `succeedsLeaving` ""+ property $+ forAll mkWhiteSpace $ \s -> do+ prs scn s `shouldParse` ()+ prs' scn s `succeedsLeaving` "" describe "symbol" $ context "when stream begins with the symbol" $ it "parses the symbol and trailing whitespace" $- property $ forAll mkSymbol $ \s -> do- let p = symbol scn y- y = takeWhile (not . isSpace) s- prs p s `shouldParse` y- prs' p s `succeedsLeaving` ""+ property $+ forAll mkSymbol $ \s -> do+ let p = symbol scn y+ y = takeWhile (not . isSpace) s+ prs p s `shouldParse` y+ prs' p s `succeedsLeaving` "" describe "symbol'" $ context "when stream begins with the symbol" $ it "parses the symbol and trailing whitespace" $- property $ forAll mkSymbol $ \s -> do- let p = symbol' scn y'- y' = toUpper <$> y- y = takeWhile (not . isSpace) s- -- Rare tricky cases we don't want to deal with.- when (CI.mk y' /= CI.mk y) discard- prs p s `shouldParse` y- prs' p s `succeedsLeaving` ""+ property $+ forAll mkSymbol $ \s -> do+ let p = symbol' scn y'+ y' = toUpper <$> y+ y = takeWhile (not . isSpace) s+ -- Rare tricky cases we don't want to deal with.+ when (CI.mk y' /= CI.mk y) discard+ prs p s `shouldParse` y+ prs' p s `succeedsLeaving` "" describe "skipLineComment" $ do context "when there is no newline at the end of line" $ it "is picked up successfully" $ do let p = skipLineComment "//" s = "// this line comment doesn't have a newline at the end "- prs p s `shouldParse` ()+ prs p s `shouldParse` () prs' p s `succeedsLeaving` "" it "inner characters are labelled properly" $ do let p = skipLineComment "//" <* empty s = "// here we go"- prs p s `shouldFailWith` err (length s) (elabel "character")+ prs p s `shouldFailWith` err (length s) (elabel "character") prs' p s `failsLeaving` "" describe "skipBlockComment" $ it "skips a simple block comment" $ do let p = skipBlockComment "/*" "*/" s = "/* here we go */foo!"- prs p s `shouldParse` ()+ prs p s `shouldParse` () prs' p s `succeedsLeaving` "foo!" describe "skipBlockCommentNested" $ context "when it runs into nested block comments" $ it "parses them all right" $ do- let p = space (void C.spaceChar) empty- (skipBlockCommentNested "/*" "*/") <* eof+ let p =+ space+ (void C.spaceChar)+ empty+ (skipBlockCommentNested "/*" "*/")+ <* eof s = " /* foo bar /* baz */ quux */ "- prs p s `shouldParse` ()+ prs p s `shouldParse` () prs' p s `succeedsLeaving` "" describe "indentLevel" $@@ -107,32 +113,35 @@ it "works as intended" $ property $ \n -> do let mki = mkIndent sbla (getSmall $ getNonNegative n)- forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do+ forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0, l1, l2) -> do let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)- fragments = [l0,l1,l2]+ fragments = [l0, l1, l2] g x = sum (length <$> take x fragments) s = concat fragments- p = ip GT pos1 >>=- \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn+ p =+ ip GT pos1+ >>= \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn ip = indentGuard scn sp = void (symbol sc sbla <* C.eol)- if | col0 <= pos1 ->- prs p s `shouldFailWith` errFancy 0 (ii GT pos1 col0)- | col1 /= col0 ->- prs p s `shouldFailWith` errFancy (getIndent l1 + g 1) (ii EQ col0 col1)- | col2 <= col0 ->- prs p s `shouldFailWith` errFancy (getIndent l2 + g 2) (ii GT col0 col2)- | otherwise ->- prs p s `shouldParse` ()+ if+ | col0 <= pos1 ->+ prs p s `shouldFailWith` errFancy 0 (ii GT pos1 col0)+ | col1 /= col0 ->+ prs p s `shouldFailWith` errFancy (getIndent l1 + g 1) (ii EQ col0 col1)+ | col2 <= col0 ->+ prs p s `shouldFailWith` errFancy (getIndent l2 + g 2) (ii GT col0 col2)+ | otherwise ->+ prs p s `shouldParse` () describe "nonIdented" $ it "works as intended" $- property $ forAll (mkIndent sbla 0) $ \s -> do- let p = nonIndented scn (symbol scn sbla)- i = getIndent s- if i == 0- then prs p s `shouldParse` sbla- else prs p s `shouldFailWith` errFancy i (ii EQ pos1 (getCol s))+ property $+ forAll (mkIndent sbla 0) $ \s -> do+ let p = nonIndented scn (symbol scn sbla)+ i = getIndent s+ if i == 0+ then prs p s `shouldParse` sbla+ else prs p s `shouldFailWith` errFancy i (ii EQ pos1 (getCol s)) describe "indentBlock" $ do it "works as indented" $@@ -143,87 +152,103 @@ l2 <- mkIndent sblc (ib + 2) l3 <- mkIndent sblb ib l4 <- mkIndent' sblc (ib + 2)- return (l0,l1,l2,l3,l4)- ib = fromMaybe 2 mn'+ return (l0, l1, l2, l3, l4)+ ib = fromMaybe 2 mn' mn' = getSmall . getPositive <$> mn''- mn = mkPos . fromIntegral <$> mn'- forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do+ mn = mkPos . fromIntegral <$> mn'+ forAll mkBlock $ \(l0, l1, l2, l3, l4) -> do let (col0, col1, col2, col3, col4) = (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)- fragments = [l0,l1,l2,l3,l4]+ fragments = [l0, l1, l2, l3, l4] g x = sum (length <$> take x fragments) s = concat fragments p = lvla <* eof- lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla+ lvla = indentBlock scn $ IndentMany mn (l sbla) lvlb <$ b sbla lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb- lvlc = indentBlock scn $ IndentNone sblc <$ b sblc- b = symbol sc- l x = return . (x,)- ib' = mkPos (fromIntegral ib)- if | col1 <= col0 -> prs p s `shouldFailWith`- err (getIndent l1 + g 1) (utok (head sblb) <> eeof)- | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`- errFancy (getIndent l1 + g 1) (ii EQ ib' col1)- | col2 <= col1 -> prs p s `shouldFailWith`- errFancy (getIndent l2 + g 2) (ii GT col1 col2)- | col3 == col2 -> prs p s `shouldFailWith`- err (getIndent l3 + g 3) (utoks sblb <> etoks sblc <> eeof)- | col3 <= col0 -> prs p s `shouldFailWith`- err (getIndent l3 + g 3) (utok (head sblb) <> eeof)- | col3 < col1 -> prs p s `shouldFailWith`- errFancy (getIndent l3 + g 3) (ii EQ col1 col3)- | col3 > col1 -> prs p s `shouldFailWith`- errFancy (getIndent l3 + g 3) (ii EQ col2 col3)- | col4 <= col3 -> prs p s `shouldFailWith`- errFancy (getIndent l4 + g 4) (ii GT col3 col4)- | otherwise -> prs p s `shouldParse`- (sbla, [(sblb, [sblc]), (sblb, [sblc])])+ lvlc = indentBlock scn $ IndentNone sblc <$ b sblc+ b = symbol sc+ l x = return . (x,)+ ib' = mkPos (fromIntegral ib)+ if+ | col1 <= col0 ->+ prs p s+ `shouldFailWith` err (getIndent l1 + g 1) (utok (head sblb) <> eeof)+ | isJust mn && col1 /= ib' ->+ prs p s+ `shouldFailWith` errFancy (getIndent l1 + g 1) (ii EQ ib' col1)+ | col2 <= col1 ->+ prs p s+ `shouldFailWith` errFancy (getIndent l2 + g 2) (ii GT col1 col2)+ | col3 == col2 ->+ prs p s+ `shouldFailWith` err (getIndent l3 + g 3) (utoks sblb <> etoks sblc <> eeof)+ | col3 <= col0 ->+ prs p s+ `shouldFailWith` err (getIndent l3 + g 3) (utok (head sblb) <> eeof)+ | col3 < col1 ->+ prs p s+ `shouldFailWith` errFancy (getIndent l3 + g 3) (ii EQ col1 col3)+ | col3 > col1 ->+ prs p s+ `shouldFailWith` errFancy (getIndent l3 + g 3) (ii EQ col2 col3)+ | col4 <= col3 ->+ prs p s+ `shouldFailWith` errFancy (getIndent l4 + g 4) (ii GT col3 col4)+ | otherwise ->+ prs p s+ `shouldParse` (sbla, [(sblb, [sblc]), (sblb, [sblc])]) it "IndentMany works as intended (newline at the end)" $- property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do- let p = lvla- lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla- lvlb = b sblb- b = symbol sc- l x = return . (x,)- prs p s `shouldParse` (sbla, [])- prs' p s `succeedsLeaving` ""+ property $+ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do+ let p = lvla+ lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+ lvlb = b sblb+ b = symbol sc+ l x = return . (x,)+ prs p s `shouldParse` (sbla, [])+ prs' p s `succeedsLeaving` "" it "IndentMany works as intended (eof)" $- property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do- let p = lvla- lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla- lvlb = b sblb- b = symbol sc- l x = return . (x,)- prs p s `shouldParse` (sbla, [])- prs' p s `succeedsLeaving` ""+ property $+ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpace) $ \s -> do+ let p = lvla+ lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+ lvlb = b sblb+ b = symbol sc+ l x = return . (x,)+ prs p s `shouldParse` (sbla, [])+ prs' p s `succeedsLeaving` "" it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do- let p = lvla+ let p = lvla lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla lvlb = b sblb- b = symbol sc- l x = return . (x,)- s = "aaa\n bbb\n "- prs p s `shouldParse` (sbla, [sblb])+ b = symbol sc+ l x = return . (x,)+ s = "aaa\n bbb\n "+ prs p s `shouldParse` (sbla, [sblb]) prs' p s `succeedsLeaving` "" it "works with many and both IndentMany and IndentNone" $- property $ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do- let p1 = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla- p2 = indentBlock scn $ IndentNone sbla <$ b sbla- lvlb = b sblb- b = symbol sc- l x = return . (x,)- prs (many p1) s `shouldParse` [(sbla, [])]- prs (many p2) s `shouldParse` [sbla]- prs' (many p1) s `succeedsLeaving` ""- prs' (many p2) s `succeedsLeaving` ""+ property $+ forAll ((<>) <$> mkIndent sbla 0 <*> mkWhiteSpaceNl) $ \s -> do+ let p1 = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+ p2 = indentBlock scn $ IndentNone sbla <$ b sbla+ lvlb = b sblb+ b = symbol sc+ l x = return . (x,)+ prs (many p1) s `shouldParse` [(sbla, [])]+ prs (many p2) s `shouldParse` [sbla]+ prs' (many p1) s `succeedsLeaving` ""+ prs' (many p2) s `succeedsLeaving` "" it "IndentSome expects the specified indentation level for first item" $ do- let s = "aaa\n bbb\n"- p = indentBlock scn $- IndentSome (Just (mkPos 5)) (l sbla) lvlb <$ symbol sc sbla+ let s = "aaa\n bbb\n"+ p =+ indentBlock scn $+ IndentSome (Just (mkPos 5)) (l sbla) lvlb <$ symbol sc sbla lvlb = symbol sc sblb l x = return . (x,)- prs p s `shouldFailWith` errFancy 6- (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3))+ prs p s+ `shouldFailWith` errFancy+ 6+ (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3)) describe "lineFold" $ it "works as intended" $@@ -232,24 +257,27 @@ l0 <- mkInterspace sbla 0 l1 <- mkInterspace sblb 1 l2 <- mkInterspace sblc 1- return (l0,l1,l2)- forAll mkFold $ \(l0,l1,l2) -> do+ return (l0, l1, l2)+ forAll mkFold $ \(l0, l1, l2) -> do let p = lineFold scn $ \sc' -> do a <- symbol sc' sbla b <- symbol sc' sblb c <- symbol scn sblc return (a, b, c) getEnd x = last x == '\n'- fragments = [l0,l1,l2]+ fragments = [l0, l1, l2] g x = sum (length <$> take x fragments) s = concat fragments (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)- (end0, end1) = (getEnd l0, getEnd l1)- if | end0 && col1 <= col0 -> prs p s `shouldFailWith`- errFancy (getIndent l1 + g 1) (ii GT col0 col1)- | end1 && col2 <= col0 -> prs p s `shouldFailWith`- errFancy (getIndent l2 + g 2) (ii GT col0 col2)- | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)+ (end0, end1) = (getEnd l0, getEnd l1)+ if+ | end0 && col1 <= col0 ->+ prs p s+ `shouldFailWith` errFancy (getIndent l1 + g 1) (ii GT col0 col1)+ | end1 && col2 <= col0 ->+ prs p s+ `shouldFailWith` errFancy (getIndent l2 + g 2) (ii GT col0 col2)+ | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc) describe "charLiteral" $ do let p = charLiteral@@ -257,13 +285,14 @@ it "parses it" $ property $ \ch -> do let s = showLitChar ch ""- prs p s `shouldParse` ch+ prs p s `shouldParse` ch prs' p s `succeedsLeaving` "" context "when stream does not begin with a literal character" $- it "signals correct parse error" $ do- let s = "\\"- prs p s `shouldFailWith` err 0 (utok '\\' <> elabel "literal character")- prs' p s `failsLeaving` s+ it "signals correct parse error" $+ do+ let s = "\\"+ prs p s `shouldFailWith` err 0 (utok '\\' <> elabel "literal character")+ prs' p s `failsLeaving` s context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> elabel "literal character")@@ -281,18 +310,19 @@ let p = decimal :: Parser Integer n = getNonNegative n' s = showInt n ""- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with decimal digits" $ it "signals correct parse error" $- property $ \a as -> not (isDigit a) ==> do- let p = decimal :: Parser Integer- s = a : as- prs p s `shouldFailWith` err 0 (utok a <> elabel "integer")+ property $ \a as ->+ not (isDigit a) ==> do+ let p = decimal :: Parser Integer+ s = a : as+ prs p s `shouldFailWith` err 0 (utok a <> elabel "integer") context "when stream is empty" $ it "signals correct parse error" $- prs (decimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "integer")+ prs (decimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "integer") describe "binary" $ do context "when stream begins with binary digits" $@@ -301,19 +331,20 @@ let p = binary :: Parser Integer n = getNonNegative n' s = showIntAtBase 2 intToDigit n ""- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with binary digits" $ it "signals correct parse error" $- property $ \a as -> a /= '0' && a /= '1' ==> do- let p = binary :: Parser Integer- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "binary integer")+ property $ \a as ->+ a /= '0' && a /= '1' ==> do+ let p = binary :: Parser Integer+ s = a : as+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "binary integer") context "when stream is empty" $ it "signals correct parse error" $- prs (binary :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "binary integer")+ prs (binary :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "binary integer") describe "octal" $ do context "when stream begins with octal digits" $@@ -322,19 +353,20 @@ let p = octal :: Parser Integer n = getNonNegative n' s = showOct n ""- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with octal digits" $ it "signals correct parse error" $- property $ \a as -> not (isOctDigit a) ==> do- let p = octal :: Parser Integer- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "octal integer")+ property $ \a as ->+ not (isOctDigit a) ==> do+ let p = octal :: Parser Integer+ s = a : as+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "octal integer") context "when stream is empty" $ it "signals correct parse error" $- prs (octal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "octal integer")+ prs (octal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "octal integer") describe "hexadecimal" $ do context "when stream begins with hexadecimal digits" $@@ -343,29 +375,33 @@ let p = hexadecimal :: Parser Integer n = getNonNegative n' s = showHex n ""- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with hexadecimal digits" $ it "signals correct parse error" $- property $ \a as -> not (isHexDigit a) ==> do- let p = hexadecimal :: Parser Integer- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "hexadecimal integer")+ property $ \a as ->+ not (isHexDigit a) ==> do+ let p = hexadecimal :: Parser Integer+ s = a : as+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "hexadecimal integer") context "when stream is empty" $ it "signals correct parse error" $- prs (hexadecimal :: Parser Integer) "" `shouldFailWith`- err 0 (ueof <> elabel "hexadecimal integer")+ prs (hexadecimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "hexadecimal integer") describe "scientific" $ do context "when stream begins with a number" $ it "parses it" $ property $ \n' -> do let p = scientific :: Parser Scientific- s = either (show . getNonNegative) (show . getNonNegative)- (n' :: Either (NonNegative Integer) (NonNegative Double))+ s =+ either+ (show . getNonNegative)+ (show . getNonNegative)+ (n' :: Either (NonNegative Integer) (NonNegative Double)) prs p s `shouldParse` case n' of- Left x -> fromIntegral (getNonNegative x)+ Left x -> fromIntegral (getNonNegative x) Right x -> fromFloatDigits (getNonNegative x) prs' p s `succeedsLeaving` "" context "when fractional part is interrupted" $@@ -373,27 +409,29 @@ property $ \(NonNegative n) -> do let p = scientific <* empty :: Parser Scientific s = showFFloatAlt Nothing (n :: Double) ""- prs p s `shouldFailWith` err (length s)- (etok 'E' <> etok 'e' <> elabel "digit")+ prs p s+ `shouldFailWith` err+ (length s)+ (etok 'E' <> etok 'e' <> elabel "digit") prs' p s `failsLeaving` "" context "when whole part is followed by a dot without valid fractional part" $ it "parsing of fractional part is backtracked correctly" $ property $ \(NonNegative n) -> do let p = scientific :: Parser Scientific s = showInt (n :: Integer) ".err"- prs p s `shouldParse` fromIntegral n+ prs p s `shouldParse` fromIntegral n prs' p s `succeedsLeaving` ".err" context "when number is followed by something starting with 'e'" $ it "parsing of exponent part is backtracked correctly" $ property $ \(NonNegative n) -> do let p = scientific :: Parser Scientific s = showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` fromFloatDigits n+ prs p s `shouldParse` fromFloatDigits n prs' p s `succeedsLeaving` "err!" context "when stream is empty" $ it "signals correct parse error" $- prs (scientific :: Parser Scientific) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")+ prs (scientific :: Parser Scientific) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") describe "float" $ do context "when stream begins with a float" $@@ -402,45 +440,49 @@ let p = float :: Parser Double n = getNonNegative n' s = show n- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when stream does not begin with a float" $ it "signals correct parse error" $- property $ \a as -> not (isDigit a) ==> do- let p = float :: Parser Double- s = a : as- prs p s `shouldFailWith`- err 0 (utok a <> elabel "digit")- prs' p s `failsLeaving` s+ property $ \a as ->+ not (isDigit a) ==> do+ let p = float :: Parser Double+ s = a : as+ prs p s+ `shouldFailWith` err 0 (utok a <> elabel "digit")+ prs' p s `failsLeaving` s context "when stream begins with an integer (decimal)" $ it "signals correct parse error" $ property $ \n' -> do let p = float :: Parser Double n = getNonNegative n' s = show (n :: Integer)- prs p s `shouldFailWith` err (length s)- (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")+ prs p s+ `shouldFailWith` err+ (length s)+ (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit") prs' p s `failsLeaving` "" context "when number is followed by something starting with 'e'" $ it "parsing of exponent part is backtracked correctly" $ property $ \(NonNegative n) -> do let p = float :: Parser Double s = showFFloatAlt Nothing (n :: Double) "err!"- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "err!" context "when stream is empty" $ it "signals correct parse error" $- prs (float :: Parser Double) "" `shouldFailWith`- err 0 (ueof <> elabel "digit")+ prs (float :: Parser Double) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") context "when there is float with just exponent" $- it "parses it all right" $ do- let p = float :: Parser Double- prs p "123e3" `shouldParse` 123e3- prs' p "123e3" `succeedsLeaving` ""- prs p "123e+3" `shouldParse` 123e+3- prs' p "123e+3" `succeedsLeaving` ""- prs p "123e-3" `shouldParse` 123e-3- prs' p "123e-3" `succeedsLeaving` ""+ it "parses it all right" $+ do+ let p = float :: Parser Double+ prs p "123e3" `shouldParse` 123e3+ prs' p "123e3" `succeedsLeaving` ""+ prs p "123e+3" `shouldParse` 123e+3+ prs' p "123e+3" `succeedsLeaving` ""+ prs p "123e-3" `shouldParse` 123e-3+ prs' p "123e-3" `succeedsLeaving` "" describe "signed" $ do context "with integer" $@@ -449,7 +491,7 @@ let p :: Parser Integer p = signed (hidden C.space) decimal s = show n- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "with float" $ it "parses signed floats" $@@ -457,7 +499,7 @@ let p :: Parser Double p = signed (hidden C.space) float s = show n- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "with scientific" $ it "parses singed scientific numbers" $@@ -465,7 +507,7 @@ let p = signed (hidden C.space) scientific s = either show show (n :: Either Integer Double) prs p s `shouldParse` case n of- Left x -> fromIntegral x+ Left x -> fromIntegral x Right x -> fromFloatDigits x context "when number is prefixed with plus sign" $ it "parses the number" $@@ -474,7 +516,7 @@ p = signed (hidden C.space) decimal n = getNonNegative n' s = '+' : show n- prs p s `shouldParse` n+ prs p s `shouldParse` n prs' p s `succeedsLeaving` "" context "when number is prefixed with white space" $ it "signals correct parse error" $@@ -482,15 +524,17 @@ let p :: Parser Integer p = signed (hidden C.space) decimal s = ' ' : show (n :: Integer)- prs p s `shouldFailWith` err 0- (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")+ prs p s+ `shouldFailWith` err+ 0+ (utok ' ' <> etok '+' <> etok '-' <> elabel "integer") prs' p s `failsLeaving` s context "when there is white space between sign and digits" $ it "parses it all right" $ do let p :: Parser Integer p = signed (hidden C.space) decimal s = "- 123"- prs p s `shouldParse` (-123)+ prs p s `shouldParse` (-123) prs' p s `succeedsLeaving` "" ----------------------------------------------------------------------------@@ -558,8 +602,10 @@ getIndent = length . takeWhile isSpace getCol :: String -> Pos-getCol x = sourceColumn .- strSourcePos defaultTabWidth (initialPos "") $ takeWhile isSpace x+getCol x =+ sourceColumn+ . strSourcePos defaultTabWidth (initialPos "")+ $ takeWhile isSpace x sbla, sblb, sblc :: String sbla = "aaa"
tests/Text/Megaparsec/CharSpec.hs view
@@ -1,29 +1,28 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Text.Megaparsec.CharSpec (spec) where import Control.Monad+import qualified Data.CaseInsensitive as CI import Data.Char-import Data.List (nub, partition, isPrefixOf)+import Data.List (isPrefixOf, nub, partition) import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec import Text.Megaparsec.Char-import qualified Data.CaseInsensitive as CI #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>)) #endif instance Arbitrary GeneralCategory where- arbitrary = elements [minBound..maxBound]+ arbitrary = elements [minBound .. maxBound] spec :: Spec spec = do- describe "newline" $ checkStrLit "newline" "\n" (pure <$> newline) @@ -35,33 +34,41 @@ it "succeeds returning the newline" $ property $ \s -> do let s' = '\n' : s- prs eol s' `shouldParse` "\n"+ prs eol s' `shouldParse` "\n" prs' eol s' `succeedsLeaving` s context "when stream begins with CRLF sequence" $ it "parses the CRLF sequence" $ property $ \s -> do let s' = '\r' : '\n' : s- prs eol s' `shouldParse` "\r\n"+ prs eol s' `shouldParse` "\r\n" prs' eol s' `succeedsLeaving` s context "when stream begins with '\\r', but it's not followed by '\\n'" $ it "signals correct parse error" $- property $ \ch -> ch /= '\n' ==> do- let s = ['\r',ch]- prs eol s `shouldFailWith` err 0 (utoks s <> elabel "end of line")+ property $ \ch ->+ ch /= '\n' ==> do+ let s = ['\r', ch]+ prs eol s `shouldFailWith` err 0 (utoks s <> elabel "end of line") context "when input stream is '\\r'" $ it "signals correct parse error" $- prs eol "\r" `shouldFailWith` err 0- (utok '\r' <> elabel "end of line")+ prs eol "\r"+ `shouldFailWith` err+ 0+ (utok '\r' <> elabel "end of line") context "when stream does not begin with newline or CRLF sequence" $ it "signals correct parse error" $- property $ \ch s -> (ch `notElem` "\r\n") ==> do- let s' = ch : s- prs eol s' `shouldFailWith` err 0- (utoks (take 2 s') <> elabel "end of line")+ property $ \ch s ->+ (ch `notElem` "\r\n") ==> do+ let s' = ch : s+ prs eol s'+ `shouldFailWith` err+ 0+ (utoks (take 2 s') <> elabel "end of line") context "when stream is empty" $ it "signals correct parse error" $- prs eol "" `shouldFailWith` err 0- (ueof <> elabel "end of line")+ prs eol ""+ `shouldFailWith` err+ 0+ (ueof <> elabel "end of line") describe "tab" $ checkStrLit "tab" "\t" (pure <$> tab)@@ -69,30 +76,59 @@ describe "space" $ it "consumes space up to first non-space character" $ property $ \s' -> do- let (s0,s1) = partition isSpace s'+ let (s0, s1) = partition isSpace s' s = s0 ++ s1- prs space s `shouldParse` ()+ prs space s `shouldParse` () prs' space s `succeedsLeaving` s1 + describe "hspace" $+ it "consumes space up to first non-space character" $+ property $ \s' -> do+ let (s0, s1) = partition isHSpace s'+ s = s0 ++ s1+ prs hspace s `shouldParse` ()+ prs' hspace s `succeedsLeaving` s1+ describe "space1" $ do context "when stream does not start with a space character" $ it "signals correct parse error" $- property $ \ch s' -> not (isSpace ch) ==> do- let (s0,s1) = partition isSpace s'- s = ch : s0 ++ s1- prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")- prs' space1 s `failsLeaving` s+ property $ \ch s' ->+ not (isSpace ch) ==> do+ let (s0, s1) = partition isSpace s'+ s = ch : s0 ++ s1+ prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")+ prs' space1 s `failsLeaving` s context "when stream starts with a space character" $ it "consumes space up to first non-space character" $ property $ \s' -> do- let (s0,s1) = partition isSpace s'+ let (s0, s1) = partition isSpace s' s = ' ' : s0 ++ s1- prs space1 s `shouldParse` ()+ prs space1 s `shouldParse` () prs' space1 s `succeedsLeaving` s1 context "when stream is empty" $ it "signals correct parse error" $ prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space") + describe "hspace1" $ do+ context "when stream does not start with a space character" $+ it "signals correct parse error" $+ property $ \ch s' ->+ not (isHSpace ch) ==> do+ let (s0, s1) = partition isHSpace s'+ s = ch : s0 ++ s1+ prs hspace1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")+ prs' hspace1 s `failsLeaving` s+ context "when stream starts with a space character" $+ it "consumes space up to first non-space character" $+ property $ \s' -> do+ let (s0, s1) = partition isHSpace s'+ s = ' ' : s0 ++ s1+ prs hspace1 s `shouldParse` ()+ prs' hspace1 s `succeedsLeaving` s1+ context "when stream is empty" $+ it "signals correct parse error" $+ prs hspace1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")+ describe "controlChar" $ checkCharPred "control character" isControl controlChar @@ -108,30 +144,27 @@ describe "letterChar" $ checkCharPred "letter" isAlpha letterChar - describe "alphaNumChar" $- checkCharPred "alphanumeric character" isAlphaNum alphaNumChar- describe "printChar" $ checkCharPred "printable character" isPrint printChar describe "digitChar" $- checkCharRange "digit" ['0'..'9'] digitChar+ checkCharRange "digit" ['0' .. '9'] digitChar describe "binDigitChar" $- checkCharRange "binary digit" ['0'..'1'] binDigitChar+ checkCharRange "binary digit" ['0' .. '1'] binDigitChar describe "octDigitChar" $- checkCharRange "octal digit" ['0'..'7'] octDigitChar+ checkCharRange "octal digit" ['0' .. '7'] octDigitChar describe "hexDigitChar" $- checkCharRange "hexadecimal digit" (['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']) hexDigitChar+ checkCharRange "hexadecimal digit" (['0' .. '9'] ++ ['a' .. 'f'] ++ ['A' .. 'F']) hexDigitChar describe "markChar" $ checkCharRange "mark character" "\71229\7398" markChar describe "numberChar" $- let xs = "\185\178\179\188\189\190" ++ ['0'..'9']- in checkCharRange "numeric character" xs numberChar+ let xs = "\185\178\179\188\189\190" ++ ['0' .. '9']+ in checkCharRange "numeric character" xs numberChar describe "punctuationChar" $ checkCharPred "punctuation" isPunctuation punctuationChar@@ -147,15 +180,17 @@ describe "latin1Char" $ do context "when stream begins with Latin-1 character" $ it "parses the Latin-1 character" $- property $ \ch s -> isLatin1 ch ==> do- let s' = ch : s- prs latin1Char s' `shouldParse` ch- prs' latin1Char s' `succeedsLeaving` s+ property $ \ch s ->+ isLatin1 ch ==> do+ let s' = ch : s+ prs latin1Char s' `shouldParse` ch+ prs' latin1Char s' `succeedsLeaving` s context "when stream does not begin with Latin-1 character" $- it "signals correct parse error" $ do- prs latin1Char "б" `shouldFailWith`- err 0 (utok 'б' <> elabel "Latin-1 character")- prs' latin1Char "в" `failsLeaving` "в"+ it "signals correct parse error" $+ do+ prs latin1Char "б"+ `shouldFailWith` err 0 (utok 'б' <> elabel "Latin-1 character")+ prs' latin1Char "в" `failsLeaving` "в" context "when stream is empty" $ it "signals correct parse error" $ prs latin1Char "" `shouldFailWith` err 0 (ueof <> elabel "Latin-1 character")@@ -165,39 +200,41 @@ it "succeeds" $ property $ \ch s -> do let s' = ch : s- g = generalCategory ch- prs (charCategory g) s' `shouldParse` ch+ g = generalCategory ch+ prs (charCategory g) s' `shouldParse` ch prs' (charCategory g) s' `succeedsLeaving` s context "when parser's category does not match next character's category" $ it "fails" $- property $ \g ch s -> (generalCategory ch /= g) ==> do- let s' = ch : s- prs (charCategory g) s' `shouldFailWith`- err 0 (utok ch <> elabel (categoryName g))- prs' (charCategory g) s' `failsLeaving` s'+ property $ \g ch s ->+ (generalCategory ch /= g) ==> do+ let s' = ch : s+ prs (charCategory g) s'+ `shouldFailWith` err 0 (utok ch <> elabel (categoryName g))+ prs' (charCategory g) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \g ->- prs (charCategory g) "" `shouldFailWith`- err 0 (ueof <> elabel (categoryName g))+ prs (charCategory g) ""+ `shouldFailWith` err 0 (ueof <> elabel (categoryName g)) describe "char" $ do context "when stream begins with the character specified as argument" $ it "parses the character" $ property $ \ch s -> do let s' = ch : s- prs (char ch) s' `shouldParse` ch+ prs (char ch) s' `shouldParse` ch prs' (char ch) s' `succeedsLeaving` s context "when stream does not begin with the character specified as argument" $ it "signals correct parse error" $- property $ \ch ch' s -> ch /= ch' ==> do- let s' = ch' : s- prs (char ch) s' `shouldFailWith` err 0 (utok ch' <> etok ch)- prs' (char ch) s' `failsLeaving` s'+ property $ \ch ch' s ->+ ch /= ch' ==> do+ let s' = ch' : s+ prs (char ch) s' `shouldFailWith` err 0 (utok ch' <> etok ch)+ prs' (char ch) s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ property $ \ch ->- prs (char ch) "" `shouldFailWith` err 0 (ueof <> etok ch)+ prs (char ch) "" `shouldFailWith` err 0 (ueof <> etok ch) describe "char'" $ do context "when stream begins with the character specified as argument" $ do@@ -206,9 +243,9 @@ let sl = toLower ch : s su = toUpper ch : s st = toTitle ch : s- prs (char' ch) sl `shouldParse` toLower ch- prs (char' ch) su `shouldParse` toUpper ch- prs (char' ch) st `shouldParse` toTitle ch+ prs (char' ch) sl `shouldParse` toLower ch+ prs (char' ch) su `shouldParse` toUpper ch+ prs (char' ch) st `shouldParse` toTitle ch prs' (char' ch) sl `succeedsLeaving` s prs' (char' ch) su `succeedsLeaving` s context "when the character is not upper or lower" $@@ -221,36 +258,39 @@ prs' (char' ch) s' `succeedsLeaving` s context "when stream does not begin with the character specified as argument" $ do it "signals correct parse error" $- property $ \ch ch' s -> not (casei ch ch') ==> do- let s' = ch' : s- ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) <> etok (toTitle ch)- prs (char' ch) s' `shouldFailWith` err 0 ms- prs' (char' ch) s' `failsLeaving` s'+ property $ \ch ch' s ->+ not (casei ch ch') ==> do+ let s' = ch' : s+ ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) <> etok (toTitle ch)+ prs (char' ch) s' `shouldFailWith` err 0 ms+ prs' (char' ch) s' `failsLeaving` s' context "when the character is not upper or lower" $ it "lists correct options in the error message" $- property $ \ch s -> not (casei '\9438' ch) ==> do- let ms = utok ch <> etok '\9438' <> etok '\9412'- s' = ch : s- prs (char' '\9438') s' `shouldFailWith` err 0 ms+ property $ \ch s ->+ not (casei '\9438' ch) ==> do+ let ms = utok ch <> etok '\9438' <> etok '\9412'+ s' = ch : s+ prs (char' '\9438') s' `shouldFailWith` err 0 ms context "when stream is empty" $ it "signals correct parse error" $ property $ \ch -> do let options = etok <$> [toLower ch, toTitle ch, toUpper ch] ms = ueof <> mconcat (nub options)- prs (char' ch) "" `shouldFailWith` err 0 ms+ prs (char' ch) "" `shouldFailWith` err 0 ms describe "string" $ do context "when stream is prefixed with given string" $ it "parses the string" $ property $ \str s -> do let s' = str ++ s- prs (string str) s' `shouldParse` str+ prs (string str) s' `shouldParse` str prs' (string str) 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 us = take (length str) s- prs (string str) s `shouldFailWith` err 0 (utoks us <> etoks str)+ property $ \str s ->+ not (str `isPrefixOf` s) ==> do+ let us = take (length str) s+ prs (string str) s `shouldFailWith` err 0 (utoks us <> etoks str) describe "string'" $ do context "when stream is prefixed with given string" $@@ -260,13 +300,14 @@ let s' = str' ++ s -- Rare tricky cases we don't want to deal with. when (CI.mk str /= CI.mk str') discard- prs (string' str) s' `shouldParse` str'+ prs (string' str) s' `shouldParse` str' prs' (string' str) s' `succeedsLeaving` s context "when stream is not prefixed with given string" $ it "signals correct parse error" $- property $ \str s -> not (str `isPrefixOfI` s) ==> do- let us = take (length str) s- prs (string' str) s `shouldFailWith` err 0 (utoks us <> etoks str)+ property $ \str s ->+ not (str `isPrefixOfI` s) ==> do+ let us = take (length str) s+ prs (string' str) s `shouldFailWith` err 0 (utoks us <> etoks str) ---------------------------------------------------------------------------- -- Helpers@@ -277,15 +318,16 @@ it ("parses the " ++ name) $ property $ \s -> do let s' = ts ++ s- prs p s' `shouldParse` ts+ prs p s' `shouldParse` ts prs' p s' `succeedsLeaving` s context ("when stream does not begin with " ++ name) $ it "signals correct parse error" $- property $ \ch s -> ch /= head ts ==> do- let s' = ch : s- us = take (length ts) s'- prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)- prs' p s' `failsLeaving` s'+ property $ \ch s ->+ ch /= head ts ==> do+ let s' = ch : s+ us = take (length ts) s'+ prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)+ prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)@@ -294,16 +336,18 @@ checkCharPred name f p = do context ("when stream begins with " ++ name) $ it ("parses the " ++ name) $- property $ \ch s -> f ch ==> do- let s' = ch : s- prs p s' `shouldParse` ch- prs' p s' `succeedsLeaving` s+ property $ \ch s ->+ f ch ==> do+ let s' = ch : s+ prs p s' `shouldParse` ch+ prs' p s' `succeedsLeaving` s context ("when stream does not begin with " ++ name) $ it "signals correct parse error" $- property $ \ch s -> not (f ch) ==> do- let s' = ch : s- prs p s' `shouldFailWith` err 0 (utok ch <> elabel name)- prs' p s' `failsLeaving` s'+ property $ \ch s ->+ not (f ch) ==> do+ let s' = ch : s+ prs p s' `shouldFailWith` err 0 (utok ch <> elabel name)+ prs' p s' `failsLeaving` s' context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> elabel name)@@ -315,33 +359,34 @@ it ("parses the " ++ showTokens sproxy (nes tch)) $ property $ \s -> do let s' = tch : s- prs p s' `shouldParse` tch+ prs p s' `shouldParse` tch prs' p s' `succeedsLeaving` s context "when stream is empty" $ it "signals correct parse error" $ prs p "" `shouldFailWith` err 0 (ueof <> elabel name) -- | Randomly change the case in the given string.- fuzzyCase :: String -> Gen String fuzzyCase s = zipWith f s <$> vector (length s) where- f k True = if isLower k then toUpper k else toLower k+ f k True = if isLower k then toUpper k else toLower k f k False = k -- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff -- the first list is a prefix of the second with case-insensitive -- comparison.- isPrefixOfI :: String -> String -> Bool-isPrefixOfI [] _ = True-isPrefixOfI _ [] = False-isPrefixOfI (x:xs) (y:ys) = x `casei` y && isPrefixOf xs ys+isPrefixOfI [] _ = True+isPrefixOfI _ [] = False+isPrefixOfI (x : xs) (y : ys) = x `casei` y && isPrefixOf xs ys -- | Case-insensitive equality test for characters.- casei :: Char -> Char -> Bool casei x y =- x == toLower y ||- x == toUpper y ||- x == toTitle y+ x == toLower y+ || x == toUpper y+ || x == toTitle y++-- | Is it a horizontal space character?+isHSpace :: Char -> Bool+isHSpace x = isSpace x && x /= '\n' && x /= '\r'
tests/Text/Megaparsec/DebugSpec.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Text.Megaparsec.DebugSpec- ( spec )-where+module Text.Megaparsec.DebugSpec (spec) where import Control.Monad import Test.Hspec@@ -19,7 +17,6 @@ spec :: Spec spec = do- describe "dbg" $ do -- NOTE We don't test properties here to avoid flood of debugging output -- when the test runs.@@ -27,33 +24,33 @@ 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 `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 1 (etok 'a')+ prs p s `shouldFailWith` err 1 (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 1 (utok 'b' <> etok 'c')+ prs p s `shouldFailWith` err 1 (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 `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 0 (etok 'a')+ prs p s `shouldFailWith` err 0 (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 0 mempty+ prs p s `shouldFailWith` err 0 mempty prs' p s `failsLeaving` s
tests/Text/Megaparsec/ErrorSpec.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.ErrorSpec (spec) where import Control.Exception (Exception (..)) import Data.Functor.Identity-import Data.List (isSuffixOf, isInfixOf, sort)+import Data.List (isInfixOf, isSuffixOf, sort) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Set as E import Data.Void import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc () import Test.QuickCheck import Text.Megaparsec-import qualified Data.Set as E #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -21,7 +21,6 @@ spec :: Spec spec = do- describe "Semigroup instance of ParseError" $ it "associativity" $ property $ \x y z ->@@ -43,28 +42,29 @@ property $ \x y -> errorOffset (x <> y :: PE) === max (errorOffset x) (errorOffset y) context "when combining two trivial parse errors at the same position" $- it "merges their unexpected and expected items" $ do- let n Nothing Nothing = Nothing- n (Just x) Nothing = Just x- n Nothing (Just y) = Just y- n (Just x) (Just y) = Just (max x y)- property $ \pos us0 ps0 us1 ps1 ->- TrivialError pos us0 ps0 <> TrivialError pos us1 ps1 `shouldBe`- (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE)+ it "merges their unexpected and expected items" $+ do+ let n Nothing Nothing = Nothing+ n (Just x) Nothing = Just x+ n Nothing (Just y) = Just y+ n (Just x) (Just y) = Just (max x y)+ property $ \pos us0 ps0 us1 ps1 ->+ TrivialError pos us0 ps0 <> TrivialError pos us1 ps1+ `shouldBe` (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE) context "when combining two fancy parse errors at the same position" $ it "merges their custom items" $ property $ \pos xs0 xs1 ->- FancyError pos xs0 <> FancyError pos xs1 `shouldBe`- (FancyError pos (E.union xs0 xs1) :: PE)+ FancyError pos xs0 <> FancyError pos xs1+ `shouldBe` (FancyError pos (E.union xs0 xs1) :: PE) context "when combining trivial error with fancy error" $ do it "fancy has precedence (left)" $ property $ \pos us ps xs ->- FancyError pos xs <> TrivialError pos us ps `shouldBe`- (FancyError pos xs :: PE)+ FancyError pos xs <> TrivialError pos us ps+ `shouldBe` (FancyError pos xs :: PE) it "fancy has precedence (right)" $ property $ \pos us ps xs ->- TrivialError pos us ps <> FancyError pos xs `shouldBe`- (FancyError pos xs :: PE)+ TrivialError pos us ps <> FancyError pos xs+ `shouldBe` (FancyError pos xs :: PE) -- NOTE 'errorOffset' and 'setErrorOffset' are trivial. @@ -84,119 +84,137 @@ describe "errorBundlePretty" $ do it "shows empty line correctly" $ do let s = "" :: String- mkBundlePE s (mempty :: PE) `shouldBe`- "1:1:\n |\n1 | <empty line>\n | ^\nunknown parse error\n"+ mkBundlePE s (mempty :: PE)+ `shouldBe` "1:1:\n |\n1 | <empty line>\n | ^\nunknown parse error\n" it "shows position on first line correctly" $ do let s = "abc" :: String pe = err 1 (utok 'b' <> etok 'd') :: PE- mkBundlePE s pe `shouldBe`- "1:2:\n |\n1 | abc\n | ^\nunexpected 'b'\nexpecting 'd'\n"+ mkBundlePE s pe+ `shouldBe` "1:2:\n |\n1 | abc\n | ^\nunexpected 'b'\nexpecting 'd'\n" it "skips to second line correctly" $ do let s = "one\ntwo\n" :: String pe = err 4 (utok 't' <> etok 'x') :: PE- mkBundlePE s pe `shouldBe`- "2:1:\n |\n2 | two\n | ^\nunexpected 't'\nexpecting 'x'\n"+ mkBundlePE s pe+ `shouldBe` "2:1:\n |\n2 | two\n | ^\nunexpected 't'\nexpecting 'x'\n" it "shows position on 1000 line correctly" $ do let s = replicate 999 '\n' ++ "abc" pe = err 999 (utok 'a' <> etok 'd') :: PE- mkBundlePE s pe `shouldBe`- "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n"+ mkBundlePE s pe+ `shouldBe` "1000:1:\n |\n1000 | abc\n | ^\nunexpected 'a'\nexpecting 'd'\n" it "shows offending line in the presence of tabs correctly" $ do let s = "\tsomething" :: String pe = err 1 (utok 's' <> etok 'x') :: PE- mkBundlePE s pe `shouldBe`- "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n"+ mkBundlePE s pe+ `shouldBe` "1:9:\n |\n1 | something\n | ^\nunexpected 's'\nexpecting 'x'\n" it "uses continuous highlighting properly (trivial)" $ do let s = "\tfoobar" :: String pe = err 1 (utoks "foo" <> utoks "rar") :: PE- mkBundlePE s pe `shouldBe`- "1:9:\n |\n1 | foobar\n | ^^^\nunexpected \"rar\"\n"+ mkBundlePE s pe+ `shouldBe` "1:9:\n |\n1 | foobar\n | ^^^\nunexpected \"rar\"\n" it "uses continuous highlighting properly (fancy)" $ do let s = "\tfoobar" :: String- pe = errFancy 1- (fancy $ ErrorCustom (CustomErr 5)) :: ParseError String CustomErr- mkBundlePE s pe `shouldBe`- "1:9:\n |\n1 | foobar\n | ^^^^^\ncustom thing\n"+ pe =+ errFancy+ 1+ (fancy $ ErrorCustom (CustomErr 5)) ::+ ParseError String CustomErr+ mkBundlePE s pe+ `shouldBe` "1:9:\n |\n1 | foobar\n | ^^^^^\ncustom thing\n" it "adjusts continuous highlighting so it doesn't get too long" $ do let s = "foobar\n" :: String pe = err 4 (utoks "foobar" <> etoks "foobar") :: PE- mkBundlePE s pe `shouldBe`- "1:5:\n |\n1 | foobar\n | ^^^\nunexpected \"foobar\"\nexpecting \"foobar\"\n"+ mkBundlePE s pe+ `shouldBe` "1:5:\n |\n1 | foobar\n | ^^^\nunexpected \"foobar\"\nexpecting \"foobar\"\n" context "stream of insufficient size is provided in the bundle" $- it "handles the situation reasonably" $ do- let s = "" :: String- pe = err 3 (ueof <> etok 'x') :: PE- mkBundlePE s pe `shouldBe`- "1:1:\n |\n1 | <empty line>\n | ^\nunexpected end of input\nexpecting 'x'\n"+ it "handles the situation reasonably" $+ do+ let s = "" :: String+ pe = err 3 (ueof <> etok 'x') :: PE+ mkBundlePE s pe+ `shouldBe` "1:1:\n |\n1 | <empty line>\n | ^\nunexpected end of input\nexpecting 'x'\n" context "starting column in bundle is greater than 1" $ do context "and less than parse error column" $- it "is rendered correctly" $ do- let s = "foo" :: String- pe = err 5 (utok 'o' <> etok 'x') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 4- , pstateSourcePos = SourcePos "" pos1 (mkPos 5)- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }- errorBundlePretty bundle `shouldBe`- "1:6:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n"+ it "is rendered correctly" $+ do+ let s = "foo" :: String+ pe = err 5 (utok 'o' <> etok 'x') :: PE+ bundle =+ ParseErrorBundle+ { bundleErrors = pe :| [],+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 4,+ pstateSourcePos = SourcePos "" pos1 (mkPos 5),+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ }+ }+ errorBundlePretty bundle+ `shouldBe` "1:6:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n" context "and greater than parse error column" $- it "is rendered correctly" $ do- let s = "foo" :: String- pe = err 5 (utok 'o' <> etok 'x') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 9- , pstateSourcePos = SourcePos "" pos1 (mkPos 10)- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }- errorBundlePretty bundle `shouldBe`- "1:10:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n"+ it "is rendered correctly" $+ do+ let s = "foo" :: String+ pe = err 5 (utok 'o' <> etok 'x') :: PE+ bundle =+ ParseErrorBundle+ { bundleErrors = pe :| [],+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 9,+ pstateSourcePos = SourcePos "" pos1 (mkPos 10),+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ }+ }+ errorBundlePretty bundle+ `shouldBe` "1:10:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n" it "takes tab width into account correctly" $ property $ \w' -> do- let s = "\tsomething\t" :: String+ let s = "\tsomething\t" :: String pe = err 1 (utok 's' <> etok 'x') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = w'- , pstateLinePrefix = ""+ bundle =+ ParseErrorBundle+ { bundleErrors = pe :| [],+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos "",+ pstateTabWidth = w',+ pstateLinePrefix = ""+ } }- }- w = unPos w'+ w = unPos w' tabRep = replicate w ' '- errorBundlePretty bundle `shouldBe`- ("1:" ++ show (w + 1) ++ ":\n |\n1 | " ++ tabRep ++- "something" ++ tabRep ++- "\n | " ++ tabRep ++ "^\nunexpected 's'\nexpecting 'x'\n")+ errorBundlePretty bundle+ `shouldBe` ( "1:" ++ show (w + 1) ++ ":\n |\n1 | " ++ tabRep+ ++ "something"+ ++ tabRep+ ++ "\n | "+ ++ tabRep+ ++ "^\nunexpected 's'\nexpecting 'x'\n"+ ) it "displays multi-error bundle correctly" $ do let s = "something\ngood\n" :: String pe0 = err 2 (utok 'm' <> etok 'x') :: PE pe1 = err 10 (utok 'g' <> etok 'y') :: PE- bundle = ParseErrorBundle- { bundleErrors = pe0 :| [pe1]- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""+ bundle =+ ParseErrorBundle+ { bundleErrors = pe0 :| [pe1],+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ } }- }- errorBundlePretty bundle `shouldBe`- "1:3:\n |\n1 | something\n | ^\nunexpected 'm'\nexpecting 'x'\n\n2:1:\n |\n2 | good\n | ^\nunexpected 'g'\nexpecting 'y'\n"+ errorBundlePretty bundle+ `shouldBe` "1:3:\n |\n1 | something\n | ^\nunexpected 'm'\nexpecting 'x'\n\n2:1:\n |\n2 | good\n | ^\nunexpected 'g'\nexpecting 'y'\n" describe "parseErrorPretty" $ do it "shows unknown ParseError correctly" $@@ -214,8 +232,9 @@ parseErrorPretty e `shouldBe` "offset=0:\nOoops!\n" it "several fancy errors look not so bad" $ do let pe :: PE- pe = errFancy 0 $- mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")+ pe =+ errFancy 0 $+ mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar") parseErrorPretty pe `shouldBe` "offset=0:\nbar\nfoo\n" describe "parseErrorTextPretty" $ do@@ -240,7 +259,6 @@ -- | Custom error component to test continuous highlighting for custom -- components.- newtype CustomErr = CustomErr Int deriving (Eq, Ord, Show) @@ -256,18 +274,24 @@ rendered = parseErrorPretty e f x = r x `isInfixOf` rendered -mkBundlePE- :: (Stream s, ShowErrorComponent e)- => s- -> ParseError s e- -> String-mkBundlePE s e = errorBundlePretty $ ParseErrorBundle- { bundleErrors = e :| []- , bundlePosState = PosState- { pstateInput = s- , pstateOffset = 0- , pstateSourcePos = initialPos ""- , pstateTabWidth = defaultTabWidth- , pstateLinePrefix = ""- }- }+mkBundlePE ::+ ( VisualStream s,+ TraversableStream s,+ ShowErrorComponent e+ ) =>+ s ->+ ParseError s e ->+ String+mkBundlePE s e =+ errorBundlePretty $+ ParseErrorBundle+ { bundleErrors = e :| [],+ bundlePosState =+ PosState+ { pstateInput = s,+ pstateOffset = 0,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ }+ }
tests/Text/Megaparsec/PosSpec.hs view
@@ -16,12 +16,12 @@ spec :: Spec spec = do- describe "mkPos" $ do context "when the argument is a non-positive number" $ it "throws InvalidPosException" $- property $ \n -> n <= 0 ==>- evaluate (mkPos n) `shouldThrow` (== InvalidPosException n)+ property $ \n ->+ n <= 0+ ==> evaluate (mkPos n) `shouldThrow` (== InvalidPosException n) context "when the argument is not 0" $ it "returns Pos with the given value" $ property $ \n ->@@ -40,16 +40,16 @@ describe "Semigroup instance of Pos" $ it "works like addition" $ property $ \x y ->- x <> y === mkPos (unPos x + unPos y) .&&.- unPos (x <> y) === unPos x + unPos y+ x <> y === mkPos (unPos x + unPos y)+ .&&. unPos (x <> y) === unPos x + unPos y describe "initialPos" $ it "constructs initial position correctly" $ property $ \path -> let x = initialPos path- in sourceName x === path .&&.- sourceLine x === mkPos 1 .&&.- sourceColumn x === mkPos 1+ in sourceName x === path+ .&&. sourceLine x === mkPos 1+ .&&. sourceColumn x === mkPos 1 describe "Read and Show instances of SourcePos" $ it "printed representation of SourcePos in isomorphic to its value" $
tests/Text/Megaparsec/StreamSpec.hs view
@@ -1,26 +1,26 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Text.Megaparsec.StreamSpec (spec) where import Control.Monad-import Data.Char (isLetter, chr, isControl, isSpace)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Char (chr, isControl, isLetter, isSpace) import Data.List (foldl') import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.String (IsString)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Data.Word (Word8) import Test.Hspec import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ((<>))@@ -28,7 +28,6 @@ spec :: Spec spec = do- describe "String instance of Stream" $ do describe "tokenToChunk" $ it "produces the same result as singleton with tokensToChunk" $@@ -56,8 +55,9 @@ take1_ ("" :: String) === Nothing context "when input is not empty" $ it "unconses a token" $- property $ \s -> not (null s) ==>- take1_ (s :: String) === Just (head s, tail s)+ property $ \s ->+ not (null s)+ ==> take1_ (s :: String) === Just (head s, tail s) describe "takeN_" $ do context "requested length is 0" $ it "returns Just empty chunk and original stream" $@@ -70,8 +70,9 @@ takeN_ n ("" :: String) === Nothing context "stream is not empty" $ it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (null s) ==>- takeN_ n (s :: String) === Just (splitAt n s)+ property $ \(Positive n) s ->+ not (null s)+ ==> takeN_ n (s :: String) === Just (splitAt n s) describe "takeWhile_" $ it "extracts a chunk that is a prefix consisting of matching tokens" $ property $ \s ->@@ -107,8 +108,9 @@ take1_ ("" :: B.ByteString) === Nothing context "when input is not empty" $ it "unconses a token" $- property $ \s -> not (B.null s) ==>- take1_ (s :: B.ByteString) === B.uncons s+ property $ \s ->+ not (B.null s)+ ==> take1_ (s :: B.ByteString) === B.uncons s describe "takeN_" $ do context "requested length is 0" $ it "returns Just empty chunk and original stream" $@@ -121,13 +123,14 @@ takeN_ n ("" :: B.ByteString) === Nothing context "stream is not empty" $ it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (B.null s) ==>- takeN_ n (s :: B.ByteString) === Just (B.splitAt n s)+ property $ \(Positive n) s ->+ not (B.null s)+ ==> takeN_ n (s :: B.ByteString) === Just (B.splitAt n s) describe "takeWhile_" $ it "extracts a chunk that is a prefix consisting of matching tokens" $ property $ \s -> let f = isLetter . chr . fromIntegral- in takeWhile_ f s === B.span f s+ in takeWhile_ f s === B.span f s describeShowTokens bproxy quotedWordGen describeReachOffset bproxy describeReachOffsetNoLine bproxy@@ -159,8 +162,9 @@ take1_ ("" :: BL.ByteString) === Nothing context "when input is not empty" $ it "unconses a token" $- property $ \s -> not (BL.null s) ==>- take1_ (s :: BL.ByteString) === BL.uncons s+ property $ \s ->+ not (BL.null s)+ ==> take1_ (s :: BL.ByteString) === BL.uncons s describe "takeN_" $ do context "requested length is 0" $ it "returns Just empty chunk and original stream" $@@ -173,13 +177,14 @@ takeN_ n ("" :: BL.ByteString) === Nothing context "stream is not empty" $ it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (BL.null s) ==>- takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s)+ property $ \(Positive n) s ->+ not (BL.null s)+ ==> takeN_ n (s :: BL.ByteString) === Just (BL.splitAt (fromIntegral n) s) describe "takeWhile_" $ it "extracts a chunk that is a prefix consisting of matching tokens" $ property $ \s -> let f = isLetter . chr . fromIntegral- in takeWhile_ f s === BL.span f s+ in takeWhile_ f s === BL.span f s describeShowTokens blproxy quotedWordGen describeReachOffset blproxy describeReachOffsetNoLine blproxy@@ -211,8 +216,9 @@ take1_ ("" :: T.Text) === Nothing context "when input is not empty" $ it "unconses a token" $- property $ \s -> not (T.null s) ==>- take1_ (s :: T.Text) === T.uncons s+ property $ \s ->+ not (T.null s)+ ==> take1_ (s :: T.Text) === T.uncons s describe "takeN_" $ do context "requested length is 0" $ it "returns Just empty chunk and original stream" $@@ -225,8 +231,9 @@ takeN_ n ("" :: T.Text) === Nothing context "stream is not empty" $ it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (T.null s) ==>- takeN_ n (s :: T.Text) === Just (T.splitAt n s)+ property $ \(Positive n) s ->+ not (T.null s)+ ==> takeN_ n (s :: T.Text) === Just (T.splitAt n s) describe "takeWhile_" $ it "extracts a chunk that is a prefix consisting of matching tokens" $ property $ \s ->@@ -262,8 +269,9 @@ take1_ ("" :: TL.Text) === Nothing context "when input is not empty" $ it "unconses a token" $- property $ \s -> not (TL.null s) ==>- take1_ (s :: TL.Text) === TL.uncons s+ property $ \s ->+ not (TL.null s)+ ==> take1_ (s :: TL.Text) === TL.uncons s describe "takeN_" $ do context "requested length is 0" $ it "returns Just empty chunk and original stream" $@@ -276,8 +284,9 @@ takeN_ n ("" :: TL.Text) === Nothing context "stream is not empty" $ it "returns a chunk of correct length and rest of the stream" $- property $ \(Positive n) s -> not (TL.null s) ==>- takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s)+ property $ \(Positive n) s ->+ not (TL.null s)+ ==> takeN_ n (s :: TL.Text) === Just (TL.splitAt (fromIntegral n) s) describe "takeWhile_" $ it "extracts a chunk that is a prefix consisting of matching tokens" $ property $ \s ->@@ -290,132 +299,175 @@ -- Helpers -- | Generic block of tests for the 'showTokens' method.--describeShowTokens- :: forall s. ( Stream s- , IsString (Tokens s)- , Show (Token s)- , Arbitrary (Token s)- )- => Proxy s -- ^ 'Proxy' that clarifies the type of stream- -> Gen (Token s) -- ^ Generator of tokens that should be simply quoted- -> Spec+describeShowTokens ::+ forall s.+ ( VisualStream s,+ IsString (Tokens s),+ Show (Token s),+ Arbitrary (Token s)+ ) =>+ -- | 'Proxy' that clarifies the type of stream+ Proxy s ->+ -- | Generator of tokens that should be simply quoted+ Gen (Token s) ->+ Spec describeShowTokens pxy quotedTokGen = describe "showTokens" $ do let f :: Tokens s -> String -> Expectation f x y = showTokens pxy (NE.fromList $ chunkToTokens pxy x) `shouldBe` y- it "shows CRLF newline correctly"+ it+ "shows CRLF newline correctly" (f "\r\n" "crlf newline")- it "shows null byte correctly"+ it+ "shows null byte correctly" (f "\NUL" "null")- it "shows start of heading correctly"+ it+ "shows start of heading correctly" (f "\SOH" "start of heading")- it "shows start of text correctly"+ it+ "shows start of text correctly" (f "\STX" "start of text")- it "shows end of text correctly"+ it+ "shows end of text correctly" (f "\ETX" "end of text")- it "shows end of transmission correctly"+ it+ "shows end of transmission correctly" (f "\EOT" "end of transmission")- it "shows enquiry correctly"+ it+ "shows enquiry correctly" (f "\ENQ" "enquiry")- it "shows acknowledge correctly"+ it+ "shows acknowledge correctly" (f "\ACK" "acknowledge")- it "shows bell correctly"+ it+ "shows bell correctly" (f "\BEL" "bell")- it "shows backspace correctly"+ it+ "shows backspace correctly" (f "\BS" "backspace")- it "shows tab correctly"+ it+ "shows tab correctly" (f "\t" "tab")- it "shows newline correctly"+ it+ "shows newline correctly" (f "\n" "newline")- it "shows vertical tab correctly"+ it+ "shows vertical tab correctly" (f "\v" "vertical tab")- it "shows form feed correctly"+ it+ "shows form feed correctly" (f "\f" "form feed")- it "shows carriage return correctly"+ it+ "shows carriage return correctly" (f "\r" "carriage return")- it "shows shift out correctly"+ it+ "shows shift out correctly" (f "\SO" "shift out")- it "shows shift in correctly"+ it+ "shows shift in correctly" (f "\SI" "shift in")- it "shows data link escape correctly"+ it+ "shows data link escape correctly" (f "\DLE" "data link escape")- it "shows device control one correctly"+ it+ "shows device control one correctly" (f "\DC1" "device control one")- it "shows device control two correctly"+ it+ "shows device control two correctly" (f "\DC2" "device control two")- it "shows device control three correctly"+ it+ "shows device control three correctly" (f "\DC3" "device control three")- it "shows device control four correctly"+ it+ "shows device control four correctly" (f "\DC4" "device control four")- it "shows negative acknowledge correctly"+ it+ "shows negative acknowledge correctly" (f "\NAK" "negative acknowledge")- it "shows synchronous idle correctly"+ it+ "shows synchronous idle correctly" (f "\SYN" "synchronous idle")- it "shows end of transmission block correctly"+ it+ "shows end of transmission block correctly" (f "\ETB" "end of transmission block")- it "shows cancel correctly"+ it+ "shows cancel correctly" (f "\CAN" "cancel")- it "shows end of medium correctly"- (f "\EM" "end of medium")- it "shows substitute correctly"+ it+ "shows end of medium correctly"+ (f "\EM" "end of medium")+ it+ "shows substitute correctly" (f "\SUB" "substitute")- it "shows escape correctly"+ it+ "shows escape correctly" (f "\ESC" "escape")- it "shows file separator correctly"- (f "\FS" "file separator")- it "shows group separator correctly"- (f "\GS" "group separator")- it "shows record separator correctly"- (f "\RS" "record separator")- it "shows unit separator correctly"- (f "\US" "unit separator")- it "shows delete correctly"+ it+ "shows file separator correctly"+ (f "\FS" "file separator")+ it+ "shows group separator correctly"+ (f "\GS" "group separator")+ it+ "shows record separator correctly"+ (f "\RS" "record separator")+ it+ "shows unit separator correctly"+ (f "\US" "unit separator")+ it+ "shows delete correctly" (f "\DEL" "delete")- it "shows space correctly"- (f " " "space")- it "shows non-breaking space correctly"+ it+ "shows space correctly"+ (f " " "space")+ it+ "shows non-breaking space correctly" (f "\160" "non-breaking space") it "shows other single characters in single quotes" $- property $ forAll quotedTokGen $ \x -> do- let r = showTokens pxy (x :| [])- head r `shouldBe` '\''- last r `shouldBe` '\''+ property $+ forAll quotedTokGen $ \x -> do+ let r = showTokens pxy (x :| [])+ head r `shouldBe` '\''+ last r `shouldBe` '\'' it "shows strings in double quotes" $ property $ \x (NonEmpty xs) -> do let r = showTokens pxy (x :| xs) when (r == "crlf newline") discard head r `shouldBe` '\"' last r `shouldBe` '\"'- it "shows control characters in long strings property"+ it+ "shows control characters in long strings property" (f "{\n" "\"{<newline>\"") -- | Generic block of tests for the 'reachOffset' method.--describeReachOffset- :: forall s. ( Stream s- , IsString s- , Show s- , Arbitrary s- )- => Proxy s -- ^ 'Proxy' that clarifies the type of stream- -> Spec+describeReachOffset ::+ forall s.+ ( TraversableStream s,+ IsString s,+ Show s,+ Arbitrary s+ ) =>+ -- | 'Proxy' that clarifies the type of stream+ Proxy s ->+ Spec describeReachOffset Proxy = describe "reachOffset" $ do it "returns correct SourcePos (newline)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\n" :: s- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\n" :: s+ } o = pstateOffset pst + 1 r = pstateSourcePos . snd $ reachOffset o pst SourcePos n l _ = pstateSourcePos pst r `shouldBe` SourcePos n (l <> pos1) pos1 it "returns correct SourcePos (tab)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\t" :: s- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\t" :: s+ } o = pstateOffset pst + 1 r = pstateSourcePos . snd $ reachOffset o pst SourcePos n l c = pstateSourcePos pst@@ -423,86 +475,94 @@ r `shouldBe` SourcePos n l (toNextTab w c) it "returns correct SourcePos (other)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "a" :: s- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "a" :: s+ } o = pstateOffset pst + 1 r = pstateSourcePos . snd $ reachOffset o pst SourcePos n l c = pstateSourcePos pst r `shouldBe` SourcePos n l (c <> pos1) it "replaces empty line with <empty line>" $ property $ \o pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "" :: s- , pstateLinePrefix = ""- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "" :: s,+ pstateLinePrefix = ""+ } (r, _) = reachOffset o pst- r `shouldBe` "<empty line>"+ r `shouldBe` Just "<empty line>" it "replaces tabs with spaces in returned line" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\ta\t" :: s- , pstateLinePrefix = "\t"- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\ta\t" :: s,+ pstateLinePrefix = "\t"+ } (r, _) = reachOffset 2 pst w = unPos (pstateTabWidth pst) r' = replicate (w * 2) ' ' ++ "a" ++ replicate w ' '- r `shouldBe` r'+ r `shouldBe` Just r' it "returns correct line (with line prefix)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "foo\nbar\nbaz" :: s- , pstateLinePrefix = "123"- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "foo\nbar\nbaz" :: s,+ pstateLinePrefix = "123"+ } (r, _) = reachOffset 0 pst- r `shouldBe` "123foo"+ r `shouldBe` Just "123foo" it "returns correct line (without line prefix)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "foo\nbar\nbaz" :: s- , pstateOffset = 0- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "foo\nbar\nbaz" :: s,+ pstateOffset = 0+ } (r, _) = reachOffset 4 pst- r `shouldBe` "bar"+ r `shouldBe` Just "bar" it "works incrementally" $ property $ \os' (NonNegative d) s -> do let os = getNonNegative <$> os' s' :: PosState String s' = foldl' f s os o' = case os of- [] -> d- xs -> maximum xs + d+ [] -> d+ xs -> maximum xs + d f pst o = let (_, pst') = reachOffset o pst- in pst'+ in pst' reachOffset o' s `shouldBe` reachOffset o' s' -- | Generic block of tests for the 'reachOffsetNoLine' method.--describeReachOffsetNoLine- :: forall s. ( Stream s- , IsString s- , Show s- , Arbitrary s- )- => Proxy s -- ^ 'Proxy' that clarifies the type of stream- -> Spec+describeReachOffsetNoLine ::+ forall s.+ ( TraversableStream s,+ IsString s,+ Show s,+ Arbitrary s+ ) =>+ -- | 'Proxy' that clarifies the type of stream+ Proxy s ->+ Spec describeReachOffsetNoLine Proxy = describe "reachOffsetNoLine" $ do it "returns correct SourcePos (newline)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\n" :: s- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\n" :: s+ } o = pstateOffset pst + 1 r = pstateSourcePos (reachOffsetNoLine o pst) SourcePos n l _ = pstateSourcePos pst r `shouldBe` SourcePos n (l <> pos1) pos1 it "returns correct SourcePos (tab)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "\t" :: s- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\t" :: s+ } o = pstateOffset pst + 1 r = pstateSourcePos (reachOffsetNoLine o pst) SourcePos n l c = pstateSourcePos pst@@ -510,9 +570,10 @@ r `shouldBe` SourcePos n l (toNextTab w c) it "returns correct SourcePos (other)" $ property $ \pst' -> do- let pst = (pst' :: PosState s)- { pstateInput = "a" :: s- }+ let pst =+ (pst' :: PosState s)+ { pstateInput = "a" :: s+ } o = pstateOffset pst + 1 r = pstateSourcePos (reachOffsetNoLine o pst) SourcePos n l c = pstateSourcePos pst@@ -523,19 +584,21 @@ s' :: PosState String s' = foldl' f s os o' = case os of- [] -> d- xs -> maximum xs + d+ [] -> d+ xs -> maximum xs + d f pst o = let pst' = reachOffsetNoLine o pst- in pst'+ in pst' reachOffsetNoLine o' s `shouldBe` reachOffsetNoLine o' s' -- | Get next tab position given tab width and current column.--toNextTab- :: Pos -- ^ Tab width- -> Pos -- ^ Current column- -> Pos -- ^ Column of next tab position+toNextTab ::+ -- | Tab width+ Pos ->+ -- | Current column+ Pos ->+ -- | Column of next tab position+ Pos toNextTab w' c' = mkPos $ c + w - ((c - 1) `rem` w) where w = unPos w'@@ -549,6 +612,5 @@ -- | Return 'True' if the 'Char' should be simply quoted by the 'showTokens' -- method, i.e. it's not a character with a special representation.- isQuotedChar :: Char -> Bool isQuotedChar x = not (isControl x) && not (isSpace x)
tests/Text/MegaparsecSpec.hs view
@@ -1,1699 +1,1779 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS -fno-warn-orphans #-}--module Text.MegaparsecSpec (spec) where--import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (toUpper, isLetter)-import Data.Foldable (asum)-import Data.List (isPrefixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup-import Data.String-import Data.Void-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-import Text.Megaparsec.Char-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 as BS-import qualified Data.List as DL-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as E-import qualified Data.Text as T--spec :: Spec-spec = do-- describe "ParsecT Semigroup instance" $- it "the associative operation works" $- property $ \a b -> do- let p = pure [a] <> pure [b]- prs p "" `shouldParse` ([a,b] :: [Int])-- describe "ParsecT Monoid instance" $ do- it "mempty works" $ do- let p = mempty- prs p "" `shouldParse` ([] :: [Int])- it "mappend works" $- property $ \a b -> do- let p = pure [a] `mappend` pure [b]- prs p "" `shouldParse` ([a,b] :: [Int])-- describe "ParsecT IsString instance" $ do- describe "equivalence to 'string'" $ do- it "for String" $ property $ \s i ->- eqParser- (chunk s)- (fromString s)- (i :: String)- it "for Text" $ property $ \s i ->- eqParser- (chunk (T.pack s))- (fromString s)- (i :: T.Text)- it "for ByteString" $ property $ \s i ->- eqParser- (chunk (fromString s :: BS.ByteString))- (fromString s)- (i :: BS.ByteString)- it "can handle Unicode" $ do- let- r = "פּאַרסער 解析器" :: BS.ByteString- p :: Parsec Void BS.ByteString BS.ByteString- p = BS.concat <$> sequence ["פּאַ", "רסער", " 解析器"]- parse p "" r `shouldParse` r-- 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 2 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 = chunk s0 <|> chunk 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- z = take (max (length s0) (length s1)) s- prs p s `shouldFailWith` err 0- (etoks s0 <>- etoks s1 <>- (if null s then ueof else utoks z))- 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 1 (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 0 (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 0 (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 0- (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 (ParseErrorBundle String Void) ())- v = runParserT p "" ("" :: String)- 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 0 (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 0 (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 Void String ()- prs p "" `shouldFailWith` errFancy 0 (fancy $ ErrorFail 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` errFancy 0 (fancy $ ErrorFail msg)- prs' p s `failsLeaving` s-- describe "ParsecT MonadIO instance" $- it "liftIO works" $- property $ \n -> do- let p = liftIO (return n) :: ParsecT Void String IO Integer- runParserT p "" "" `shouldReturn` Right n-- describe "ParsecT MonadFix instance" $- it "withRange works" $ do- let- withRange- :: (MonadParsec e s m, MonadFix m)- => ((SourcePos,SourcePos) -> m a)- -> m a- withRange f = do- p1 <- getSourcePos- rec- r <- f (p1, p2)- p2 <- getSourcePos- return r- p :: Parsec Void String (SourcePos,SourcePos)- p = withRange $ \pp -> pp <$ string "ab"- runParser p "" "abcd"- `shouldBe` Right- ( SourcePos "" (mkPos 1) (mkPos 1)- , SourcePos "" (mkPos 1) (mkPos 3)- )-- describe "ParsecT MonadReader instance" $ do-- describe "ask" $- it "returns correct value of context" $- property $ \n -> do- let p = ask :: ParsecT Void 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 Void 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 Void 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 Void 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 Void String (Cont (Either (ParseErrorBundle String Void) 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 Void 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 Void 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 "parseError" $ do- it "immediately fails with given parse error" $- property $ \st e -> do- let p :: MonadParsec Void String m => m ()- p = parseError e- runParser' p st `shouldBe` (st, Left (mkBundle st (nes e)))-- 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 Void String m => m Char- p = label lbl (char a) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 mempty)- grs' p s (`failsLeaving` "")- context "inner parser produces hints" $- it "does not alter the hints" $- property $ \lbl a -> not (null lbl) ==> do- let p :: MonadParsec Void String m => m String- p = label lbl (many (char a)) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 (etok a))- 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 Void String m => m Char- p = label lbl (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (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 Void String m => m Char- p = label lbl (return a) <* empty- grs p "" (`shouldFailWith` err 0 mempty)- context "inner parser produces hints" $- it "replaces the last hint with given label" $- property $ \lbl a -> not (null lbl) ==> do- let p :: MonadParsec Void String m => m String- p = label lbl (many (char a)) <* empty- grs p "" (`shouldFailWith` err 0 (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 Void String m => m ()- p = label lbl empty- grs p "" (`shouldFailWith` err 0 (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 Void String m => m Char- p = hidden (char a) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 mempty)- grs' p s (`failsLeaving` "")- context "inner parser produces hints" $- it "hides the parser in the error message" $- property $ \a -> do- let p :: MonadParsec Void String m => m String- p = hidden (many (char a)) <* empty- s = [a]- grs p s (`shouldFailWith` err 1 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 Void String m => m Char- p = hidden (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (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 Void String m => m Char- p = hidden (return a) <* empty- grs p "" (`shouldFailWith` err 0 mempty)- context "inner parser produces hints" $- it "hides the parser in the error message" $- property $ \a -> do- let p :: MonadParsec Void String m => m String- p = hidden (many (char a)) <* empty- grs p "" (`shouldFailWith` err 0 mempty)- context "when inner parser fails without consuming" $- it "hides the parser in the error message" $ do- let p :: MonadParsec Void String m => m ()- p = hidden empty- grs p "" (`shouldFailWith` err 0 mempty)-- describe "try" $ do- context "when inner parser succeeds consuming" $- it "try has no effect" $- property $ \a -> do- let p :: MonadParsec Void 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" $ do- it "backtracks, it appears as if the parser has not consumed anything" $- property $ \a b c -> b /= c ==> do- let p :: MonadParsec Void String m => m Char- p = try (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (utok c <> etok b))- grs' p s (`failsLeaving` s)- it "hints from the inner parse error do not leak" $- property $ \a b c -> b /= c ==> do- let p :: MonadParsec Void String m => m (Maybe Char)- p = (optional . try) (char a *> char b) <* empty- s = [a,c]- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when inner parser succeeds without consuming" $- it "try has no effect" $- property $ \a -> do- let p :: MonadParsec Void 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 Void String m => m Char- p = try (setTabWidth w *> empty)- grs p "" (`shouldFailWith` err 0 mempty)- grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)-- 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 Void 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 Void String m => m String- p = lookAhead (many (char a)) <* empty- s = [a]- grs p s (`shouldFailWith` err 0 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 Void String m => m Char- p = lookAhead (char a *> char b)- s = [a,c]- grs p s (`shouldFailWith` err 1 (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 Void 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 Void String m => m String- p = lookAhead (many (char a)) <* empty- s = [b]- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- context "when inner parser fails without consuming" $- it "error message is reported as usual" $ do- let p :: MonadParsec Void String m => m Char- p = lookAhead empty- grs p "" (`shouldFailWith` err 0 mempty)-- describe "notFollowedBy" $ do- context "when inner parser succeeds consuming" $- it "signals correct parse error" $- property $ \a w -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w <* char a)- s = [a]- grs p s (`shouldFailWith` err 0 (utok a))- grs' p s (`failsLeaving` s)- grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)- context "when inner parser fails consuming" $ do- it "succeeds without consuming" $- property $ \a b c w -> b /= c ==> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w *> char a *> char b)- s = [a,c]- grs' p s (`succeedsLeaving` s)- grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)- it "hints are not preserved" $- property $ \a b -> a /= b ==> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (char b *> many (char a) <* char a) <* empty- s = [b,b]- grs p s (`shouldFailWith` err 0 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 Void String m => m ()- p = notFollowedBy (setTabWidth w *> return a)- s = [a]- grs p s (`shouldFailWith` err 0 (utok a))- grs' p s (`failsLeaving` s)- grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)- context "when inner parser fails without consuming" $ do- it "succeeds without consuming" $- property $ \w -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (setTabWidth w *> empty)- grs p "" (`shouldParse` ())- grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)- it "hints are not preserved" $- property $ \a -> do- let p :: MonadParsec Void String m => m ()- p = notFollowedBy (many (char a) <* char a) <* empty- s = ""- grs p s (`shouldFailWith` err 0 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 Void 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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ string (c : as))- (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))- grs' p s (`succeedsLeaving` "")- it "hints are not preserved" $- property $ \a b c as -> b /= c ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) 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 (length 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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ char c <* empty)- (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldFailWith` err 1 (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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (return . Left) (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldParse` Left (err 1 (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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (return . Left)- (Right <$> char a <* many (char b) <* char b) <* empty- s = a : c : as- grs p s (`shouldFailWith` err 1 (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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ empty)- (Right <$> char a <* char b)- s = a : c : as- grs p s (`shouldFailWith` err 1 (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 Void 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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ string s) empty- s = a : as- grs p s (`shouldParse` Left (err 0 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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ char a <* char b <* empty)- (Right <$> empty)- s = a : as- grs p s (`shouldFailWith` err 0 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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (return . Left) empty- grs p s (`shouldParse` Left (err 0 mempty))- grs' p s (`succeedsLeaving` s)- it "original hints are preserved" $- property $ \a b as -> a /= b ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) String)- p = withRecovery (return . Left)- (Right <$> many (char a) <* empty) <* empty- s = b : as- grs p s (`shouldFailWith` err 0 (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 Void String m => m (Either (ParseError String Void) Char)- p = withRecovery (\e -> Left e <$ empty) empty- grs p s (`shouldFailWith` err 0 mempty)- grs' p s (`failsLeaving` s)- it "works in complex situations too" $- property $ \a' b' c' -> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) 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 0 (ueof <> etok 'a'))- | a == 0 && b == 0 && c > 3 = f (err 0 (utok 'c' <> etok 'a'))- | a == 0 && b == 0 = f (err 0 (utok 'c' <> etok 'a'))- | a == 0 && b > 3 = f (err 3 (utok 'b' <> etok 'c'))- | a == 0 && c == 0 = f (err b (ueof <> etok 'c'))- | a == 0 && c > 3 = f (err (b + 3) (utok 'c' <> eeof))- | a == 0 = z (Left (err 0 (utok 'b' <> etok 'a')))- | a > 3 = f (err 3 (utok 'a' <> etok 'c'))- | b == 0 && c == 0 = f (err a (ueof <> etok 'c' <> ma))- | b == 0 && c > 3 = f (err (a + 3) (utok 'c' <> eeof))- | b == 0 = z (Right s)- | otherwise = f (err a (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 Void String m => m (Either (ParseError String Void) 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 Void String m => m (Either (ParseError String Void) Char)- p = observing (char a *> char b)- s = a : c : as- grs p s (`shouldParse` Left (err 1 (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 Void String m => m (Either (ParseError String Void) Char)- p = observing (char a *> char b) *> empty- s = a : c : as- grs p s (`shouldFailWith` err 1 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 Void String m => m (Either (ParseError String Void) 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 Void String m => m (Either (ParseError String Void) ())- p = observing empty- grs p s (`shouldParse` Left (err 0 mempty))- grs' p s (`succeedsLeaving` s)- it "creates correct hints" $- property $ \a b as -> a /= b ==> do- let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)- p = observing (char a) <* empty- s = b : as- grs p s (`shouldFailWith` err 0 (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 0 (utok a <> eeof))- grs' eof s (`failsLeaving` s)-- describe "token" $ do- let expected = E.singleton . Tokens . nes- testChar a x = if a == x then Just x else Nothing- context "when supplied predicate is satisfied" $- it "succeeds" $- property $ \a as -> do- let p :: MonadParsec Void String m => m Char- p = token (testChar a) (expected a)- 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 -> a /= b ==> do- let p :: MonadParsec Void String m => m Char- p = token (testChar b) (expected b)- s = a : as- us = pure (Tokens $ nes a)- ps = E.singleton (Tokens $ nes b)- grs p s (`shouldFailWith` TrivialError 0 us ps)- grs' p s (`failsLeaving` s)- context "when stream is empty" $- it "signals correct parse error" $- property $ \a -> do- let p :: MonadParsec Void String m => m Char- p = token (testChar a) ps- us = pure EndOfInput- ps = expected a- grs p "" (`shouldFailWith` TrivialError 0 us ps)-- describe "tokens" $ do- context "when stream is prefixed with given string" $- it "parses the string" $- property $ \str s -> do- let p :: MonadParsec Void 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 Void String m => m String- p = tokens (==) str- z = take (length str) s- grs p s (`shouldFailWith` err 0 (utoks z <> etoks str))- grs' p s (`failsLeaving` s)- context "when matching the empty string" $- it "eok continuation is used" $- property $ \str s -> do- let p :: MonadParsec Void String m => m String- p = (tokens (==) "" <* empty) <|> pure str- grs p s (`shouldParse` str)- grs' p s (`succeedsLeaving` s)-- describe "takeWhileP" $ do- context "when stream is not empty" $- it "consumes all matching tokens, zero or more" $- property $ \s -> not (null s) ==> do- let p :: MonadParsec Void String m => m String- p = takeWhileP Nothing isLetter- (z,zs) = DL.span isLetter s- grs p s (`shouldParse` z)- grs' p s (`succeedsLeaving` zs)- context "when stream is empty" $- it "succeeds returning empty chunk" $ do- let p :: MonadParsec Void String m => m String- p = takeWhileP Nothing isLetter- grs p "" (`shouldParse` "")- grs' p "" (`succeedsLeaving` "")- context "with two takeWhileP in a row (testing hints)" $ do- let p :: MonadParsec Void String m => m String- p = do- void $ takeWhileP (Just "foo") (== 'a')- void $ takeWhileP (Just "bar") (== 'b')- empty- context "when the second one does not consume" $- it "hints are combined properly" $ do- let s = "aaa"- pe = err 3 (elabel "foo" <> elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "when the second one consumes" $- it "only hints of the second one affect parse error" $ do- let s = "aaabbb"- pe = err 6 (elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "without label (testing hints)" $- it "there are no hints" $ do- let p :: MonadParsec Void String m => m String- p = takeWhileP Nothing (== 'a') <* empty- s = "aaa"- grs p s (`shouldFailWith` err 3 mempty)- grs' p s (`failsLeaving` "")-- describe "takeWhile1P" $ do- context "when stream is prefixed with matching tokens" $- it "consumes the tokens" $- property $ \s' -> do- let p :: MonadParsec Void String m => m String- p = takeWhile1P Nothing isLetter- s = 'a' : s'- (z,zs) = DL.span isLetter s- grs p s (`shouldParse` z)- grs' p s (`succeedsLeaving` zs)- context "when stream is not prefixed with at least one matching token" $- it "signals correct parse error" $- property $ \s' -> do- let p :: MonadParsec Void String m => m String- p = takeWhile1P (Just "foo") isLetter- s = '3' : s'- pe = err 0 (utok '3' <> elabel "foo")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` s)- context "when stream is empty" $ do- context "with label" $- it "signals correct parse error" $ do- let p :: MonadParsec Void String m => m String- p = takeWhile1P (Just "foo") isLetter- pe = err 0 (ueof <> elabel "foo")- grs p "" (`shouldFailWith` pe)- grs' p "" (`failsLeaving` "")- context "without label" $- it "signals correct parse error" $ do- let p :: MonadParsec Void String m => m String- p = takeWhile1P Nothing isLetter- pe = err 0 ueof- grs p "" (`shouldFailWith` pe)- grs' p "" (`failsLeaving` "")- context "with two takeWhile1P in a row (testing hints)" $ do- let p :: MonadParsec Void String m => m String- p = do- void $ takeWhile1P (Just "foo") (== 'a')- void $ takeWhile1P (Just "bar") (== 'b')- empty- context "when the second one does not consume" $- it "hints are combined properly" $ do- let s = "aaa"- pe = err 3 (ueof <> elabel "foo" <> elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "when the second one consumes" $- it "only hints of the second one affect parse error" $ do- let s = "aaabbb"- pe = err 6 (elabel "bar")- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` "")- context "without label (testing hints)" $- it "there are no hints" $ do- let p :: MonadParsec Void String m => m String- p = takeWhile1P Nothing (== 'a') <* empty- s = "aaa"- grs p s (`shouldFailWith` err 3 mempty)- grs' p s (`failsLeaving` "")-- describe "takeP" $ do- context "when taking 0 tokens" $ do- context "when stream is empty" $- it "succeeds returning zero-length chunk" $ do- let p :: MonadParsec Void String m => m String- p = takeP Nothing 0- grs p "" (`shouldParse` "")- context "when stream is not empty" $- it "succeeds returning zero-length chunk" $- property $ \s -> not (null s) ==> do- let p :: MonadParsec Void String m => m String- p = takeP Nothing 0- grs p s (`shouldParse` "")- grs' p s (`succeedsLeaving` s)- context "when taking >0 tokens" $ do- context "when stream is empty" $ do- context "with label" $- it "signals correct parse error" $- property $ \(Positive n) -> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n- pe = err 0 (ueof <> elabel "foo")- grs p "" (`shouldFailWith` pe)- grs' p "" (`failsLeaving` "")- context "without label" $- it "signals correct parse error" $- property $ \(Positive n) -> do- let p :: MonadParsec Void String m => m String- p = takeP Nothing n- pe = err 0 ueof- grs p "" (`shouldFailWith` pe)- context "when stream has not enough tokens" $- it "signals correct parse error" $- property $ \(Positive n) s -> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n- m = length s- pe = err m (ueof <> elabel "foo")- unless (length s < n && not (null s)) discard- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` s)- context "when stream has enough tokens" $- it "succeeds returning the extracted tokens" $- property $ \(Positive n) s -> length s >= n ==> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n- (s0,s1) = splitAt n s- grs p s (`shouldParse` s0)- grs' p s (`succeedsLeaving` s1)- context "when failing right after takeP (testing hints)" $- it "there are no hints to influence the parse error" $- property $ \(Positive n) s -> length s >= n ==> do- let p :: MonadParsec Void String m => m String- p = takeP (Just "foo") n <* empty- pe = err n mempty- grs p s (`shouldFailWith` pe)- grs' p s (`failsLeaving` drop n s)-- describe "signaling parse errors" $ do-- describe "failure" $- it "signals correct parse error" $- property $ \us ps -> do- let p :: MonadParsec Void String m => m ()- p = void (failure us ps)- grs p "" (`shouldFailWith` TrivialError 0 us ps)-- describe "fancyFailure" $- it "singals correct parse error" $- property $ \xs -> do- let p :: MonadParsec Void String m => m ()- p = void (fancyFailure xs)- grs p "" (`shouldFailWith` FancyError 0 xs)-- describe "unexpected" $- it "signals correct parse error" $- property $ \item -> do- let p :: MonadParsec Void String m => m ()- p = void (unexpected item)- grs p "" (`shouldFailWith` TrivialError 0 (pure item) E.empty)-- describe "customFailure" $- it "signals correct parse error" $- property $ \n st -> do- let p :: MonadParsec Int String m => m ()- p = void (customFailure n)- xs = E.singleton (ErrorCustom n)- runParser p "" (stateInput st) `shouldFailWith` FancyError 0 xs- runParser' p st `failsLeaving` stateInput st-- describe "region" $ do- let f o' = \case- TrivialError o us ps ->- FancyError- (max o o')- (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)- FancyError o xs ->- FancyError- (max o o')- (E.singleton . ErrorCustom $ E.size xs)- context "when inner parser succeeds" $ do- it "delayed parse errors get updated correctly" $- property $ \st es0 es1 es2 o' n -> do- let p :: Parsec Int String Int- p = do- forM_ (NE.reverse es0) registerParseError- region (f o') $- forM_ (NE.reverse es1) registerParseError- forM_ (NE.reverse es2) registerParseError- return n- es = es2 <> fmap (f o') es1 <> es0- st' = st- { stateParseErrors = NE.toList es- }- runParser' p st `shouldBe`- ( st'- , Left (mkBundle st es)- )- context "when inner parser fails" $ do- it "delayed and normal parse errors get updated correctly" $- property $ \st es0 es1 e o' -> do- let p :: Parsec Int String ()- p = do- forM_ (NE.reverse es0) registerParseError- region (f o') $ do- forM_ (NE.reverse es1) registerParseError- void (parseError e)- es = fmap (f o') es1 <> es0- st' = st- { stateParseErrors = NE.toList es- }- runParser' p st `shouldBe`- ( st'- , Left (mkBundle st (nes (f o' e) <> es))- )-- describe "registerParseError" $ do- it "immediately fails with given parse error" $- property $ \st es -> do- let p :: MonadParsec Void String m => m ()- p = forM_ (NE.reverse es) registerParseError- st' = st- { stateParseErrors = NE.toList es- }- runParser' p st `shouldBe`- ( st'- , Left (mkBundle st es)- )-- describe "registerFailure" $- it "signals correct parse error" $- property $ \us ps -> do- let p :: MonadParsec Void String m => m ()- p = void (registerFailure us ps)- grs p "" (`shouldFailWith` TrivialError 0 us ps)-- describe "reisterFancyFailure" $- it "singals correct parse error" $- property $ \xs -> do- let p :: MonadParsec Void String m => m ()- p = void (registerFancyFailure xs)- grs p "" (`shouldFailWith` FancyError 0 xs)-- describe "derivatives from primitive combinators" $ do-- -- NOTE 'single' is tested via 'char' in "Text.Megaparsec.Char" and- -- "Text.Megaparsec.Byte".-- describe "anySingle" $ do- let p :: MonadParsec Void String m => m Char- p = anySingle- context "when stream is not empty" $- it "succeeds consuming next character in the stream" $- property $ \ch s -> do- let s' = ch : s- grs p s' (`shouldParse` ch)- grs' p s' (`succeedsLeaving` s)- context "when stream is empty" $- it "signals correct parse error" $- grs p "" (`shouldFailWith` err 0 ueof)-- describe "anySingleBut" $ do- context "when stream begins with the character specified as argument" $- it "signals correct parse error" $- property $ \ch s' -> do- let p :: MonadParsec Void String m => m Char- p = anySingleBut ch- s = ch : s'- grs p s (`shouldFailWith` err 0 (utok ch))- grs' p s (`failsLeaving` s)- context "when stream does not begin with the character specified as argument" $- it "parses first character in the stream" $- property $ \ch s -> not (null s) && ch /= head s ==> do- let p :: MonadParsec Void String m => m Char- p = anySingleBut ch- grs p s (`shouldParse` head s)- grs' p s (`succeedsLeaving` tail s)- context "when stream is empty" $- it "signals correct parse error" $- grs (anySingleBut 'a') "" (`shouldFailWith` err 0 ueof)-- describe "oneOf" $ do- context "when stream begins with one of specified characters" $- it "parses the character" $- property $ \chs' n s -> do- let chs = getNonEmpty chs'- ch = chs !! (getNonNegative n `rem` length chs)- s' = ch : s- grs (oneOf chs) s' (`shouldParse` ch)- grs' (oneOf chs) s' (`succeedsLeaving` s)- context "when stream does not begin with any of specified characters" $- it "signals correct parse error" $- property $ \chs ch s -> ch `notElem` (chs :: String) ==> do- let s' = ch : s- grs (oneOf chs) s' (`shouldFailWith` err 0 (utok ch))- grs' (oneOf chs) s' (`failsLeaving` s')- context "when stream is empty" $- it "signals correct parse error" $- property $ \chs ->- grs (oneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)-- describe "noneOf" $ do- context "when stream does not begin with any of specified characters" $- it "parses the character" $- property $ \chs ch s -> ch `notElem` (chs :: String) ==> do- let s' = ch : s- grs (noneOf chs) s' (`shouldParse` ch)- grs' (noneOf chs) s' (`succeedsLeaving` s)- context "when stream begins with one of specified characters" $- it "signals correct parse error" $- property $ \chs' n s -> do- let chs = getNonEmpty chs'- ch = chs !! (getNonNegative n `rem` length chs)- s' = ch : s- grs (noneOf chs) s' (`shouldFailWith` err 0 (utok ch))- grs' (noneOf chs) s' (`failsLeaving` s')- context "when stream is empty" $- it "signals correct parse error" $- property $ \chs ->- grs (noneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)-- -- NOTE 'chunk' is tested via 'string' in "Text.Megaparsec.Char" and- -- "Text.Megaparsec.Byte".-- describe "match" $- it "return consumed tokens along with the result" $- property $ \str -> do- let p = match (string str)- prs p str `shouldParse` (str,str)- prs' p str `succeedsLeaving` ""-- describe "takeRest" $- it "returns rest of the input" $- property $ \st@State {..} -> do- let p :: Parser String- p = takeRest- st' = st- { stateInput = []- , stateOffset = stateOffset + length stateInput- , statePosState = statePosState- }- runParser' p st `shouldBe` (st', Right stateInput)-- describe "atEnd" $ do- let p, p' :: Parser Bool- p = atEnd- p' = p <* empty- context "when stream is empty" $ do- it "returns True" $- prs p "" `shouldParse` True- it "does not produce hints" $- prs p' "" `shouldFailWith` err 0 mempty- context "when stream is not empty" $ do- it "returns False" $- property $ \s -> not (null s) ==> do- prs p s `shouldParse` False- prs' p s `succeedsLeaving` s- it "does not produce hints" $- property $ \s -> not (null s) ==> do- prs p' s `shouldFailWith` err 0 mempty- prs' 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 "getSourcePos" $- it "sets position and gets it back" $- property $ \st -> do- let p :: Parser SourcePos- p = getSourcePos- pst' = snd $ reachOffset (stateOffset st) (statePosState st)- spos = pstateSourcePos pst'- runParser' p st `shouldBe` (st { statePosState = pst' }, Right spos)-- describe "setOffset and getOffset" $- it "sets number of processed tokens and gets it back" $- property $ \o -> do- let p = setOffset o >> getOffset- prs p "" `shouldParse` o-- describe "setParserState and getParserState" $- it "sets parser state and gets it back" $- property $ \s1 s2 -> do- let p :: MonadParsec Void String m => m (State String Void)- p = do- st <- getParserState- guard (st == initialState s)- setParserState s1- updateParserState (f s2)- getParserState <* setInput ""- f (State s1' o pst de1) (State s2' _ _ de2) =- State (max s1' s2') o pst (de1 <> de2)- 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 1 (ueof <> etok ch1 <> etok ch2)-- describe "notFollowedBy" $- it "generally works" $- property $ \a' b' c' -> do- let p = many (char =<< ask) <* notFollowedBy eof <* many anySingle- [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 a (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 (anySingle <* 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 (anySingle <* 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 0 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 0 mempty), s0, mempty :: [Int])--------------------------------------------------------------------------------- Helpers--instance ShowErrorComponent Int where- showErrorComponent = show--emulateStrParsing- :: State String Void- -> String- -> (State String Void, Either (ParseErrorBundle String Void) String)-emulateStrParsing st@(State i o pst de) s =- if s == take l i- then ( State (drop l i) (o + l) pst de- , Right s- )- else ( st- , Left (mkBundle st (nes (err o (etoks s <> utoks (take l i)))))- )- where- l = length s--eqParser :: (Eq a, Eq (Token s), Eq s)- => Parsec Void s a- -> Parsec Void s a- -> s- -> Bool-eqParser p1 p2 s = runParser p1 "" s == runParser p2 "" s--mkBundle- :: State s e- -> NonEmpty (ParseError s e) -- FIXME change back if we don't use it- -> ParseErrorBundle s e-mkBundle s es = ParseErrorBundle- { bundleErrors = NE.sortWith errorOffset es- , bundlePosState = statePosState s- }+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.MegaparsecSpec (spec) where++import Control.Monad.Cont+import Control.Monad.Except+import Control.Monad.Identity+import qualified Control.Monad.RWS.Lazy as L+import qualified Control.Monad.RWS.Strict as S+import Control.Monad.Reader+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 as BS+import Data.Char (isLetter, toUpper)+import Data.Foldable (asum)+import Data.List (isPrefixOf)+import qualified Data.List as DL+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Semigroup+import qualified Data.Set as E+import Data.String+import qualified Data.Text as T+import Data.Void+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck hiding (label)+import Text.Megaparsec+import Text.Megaparsec.Char+import Prelude hiding (concat, span)++spec :: Spec+spec = do+ describe "ParsecT Semigroup instance" $+ it "the associative operation works" $+ property $ \a b -> do+ let p = pure [a] <> pure [b]+ prs p "" `shouldParse` ([a, b] :: [Int])++ describe "ParsecT Monoid instance" $ do+ it "mempty works" $ do+ let p = mempty+ prs p "" `shouldParse` ([] :: [Int])+ it "mappend works" $+ property $ \a b -> do+ let p = pure [a] `mappend` pure [b]+ prs p "" `shouldParse` ([a, b] :: [Int])++ describe "ParsecT IsString instance" $ do+ describe "equivalence to 'string'" $ do+ it "for String" $+ property $ \s i ->+ eqParser+ (chunk s)+ (fromString s)+ (i :: String)+ it "for Text" $+ property $ \s i ->+ eqParser+ (chunk (T.pack s))+ (fromString s)+ (i :: T.Text)+ it "for ByteString" $+ property $ \s i ->+ eqParser+ (chunk (fromString s :: BS.ByteString))+ (fromString s)+ (i :: BS.ByteString)+ it "can handle Unicode" $ do+ let r = "פּאַרסער 解析器" :: BS.ByteString+ p :: Parsec Void BS.ByteString BS.ByteString+ p = BS.concat <$> sequence ["פּאַ", "רסער", " 解析器"]+ parse p "" r `shouldParse` r++ 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 2 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 = chunk s0 <|> chunk 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+ z = take (max (length s0) (length s1)) s+ prs p s+ `shouldFailWith` err+ 0+ ( etoks s0+ <> etoks s1+ <> (if null s then ueof else utoks z)+ )+ 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 1 (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 0 (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 0 (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+ 0+ (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 (ParseErrorBundle String Void) ())+ v = runParserT p "" ("" :: String)+ 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 0 (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 0 (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 Void String ()+ prs p "" `shouldFailWith` errFancy 0 (fancy $ ErrorFail 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` errFancy 0 (fancy $ ErrorFail msg)+ prs' p s `failsLeaving` s++ describe "ParsecT MonadIO instance" $+ it "liftIO works" $+ property $ \n -> do+ let p = liftIO (return n) :: ParsecT Void String IO Integer+ runParserT p "" "" `shouldReturn` Right n++ describe "ParsecT MonadFix instance" $+ it "withRange works" $+ do+ let withRange ::+ ( TraversableStream s,+ MonadParsec e s m,+ MonadFix m+ ) =>+ ((SourcePos, SourcePos) -> m a) ->+ m a+ withRange f = do+ p1 <- getSourcePos+ rec r <- f (p1, p2)+ p2 <- getSourcePos+ return r+ p :: Parsec Void String (SourcePos, SourcePos)+ p = withRange $ \pp -> pp <$ string "ab"+ runParser p "" "abcd"+ `shouldBe` Right+ ( SourcePos "" (mkPos 1) (mkPos 1),+ SourcePos "" (mkPos 1) (mkPos 3)+ )++ describe "ParsecT MonadReader instance" $ do+ describe "ask" $+ it "returns correct value of context" $+ property $ \n -> do+ let p = ask :: ParsecT Void 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 Void 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 Void 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 Void 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 Void String (Cont (Either (ParseErrorBundle String Void) 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 Void 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 Void 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 "parseError" $ do+ it "immediately fails with given parse error" $+ property $ \st e -> do+ let p :: MonadParsec Void String m => m ()+ p = parseError e+ runParser' p st `shouldBe` (st, Left (mkBundle st (nes e)))++ 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 Void String m => m Char+ p = label lbl (char a) <* empty+ s = [a]+ grs p s (`shouldFailWith` err 1 mempty)+ grs' p s (`failsLeaving` "")+ context "inner parser produces hints" $+ it "does not alter the hints" $+ property $ \lbl a ->+ not (null lbl) ==> do+ let p :: MonadParsec Void String m => m String+ p = label lbl (many (char a)) <* empty+ s = [a]+ grs p s (`shouldFailWith` err 1 (etok a))+ 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 Void String m => m Char+ p = label lbl (char a *> char b)+ s = [a, c]+ grs p s (`shouldFailWith` err 1 (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 Void String m => m Char+ p = label lbl (return a) <* empty+ grs p "" (`shouldFailWith` err 0 mempty)+ context "inner parser produces hints" $+ it "replaces the last hint with given label" $+ property $ \lbl a ->+ not (null lbl) ==> do+ let p :: MonadParsec Void String m => m String+ p = label lbl (many (char a)) <* empty+ grs p "" (`shouldFailWith` err 0 (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 Void String m => m ()+ p = label lbl empty+ grs p "" (`shouldFailWith` err 0 (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 Void String m => m Char+ p = hidden (char a) <* empty+ s = [a]+ grs p s (`shouldFailWith` err 1 mempty)+ grs' p s (`failsLeaving` "")+ context "inner parser produces hints" $+ it "hides the parser in the error message" $+ property $ \a -> do+ let p :: MonadParsec Void String m => m String+ p = hidden (many (char a)) <* empty+ s = [a]+ grs p s (`shouldFailWith` err 1 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 Void String m => m Char+ p = hidden (char a *> char b)+ s = [a, c]+ grs p s (`shouldFailWith` err 1 (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 Void String m => m Char+ p = hidden (return a) <* empty+ grs p "" (`shouldFailWith` err 0 mempty)+ context "inner parser produces hints" $+ it "hides the parser in the error message" $+ property $ \a -> do+ let p :: MonadParsec Void String m => m String+ p = hidden (many (char a)) <* empty+ grs p "" (`shouldFailWith` err 0 mempty)+ context "when inner parser fails without consuming" $+ it "hides the parser in the error message" $+ do+ let p :: MonadParsec Void String m => m ()+ p = hidden empty+ grs p "" (`shouldFailWith` err 0 mempty)++ describe "try" $ do+ context "when inner parser succeeds consuming" $+ it "try has no effect" $+ property $ \a -> do+ let p :: MonadParsec Void 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" $ do+ it "backtracks, it appears as if the parser has not consumed anything" $+ property $ \a b c ->+ b /= c ==> do+ let p :: MonadParsec Void String m => m Char+ p = try (char a *> char b)+ s = [a, c]+ grs p s (`shouldFailWith` err 1 (utok c <> etok b))+ grs' p s (`failsLeaving` s)+ it "hints from the inner parse error do not leak" $+ property $ \a b c ->+ b /= c ==> do+ let p :: MonadParsec Void String m => m (Maybe Char)+ p = (optional . try) (char a *> char b) <* empty+ s = [a, c]+ grs p s (`shouldFailWith` err 0 mempty)+ grs' p s (`failsLeaving` s)+ context "when inner parser succeeds without consuming" $+ it "try has no effect" $+ property $ \a -> do+ let p :: MonadParsec Void 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 Void String m => m Char+ p = try (setTabWidth w *> empty)+ grs p "" (`shouldFailWith` err 0 mempty)+ grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)++ 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 Void 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 Void String m => m String+ p = lookAhead (many (char a)) <* empty+ s = [a]+ grs p s (`shouldFailWith` err 0 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 Void String m => m Char+ p = lookAhead (char a *> char b)+ s = [a, c]+ grs p s (`shouldFailWith` err 1 (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 Void 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 Void String m => m String+ p = lookAhead (many (char a)) <* empty+ s = [b]+ grs p s (`shouldFailWith` err 0 mempty)+ grs' p s (`failsLeaving` s)+ context "when inner parser fails without consuming" $+ it "error message is reported as usual" $+ do+ let p :: MonadParsec Void String m => m Char+ p = lookAhead empty+ grs p "" (`shouldFailWith` err 0 mempty)++ describe "notFollowedBy" $ do+ context "when inner parser succeeds consuming" $+ it "signals correct parse error" $+ property $ \a w -> do+ let p :: MonadParsec Void String m => m ()+ p = notFollowedBy (setTabWidth w <* char a)+ s = [a]+ grs p s (`shouldFailWith` err 0 (utok a))+ grs' p s (`failsLeaving` s)+ grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)+ context "when inner parser fails consuming" $ do+ it "succeeds without consuming" $+ property $ \a b c w ->+ b /= c ==> do+ let p :: MonadParsec Void String m => m ()+ p = notFollowedBy (setTabWidth w *> char a *> char b)+ s = [a, c]+ grs' p s (`succeedsLeaving` s)+ grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)+ it "hints are not preserved" $+ property $ \a b ->+ a /= b ==> do+ let p :: MonadParsec Void String m => m ()+ p = notFollowedBy (char b *> many (char a) <* char a) <* empty+ s = [b, b]+ grs p s (`shouldFailWith` err 0 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 Void String m => m ()+ p = notFollowedBy (setTabWidth w *> return a)+ s = [a]+ grs p s (`shouldFailWith` err 0 (utok a))+ grs' p s (`failsLeaving` s)+ grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)+ context "when inner parser fails without consuming" $ do+ it "succeeds without consuming" $+ property $ \w -> do+ let p :: MonadParsec Void String m => m ()+ p = notFollowedBy (setTabWidth w *> empty)+ grs p "" (`shouldParse` ())+ grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)+ it "hints are not preserved" $+ property $ \a -> do+ let p :: MonadParsec Void String m => m ()+ p = notFollowedBy (many (char a) <* char a) <* empty+ s = ""+ grs p s (`shouldFailWith` err 0 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 Void 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 Void String m => m (Either (ParseError String Void) Char)+ p =+ withRecovery+ (\e -> Left e <$ string (c : as))+ (Right <$> char a <* char b)+ s = a : c : as+ grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))+ grs' p s (`succeedsLeaving` "")+ it "hints are not preserved" $+ property $ \a b c as ->+ b /= c ==> do+ let p :: MonadParsec Void String m => m (Either (ParseError String Void) 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 (length 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 Void String m => m (Either (ParseError String Void) Char)+ p =+ withRecovery+ (\e -> Left e <$ char c <* empty)+ (Right <$> char a <* char b)+ s = a : c : as+ grs p s (`shouldFailWith` err 1 (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 Void String m => m (Either (ParseError String Void) Char)+ p = withRecovery (return . Left) (Right <$> char a <* char b)+ s = a : c : as+ grs p s (`shouldParse` Left (err 1 (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 Void String m => m (Either (ParseError String Void) Char)+ p =+ withRecovery+ (return . Left)+ (Right <$> char a <* many (char b) <* char b)+ <* empty+ s = a : c : as+ grs p s (`shouldFailWith` err 1 (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 Void String m => m (Either (ParseError String Void) Char)+ p =+ withRecovery+ (\e -> Left e <$ empty)+ (Right <$> char a <* char b)+ s = a : c : as+ grs p s (`shouldFailWith` err 1 (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 Void 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 Void String m => m (Either (ParseError String Void) Char)+ p = withRecovery (\e -> Left e <$ string s) empty+ s = a : as+ grs p s (`shouldParse` Left (err 0 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 Void String m => m (Either (ParseError String Void) Char)+ p =+ withRecovery+ (\e -> Left e <$ char a <* char b <* empty)+ (Right <$> empty)+ s = a : as+ grs p s (`shouldFailWith` err 0 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 Void String m => m (Either (ParseError String Void) Char)+ p = withRecovery (return . Left) empty+ grs p s (`shouldParse` Left (err 0 mempty))+ grs' p s (`succeedsLeaving` s)+ it "original hints are preserved" $+ property $ \a b as ->+ a /= b ==> do+ let p :: MonadParsec Void String m => m (Either (ParseError String Void) String)+ p =+ withRecovery+ (return . Left)+ (Right <$> many (char a) <* empty)+ <* empty+ s = b : as+ grs p s (`shouldFailWith` err 0 (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 Void String m => m (Either (ParseError String Void) Char)+ p = withRecovery (\e -> Left e <$ empty) empty+ grs p s (`shouldFailWith` err 0 mempty)+ grs' p s (`failsLeaving` s)+ it "works in complex situations too" $+ property $ \a' b' c' -> do+ let p :: MonadParsec Void String m => m (Either (ParseError String Void) 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 0 (ueof <> etok 'a'))+ | a == 0 && b == 0 && c > 3 = f (err 0 (utok 'c' <> etok 'a'))+ | a == 0 && b == 0 = f (err 0 (utok 'c' <> etok 'a'))+ | a == 0 && b > 3 = f (err 3 (utok 'b' <> etok 'c'))+ | a == 0 && c == 0 = f (err b (ueof <> etok 'c'))+ | a == 0 && c > 3 = f (err (b + 3) (utok 'c' <> eeof))+ | a == 0 = z (Left (err 0 (utok 'b' <> etok 'a')))+ | a > 3 = f (err 3 (utok 'a' <> etok 'c'))+ | b == 0 && c == 0 = f (err a (ueof <> etok 'c' <> ma))+ | b == 0 && c > 3 = f (err (a + 3) (utok 'c' <> eeof))+ | b == 0 = z (Right s)+ | otherwise = f (err a (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 Void String m => m (Either (ParseError String Void) 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 Void String m => m (Either (ParseError String Void) Char)+ p = observing (char a *> char b)+ s = a : c : as+ grs p s (`shouldParse` Left (err 1 (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 Void String m => m (Either (ParseError String Void) Char)+ p = observing (char a *> char b) *> empty+ s = a : c : as+ grs p s (`shouldFailWith` err 1 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 Void String m => m (Either (ParseError String Void) 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 Void String m => m (Either (ParseError String Void) ())+ p = observing empty+ grs p s (`shouldParse` Left (err 0 mempty))+ grs' p s (`succeedsLeaving` s)+ it "creates correct hints" $+ property $ \a b as ->+ a /= b ==> do+ let p :: MonadParsec Void String m => m (Either (ParseError String Void) Char)+ p = observing (char a) <* empty+ s = b : as+ grs p s (`shouldFailWith` err 0 (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 0 (utok a <> eeof))+ grs' eof s (`failsLeaving` s)++ describe "token" $ do+ let expected = E.singleton . Tokens . nes+ testChar a x = if a == x then Just x else Nothing+ context "when supplied predicate is satisfied" $+ it "succeeds" $+ property $ \a as -> do+ let p :: MonadParsec Void String m => m Char+ p = token (testChar a) (expected a)+ 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 ->+ a /= b ==> do+ let p :: MonadParsec Void String m => m Char+ p = token (testChar b) (expected b)+ s = a : as+ us = pure (Tokens $ nes a)+ ps = E.singleton (Tokens $ nes b)+ grs p s (`shouldFailWith` TrivialError 0 us ps)+ grs' p s (`failsLeaving` s)+ context "when stream is empty" $+ it "signals correct parse error" $+ property $ \a -> do+ let p :: MonadParsec Void String m => m Char+ p = token (testChar a) ps+ us = pure EndOfInput+ ps = expected a+ grs p "" (`shouldFailWith` TrivialError 0 us ps)++ describe "tokens" $ do+ context "when stream is prefixed with given string" $+ it "parses the string" $+ property $ \str s -> do+ let p :: MonadParsec Void 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 Void String m => m String+ p = tokens (==) str+ z = take (length str) s+ grs p s (`shouldFailWith` err 0 (utoks z <> etoks str))+ grs' p s (`failsLeaving` s)+ context "when matching the empty string" $+ it "eok continuation is used" $+ property $ \str s -> do+ let p :: MonadParsec Void String m => m String+ p = (tokens (==) "" <* empty) <|> pure str+ grs p s (`shouldParse` str)+ grs' p s (`succeedsLeaving` s)++ describe "takeWhileP" $ do+ context "when stream is not empty" $+ it "consumes all matching tokens, zero or more" $+ property $ \s ->+ not (null s) ==> do+ let p :: MonadParsec Void String m => m String+ p = takeWhileP Nothing isLetter+ (z, zs) = DL.span isLetter s+ grs p s (`shouldParse` z)+ grs' p s (`succeedsLeaving` zs)+ context "when stream is empty" $+ it "succeeds returning empty chunk" $ do+ let p :: MonadParsec Void String m => m String+ p = takeWhileP Nothing isLetter+ grs p "" (`shouldParse` "")+ grs' p "" (`succeedsLeaving` "")+ context "with two takeWhileP in a row (testing hints)" $ do+ let p :: MonadParsec Void String m => m String+ p = do+ void $ takeWhileP (Just "foo") (== 'a')+ void $ takeWhileP (Just "bar") (== 'b')+ empty+ context "when the second one does not consume" $+ it "hints are combined properly" $ do+ let s = "aaa"+ pe = err 3 (elabel "foo" <> elabel "bar")+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` "")+ context "when the second one consumes" $+ it "only hints of the second one affect parse error" $ do+ let s = "aaabbb"+ pe = err 6 (elabel "bar")+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` "")+ context "without label (testing hints)" $+ it "there are no hints" $ do+ let p :: MonadParsec Void String m => m String+ p = takeWhileP Nothing (== 'a') <* empty+ s = "aaa"+ grs p s (`shouldFailWith` err 3 mempty)+ grs' p s (`failsLeaving` "")++ describe "takeWhile1P" $ do+ context "when stream is prefixed with matching tokens" $+ it "consumes the tokens" $+ property $ \s' -> do+ let p :: MonadParsec Void String m => m String+ p = takeWhile1P Nothing isLetter+ s = 'a' : s'+ (z, zs) = DL.span isLetter s+ grs p s (`shouldParse` z)+ grs' p s (`succeedsLeaving` zs)+ context "when stream is not prefixed with at least one matching token" $+ it "signals correct parse error" $+ property $ \s' -> do+ let p :: MonadParsec Void String m => m String+ p = takeWhile1P (Just "foo") isLetter+ s = '3' : s'+ pe = err 0 (utok '3' <> elabel "foo")+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` s)+ context "when stream is empty" $ do+ context "with label" $+ it "signals correct parse error" $ do+ let p :: MonadParsec Void String m => m String+ p = takeWhile1P (Just "foo") isLetter+ pe = err 0 (ueof <> elabel "foo")+ grs p "" (`shouldFailWith` pe)+ grs' p "" (`failsLeaving` "")+ context "without label" $+ it "signals correct parse error" $ do+ let p :: MonadParsec Void String m => m String+ p = takeWhile1P Nothing isLetter+ pe = err 0 ueof+ grs p "" (`shouldFailWith` pe)+ grs' p "" (`failsLeaving` "")+ context "with two takeWhile1P in a row (testing hints)" $ do+ let p :: MonadParsec Void String m => m String+ p = do+ void $ takeWhile1P (Just "foo") (== 'a')+ void $ takeWhile1P (Just "bar") (== 'b')+ empty+ context "when the second one does not consume" $+ it "hints are combined properly" $ do+ let s = "aaa"+ pe = err 3 (ueof <> elabel "foo" <> elabel "bar")+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` "")+ context "when the second one consumes" $+ it "only hints of the second one affect parse error" $ do+ let s = "aaabbb"+ pe = err 6 (elabel "bar")+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` "")+ context "without label (testing hints)" $+ it "there are no hints" $ do+ let p :: MonadParsec Void String m => m String+ p = takeWhile1P Nothing (== 'a') <* empty+ s = "aaa"+ grs p s (`shouldFailWith` err 3 mempty)+ grs' p s (`failsLeaving` "")++ describe "takeP" $ do+ context "when taking 0 tokens" $ do+ context "when stream is empty" $+ it "succeeds returning zero-length chunk" $ do+ let p :: MonadParsec Void String m => m String+ p = takeP Nothing 0+ grs p "" (`shouldParse` "")+ context "when stream is not empty" $+ it "succeeds returning zero-length chunk" $+ property $ \s ->+ not (null s) ==> do+ let p :: MonadParsec Void String m => m String+ p = takeP Nothing 0+ grs p s (`shouldParse` "")+ grs' p s (`succeedsLeaving` s)+ context "when taking >0 tokens" $ do+ context "when stream is empty" $ do+ context "with label" $+ it "signals correct parse error" $+ property $ \(Positive n) -> do+ let p :: MonadParsec Void String m => m String+ p = takeP (Just "foo") n+ pe = err 0 (ueof <> elabel "foo")+ grs p "" (`shouldFailWith` pe)+ grs' p "" (`failsLeaving` "")+ context "without label" $+ it "signals correct parse error" $+ property $ \(Positive n) -> do+ let p :: MonadParsec Void String m => m String+ p = takeP Nothing n+ pe = err 0 ueof+ grs p "" (`shouldFailWith` pe)+ context "when stream has not enough tokens" $+ it "signals correct parse error" $+ property $ \(Positive n) s -> do+ let p :: MonadParsec Void String m => m String+ p = takeP (Just "foo") n+ m = length s+ pe = err m (ueof <> elabel "foo")+ unless (length s < n && not (null s)) discard+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` s)+ context "when stream has enough tokens" $+ it "succeeds returning the extracted tokens" $+ property $ \(Positive n) s ->+ length s >= n ==> do+ let p :: MonadParsec Void String m => m String+ p = takeP (Just "foo") n+ (s0, s1) = splitAt n s+ grs p s (`shouldParse` s0)+ grs' p s (`succeedsLeaving` s1)+ context "when failing right after takeP (testing hints)" $+ it "there are no hints to influence the parse error" $+ property $ \(Positive n) s ->+ length s >= n ==> do+ let p :: MonadParsec Void String m => m String+ p = takeP (Just "foo") n <* empty+ pe = err n mempty+ grs p s (`shouldFailWith` pe)+ grs' p s (`failsLeaving` drop n s)++ describe "signaling parse errors" $ do+ describe "failure" $+ it "signals correct parse error" $+ property $ \us ps -> do+ let p :: MonadParsec Void String m => m ()+ p = void (failure us ps)+ grs p "" (`shouldFailWith` TrivialError 0 us ps)++ describe "fancyFailure" $+ it "singals correct parse error" $+ property $ \xs -> do+ let p :: MonadParsec Void String m => m ()+ p = void (fancyFailure xs)+ grs p "" (`shouldFailWith` FancyError 0 xs)++ describe "unexpected" $+ it "signals correct parse error" $+ property $ \item -> do+ let p :: MonadParsec Void String m => m ()+ p = void (unexpected item)+ grs p "" (`shouldFailWith` TrivialError 0 (pure item) E.empty)++ describe "customFailure" $+ it "signals correct parse error" $+ property $ \n st -> do+ let p :: MonadParsec Int String m => m ()+ p = void (customFailure n)+ xs = E.singleton (ErrorCustom n)+ runParser p "" (stateInput st) `shouldFailWith` FancyError 0 xs+ runParser' p st `failsLeaving` stateInput st++ describe "region" $ do+ let f o' = \case+ TrivialError o us ps ->+ FancyError+ (max o o')+ (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)+ FancyError o xs ->+ FancyError+ (max o o')+ (E.singleton . ErrorCustom $ E.size xs)+ context "when inner parser succeeds" $ do+ it "delayed parse errors get updated correctly" $+ property $ \st es0 es1 es2 o' n -> do+ let p :: Parsec Int String Int+ p = do+ forM_ (NE.reverse es0) registerParseError+ region (f o') $+ forM_ (NE.reverse es1) registerParseError+ forM_ (NE.reverse es2) registerParseError+ return n+ es = es2 <> fmap (f o') es1 <> es0+ st' =+ st+ { stateParseErrors = NE.toList es+ }+ runParser' p st+ `shouldBe` ( st',+ Left (mkBundle st es)+ )+ context "when inner parser fails" $ do+ it "delayed and normal parse errors get updated correctly" $+ property $ \st es0 es1 e o' -> do+ let p :: Parsec Int String ()+ p = do+ forM_ (NE.reverse es0) registerParseError+ region (f o') $ do+ forM_ (NE.reverse es1) registerParseError+ void (parseError e)+ es = fmap (f o') es1 <> es0+ st' =+ st+ { stateParseErrors = NE.toList es+ }+ runParser' p st+ `shouldBe` ( st',+ Left (mkBundle st (nes (f o' e) <> es))+ )++ describe "registerParseError" $ do+ it "immediately fails with given parse error" $+ property $ \st es -> do+ let p :: MonadParsec Void String m => m ()+ p = forM_ (NE.reverse es) registerParseError+ st' =+ st+ { stateParseErrors = NE.toList es+ }+ runParser' p st+ `shouldBe` ( st',+ Left (mkBundle st es)+ )++ describe "registerFailure" $+ it "signals correct parse error" $+ property $ \us ps -> do+ let p :: MonadParsec Void String m => m ()+ p = void (registerFailure us ps)+ grs p "" (`shouldFailWith` TrivialError 0 us ps)++ describe "reisterFancyFailure" $+ it "singals correct parse error" $+ property $ \xs -> do+ let p :: MonadParsec Void String m => m ()+ p = void (registerFancyFailure xs)+ grs p "" (`shouldFailWith` FancyError 0 xs)++ describe "derivatives from primitive combinators" $ do+ -- NOTE 'single' is tested via 'char' in "Text.Megaparsec.Char" and+ -- "Text.Megaparsec.Byte".++ describe "anySingle" $ do+ let p :: MonadParsec Void String m => m Char+ p = anySingle+ context "when stream is not empty" $+ it "succeeds consuming next character in the stream" $+ property $ \ch s -> do+ let s' = ch : s+ grs p s' (`shouldParse` ch)+ grs' p s' (`succeedsLeaving` s)+ context "when stream is empty" $+ it "signals correct parse error" $+ grs p "" (`shouldFailWith` err 0 ueof)++ describe "anySingleBut" $ do+ context "when stream begins with the character specified as argument" $+ it "signals correct parse error" $+ property $ \ch s' -> do+ let p :: MonadParsec Void String m => m Char+ p = anySingleBut ch+ s = ch : s'+ grs p s (`shouldFailWith` err 0 (utok ch))+ grs' p s (`failsLeaving` s)+ context "when stream does not begin with the character specified as argument" $+ it "parses first character in the stream" $+ property $ \ch s ->+ not (null s) && ch /= head s ==> do+ let p :: MonadParsec Void String m => m Char+ p = anySingleBut ch+ grs p s (`shouldParse` head s)+ grs' p s (`succeedsLeaving` tail s)+ context "when stream is empty" $+ it "signals correct parse error" $+ grs (anySingleBut 'a') "" (`shouldFailWith` err 0 ueof)++ describe "oneOf" $ do+ context "when stream begins with one of specified characters" $+ it "parses the character" $+ property $ \chs' n s -> do+ let chs = getNonEmpty chs'+ ch = chs !! (getNonNegative n `rem` length chs)+ s' = ch : s+ grs (oneOf chs) s' (`shouldParse` ch)+ grs' (oneOf chs) s' (`succeedsLeaving` s)+ context "when stream does not begin with any of specified characters" $+ it "signals correct parse error" $+ property $ \chs ch s ->+ ch `notElem` (chs :: String) ==> do+ let s' = ch : s+ grs (oneOf chs) s' (`shouldFailWith` err 0 (utok ch))+ grs' (oneOf chs) s' (`failsLeaving` s')+ context "when stream is empty" $+ it "signals correct parse error" $+ property $ \chs ->+ grs (oneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)++ describe "noneOf" $ do+ context "when stream does not begin with any of specified characters" $+ it "parses the character" $+ property $ \chs ch s ->+ ch `notElem` (chs :: String) ==> do+ let s' = ch : s+ grs (noneOf chs) s' (`shouldParse` ch)+ grs' (noneOf chs) s' (`succeedsLeaving` s)+ context "when stream begins with one of specified characters" $+ it "signals correct parse error" $+ property $ \chs' n s -> do+ let chs = getNonEmpty chs'+ ch = chs !! (getNonNegative n `rem` length chs)+ s' = ch : s+ grs (noneOf chs) s' (`shouldFailWith` err 0 (utok ch))+ grs' (noneOf chs) s' (`failsLeaving` s')+ context "when stream is empty" $+ it "signals correct parse error" $+ property $ \chs ->+ grs (noneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)++ -- NOTE 'chunk' is tested via 'string' in "Text.Megaparsec.Char" and+ -- "Text.Megaparsec.Byte".++ describe "match" $+ it "return consumed tokens along with the result" $+ property $ \str -> do+ let p = match (string str)+ prs p str `shouldParse` (str, str)+ prs' p str `succeedsLeaving` ""++ describe "takeRest" $+ it "returns rest of the input" $+ property $ \st@State {..} -> do+ let p :: Parser String+ p = takeRest+ st' =+ st+ { stateInput = [],+ stateOffset = stateOffset + length stateInput,+ statePosState = statePosState+ }+ runParser' p st `shouldBe` (st', Right stateInput)++ describe "atEnd" $ do+ let p, p' :: Parser Bool+ p = atEnd+ p' = p <* empty+ context "when stream is empty" $ do+ it "returns True" $+ prs p "" `shouldParse` True+ it "does not produce hints" $+ prs p' "" `shouldFailWith` err 0 mempty+ context "when stream is not empty" $ do+ it "returns False" $+ property $ \s ->+ not (null s) ==> do+ prs p s `shouldParse` False+ prs' p s `succeedsLeaving` s+ it "does not produce hints" $+ property $ \s ->+ not (null s) ==> do+ prs p' s `shouldFailWith` err 0 mempty+ prs' 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 "getSourcePos" $+ it "sets position and gets it back" $+ property $ \st -> do+ let p :: Parser SourcePos+ p = getSourcePos+ pst' = snd $ reachOffset (stateOffset st) (statePosState st)+ spos = pstateSourcePos pst'+ runParser' p st `shouldBe` (st {statePosState = pst'}, Right spos)++ describe "setOffset and getOffset" $+ it "sets number of processed tokens and gets it back" $+ property $ \o -> do+ let p = setOffset o >> getOffset+ prs p "" `shouldParse` o++ describe "setParserState and getParserState" $+ it "sets parser state and gets it back" $+ property $ \s1 s2 -> do+ let p :: MonadParsec Void String m => m (State String Void)+ p = do+ st <- getParserState+ guard (st == initialState s)+ setParserState s1+ updateParserState (f s2)+ getParserState <* setInput ""+ f (State s1' o pst de1) (State s2' _ _ de2) =+ State (max s1' s2') o pst (de1 <> de2)+ 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 1 (ueof <> etok ch1 <> etok ch2)++ describe "notFollowedBy" $+ it "generally works" $+ property $ \a' b' c' -> do+ let p = many (char =<< ask) <* notFollowedBy eof <* many anySingle+ [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 a (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 (anySingle <* 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 (anySingle <* 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 0 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 0 mempty), s0, mempty :: [Int])++----------------------------------------------------------------------------+-- Helpers++instance ShowErrorComponent Int where+ showErrorComponent = show++emulateStrParsing ::+ State String Void ->+ String ->+ (State String Void, Either (ParseErrorBundle String Void) String)+emulateStrParsing st@(State i o pst de) s =+ if s == take l i+ then+ ( State (drop l i) (o + l) pst de,+ Right s+ )+ else+ ( st,+ Left (mkBundle st (nes (err o (etoks s <> utoks (take l i)))))+ )+ where+ l = length s++eqParser ::+ (Eq a, Eq (Token s), Eq s) =>+ Parsec Void s a ->+ Parsec Void s a ->+ s ->+ Bool+eqParser p1 p2 s = runParser p1 "" s == runParser p2 "" s++mkBundle ::+ State s e ->+ NonEmpty (ParseError s e) ->+ ParseErrorBundle s e+mkBundle s es =+ ParseErrorBundle+ { bundleErrors = NE.sortWith errorOffset es,+ bundlePosState = statePosState s+ } grabTabWidth :: (State a e, b) -> Pos grabTabWidth = pstateTabWidth . statePosState . fst