diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,6 @@ +module Main (main) where + import Distribution.Simple + +main :: IO () main = defaultMain diff --git a/megaparsec-tests.cabal b/megaparsec-tests.cabal --- a/megaparsec-tests.cabal +++ b/megaparsec-tests.cabal @@ -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 -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 +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 diff --git a/src/Test/Hspec/Megaparsec/AdHoc.hs b/src/Test/Hspec/Megaparsec/AdHoc.hs --- a/src/Test/Hspec/Megaparsec/AdHoc.hs +++ b/src/Test/Hspec/Megaparsec/AdHoc.hs @@ -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 diff --git a/tests/Text/Megaparsec/Byte/LexerSpec.hs b/tests/Text/Megaparsec/Byte/LexerSpec.hs --- a/tests/Text/Megaparsec/Byte/LexerSpec.hs +++ b/tests/Text/Megaparsec/Byte/LexerSpec.hs @@ -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) diff --git a/tests/Text/Megaparsec/ByteSpec.hs b/tests/Text/Megaparsec/ByteSpec.hs --- a/tests/Text/Megaparsec/ByteSpec.hs +++ b/tests/Text/Megaparsec/ByteSpec.hs @@ -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 diff --git a/tests/Text/Megaparsec/Char/LexerSpec.hs b/tests/Text/Megaparsec/Char/LexerSpec.hs --- a/tests/Text/Megaparsec/Char/LexerSpec.hs +++ b/tests/Text/Megaparsec/Char/LexerSpec.hs @@ -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" diff --git a/tests/Text/Megaparsec/CharSpec.hs b/tests/Text/Megaparsec/CharSpec.hs --- a/tests/Text/Megaparsec/CharSpec.hs +++ b/tests/Text/Megaparsec/CharSpec.hs @@ -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' diff --git a/tests/Text/Megaparsec/DebugSpec.hs b/tests/Text/Megaparsec/DebugSpec.hs --- a/tests/Text/Megaparsec/DebugSpec.hs +++ b/tests/Text/Megaparsec/DebugSpec.hs @@ -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 diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs --- a/tests/Text/Megaparsec/ErrorSpec.hs +++ b/tests/Text/Megaparsec/ErrorSpec.hs @@ -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 | \n | ^\nunknown parse error\n" + mkBundlePE s (mempty :: PE) + `shouldBe` "1:1:\n |\n1 | \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 | \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 | \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 = "" + } + } diff --git a/tests/Text/Megaparsec/PosSpec.hs b/tests/Text/Megaparsec/PosSpec.hs --- a/tests/Text/Megaparsec/PosSpec.hs +++ b/tests/Text/Megaparsec/PosSpec.hs @@ -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" $ diff --git a/tests/Text/Megaparsec/StreamSpec.hs b/tests/Text/Megaparsec/StreamSpec.hs --- a/tests/Text/Megaparsec/StreamSpec.hs +++ b/tests/Text/Megaparsec/StreamSpec.hs @@ -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" "\"{\"") -- | 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 " $ 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` "" + r `shouldBe` Just "" 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) diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -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