megaparsec-tests (empty) → 7.0.5
raw patch · 15 files changed
+4525/−0 lines, 15 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, case-insensitive, containers, hspec, hspec-expectations, hspec-megaparsec, megaparsec, megaparsec-tests, mtl, parser-combinators, scientific, text, transformers
Files
- LICENSE.md +24/−0
- README.md +17/−0
- Setup.hs +6/−0
- megaparsec-tests.cabal +79/−0
- src/Test/Hspec/Megaparsec/AdHoc.hs +338/−0
- tests/Spec.hs +1/−0
- tests/Text/Megaparsec/Byte/LexerSpec.hs +314/−0
- tests/Text/Megaparsec/ByteSpec.hs +236/−0
- tests/Text/Megaparsec/Char/LexerSpec.hs +567/−0
- tests/Text/Megaparsec/CharSpec.hs +344/−0
- tests/Text/Megaparsec/DebugSpec.hs +55/−0
- tests/Text/Megaparsec/ErrorSpec.hs +280/−0
- tests/Text/Megaparsec/PosSpec.hs +63/−0
- tests/Text/Megaparsec/StreamSpec.hs +550/−0
- tests/Text/MegaparsecSpec.hs +1651/−0
+ LICENSE.md view
@@ -0,0 +1,24 @@+Copyright © 2015–2019 Megaparsec contributors++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,17 @@+# Megaparsec tests++Megaparsec's test suite as a standalone package. The reason for separtion is+that we can avoid circular dependency on `hspec-megaparsec` and thus avoid+keeping copies of its source files in our test suite, as we had to do+before. Another benefit is that we can export some auxiliary functions in+`megaparsec-tests` which can be used by other test suites, for example in+the `parser-combinators-tests` package.++Version of `megaparsec-tests` will be kept in sync with versions of+`megaparsec` from now on.++## License++Copyright © 2015–2019 Megaparsec contributors++Distributed under FreeBSD license.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ megaparsec-tests.cabal view
@@ -0,0 +1,79 @@+name: megaparsec-tests+version: 7.0.5+cabal-version: 1.18+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5+license: BSD2+license-file: LICENSE.md+author: Megaparsec contributors+maintainer: Mark Karpov <markkarpov92@gmail.com>+homepage: https://github.com/mrkkrp/megaparsec+bug-reports: https://github.com/mrkkrp/megaparsec/issues+category: Parsing+synopsis: Test utilities and the test suite of Megaparsec+build-type: Simple+description: Test utilities and the test suite of Megaparsec.+extra-doc-files: README.md++flag dev+ description: Turn on development settings.+ manual: True+ default: False++library+ hs-source-dirs: src+ build-depends: QuickCheck >= 2.7 && < 2.13+ , base >= 4.9 && < 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 == 7.0.5+ , mtl >= 2.0 && < 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+ -Wnoncanonical-monadfail-instances+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010++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.7 && < 2.13+ , base >= 4.9 && < 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 == 7.0.5+ , megaparsec-tests+ , mtl >= 2.0 && < 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
+ src/Test/Hspec/Megaparsec/AdHoc.hs view
@@ -0,0 +1,338 @@+-- |+-- Module : Test.Hspec.Megaparsec.AdHoc+-- Copyright : © 2019 Megaparsec contributors+-- License : FreeBSD+--+-- Maintainer : Mark Karpov <markkarpov92@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Ad-hoc helpers used in Megaparsec's test suite.++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Hspec.Megaparsec.AdHoc+ ( -- * Types+ Parser+ -- * Helpers to run parsers+ , prs+ , prs'+ , prs_+ , grs+ , grs'+ -- * Other+ , nes+ , abcRow+ , rightOrder+ , scaleDown+ , getTabWidth+ , setTabWidth+ , strSourcePos+ -- * Char and byte conversion+ , toChar+ , fromChar+ -- * Proxies+ , sproxy+ , bproxy+ , blproxy+ , tproxy+ , tlproxy )+where++import Control.Monad.Reader+import Control.Monad.Trans.Identity+import Data.Char (chr, ord)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy+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++----------------------------------------------------------------------------+-- Helpers to run parsers++-- | 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 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, Either (ParseErrorBundle String Void) a)+ -- ^ Result of parsing+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_ 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 p s r = do+ r (prs 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)++-- | '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, Either (ParseErrorBundle String Void) a) -> Expectation)+ -- ^ How to check result of parsing+ -> Expectation+grs' p s r = do+ r (prs' 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)++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 () ()+ return a++evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a+evalRWSTS m = do+ (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 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 } }++-- | 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 (x, _, _) = reachOffset maxBound pstate in x+ where+ 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)++----------------------------------------------------------------------------+-- Proxies++sproxy :: Proxy String+sproxy = Proxy++bproxy :: Proxy B.ByteString+bproxy = Proxy++blproxy :: Proxy BL.ByteString+blproxy = Proxy++tproxy :: Proxy T.Text+tproxy = Proxy++tlproxy :: Proxy TL.Text+tlproxy = Proxy++----------------------------------------------------------------------------+-- Arbitrary instances++instance Arbitrary Void where+ arbitrary = error "Arbitrary Void"++instance Arbitrary Pos where+ arbitrary = mkPos <$> (getSmall . getPositive <$> arbitrary)++instance Arbitrary SourcePos where+ 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 ]++instance Arbitrary (ErrorFancy a) where+ 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 s => Arbitrary (State s) where+ arbitrary = do+ input <- scaleDown arbitrary+ offset <- choose (1, 10000)+ pstate :: PosState s <- arbitrary+ return State+ { stateInput = input+ , stateOffset = offset+ , statePosState = pstate+ { pstateInput = input+ , pstateOffset = offset+ }+ }++instance Arbitrary s => Arbitrary (PosState s) where+ arbitrary = PosState+ <$> arbitrary+ <*> choose (1, 10000)+ <*> arbitrary+ <*> (mkPos <$> choose (1, 20))+ <*> scaleDown arbitrary++instance Arbitrary T.Text where+ arbitrary = T.pack <$> arbitrary++instance Arbitrary TL.Text where+ arbitrary = TL.pack <$> arbitrary++instance Arbitrary B.ByteString where+ arbitrary = B.pack <$> arbitrary++instance Arbitrary BL.ByteString where+ arbitrary = BL.pack <$> arbitrary++#if MIN_VERSION_QuickCheck(2,10,0)+instance Arbitrary a => Arbitrary (NonEmpty a) where+ arbitrary = NE.fromList <$> (arbitrary `suchThat` (not . null))+#endif
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/Text/Megaparsec/Byte/LexerSpec.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Megaparsec.Byte.LexerSpec (spec) where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.Char (intToDigit, toUpper)+import Data.Monoid ((<>))+import Data.Scientific (Scientific, fromFloatDigits)+import Data.Void+import Data.Word (Word8)+import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt)+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.QuickCheck+import Text.Megaparsec+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++type Parser = Parsec Void ByteString++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 `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 `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 `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+ s = " /* foo bar /* baz */ quux */ "+ prs p s `shouldParse` ()+ prs' p s `succeedsLeaving` ""++ describe "decimal" $ do+ context "when stream begins with decimal digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = decimal :: Parser Integer+ n = getNonNegative n'+ s = B8.pack (showInt 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (decimal :: Parser Integer) "" `shouldFailWith`+ err 0 (ueof <> elabel "integer")++ describe "binary" $ do+ context "when stream begins with binary digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = binary :: Parser Integer+ n = getNonNegative n'+ s = B8.pack (showIntAtBase 2 intToDigit 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (binary :: Parser Integer) "" `shouldFailWith`+ err 0 (ueof <> elabel "binary integer")++ describe "octal" $ do+ context "when stream begins with octal digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = octal :: Parser Integer+ n = getNonNegative n'+ s = B8.pack (showOct 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (octal :: Parser Integer) "" `shouldFailWith`+ err 0 (ueof <> elabel "octal integer")++ describe "hexadecimal" $ do+ context "when stream begins with hexadecimal digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = hexadecimal :: Parser Integer+ n = getNonNegative n'+ s = B8.pack (showHex 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" $+ property $ \n' -> do+ let p = hexadecimal :: Parser Integer+ n = getNonNegative n'+ s = B8.pack (toUpper <$> showHex 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ 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))+ prs p s `shouldParse` case n' of+ Left x -> fromIntegral (getNonNegative x)+ Right x -> fromFloatDigits (getNonNegative x)+ prs' p s `succeedsLeaving` ""+ context "when fractional part is interrupted" $+ it "signals correct parse error" $+ 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 `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 `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 `succeedsLeaving` "err!"+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (scientific :: Parser Scientific) "" `shouldFailWith`+ err 0 (ueof <> elabel "digit")++ describe "float" $ do+ context "when stream begins with a float" $+ it "parses it" $+ property $ \n' -> do+ let p = float :: Parser Double+ n = getNonNegative n'+ s = B8.pack (show 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+ 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 `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 `succeedsLeaving` "err!"+ context "when stream is empty" $+ it "signals correct parse error" $+ 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` ""++ describe "signed" $ do+ context "with integer" $+ it "parses signed integers" $+ property $ \n -> do+ let p :: Parser Integer+ p = signed (hidden B.space) decimal+ s = B8.pack (show n)+ prs p s `shouldParse` n+ prs' p s `succeedsLeaving` ""+ context "with float" $+ it "parses signed floats" $+ property $ \n -> do+ let p :: Parser Double+ p = signed (hidden B.space) float+ s = B8.pack (show n)+ prs p s `shouldParse` n+ prs' p s `succeedsLeaving` ""+ context "with scientific" $+ it "parses singed scientific numbers" $+ property $ \n -> do+ 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+ Right x -> fromFloatDigits x+ context "when number is prefixed with plus sign" $+ it "parses the number" $+ property $ \n' -> do+ let p :: Parser Integer+ p = signed (hidden B.space) decimal+ n = getNonNegative n'+ s = B8.pack ('+' : show n)+ prs p s `shouldParse` n+ prs' p s `succeedsLeaving` ""+ context "when number is prefixed with white space" $+ it "signals correct parse error" $+ property $ \n -> do+ 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 `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 `succeedsLeaving` ""++----------------------------------------------------------------------------+-- Helpers++prs+ :: Parser a+ -- ^ Parser to run+ -> ByteString+ -- ^ Input for the parser+ -> Either (ParseErrorBundle ByteString Void) a+ -- ^ Result of parsing+prs p = parse p ""++prs'+ :: Parser a+ -- ^ Parser to run+ -> ByteString+ -- ^ Input for the parser+ -> (State ByteString, Either (ParseErrorBundle ByteString Void) a)+ -- ^ Result of parsing+prs' p s = runParser' p (initialState s)++isDigit :: Word8 -> Bool+isDigit w = w - 48 < 10++isOctDigit :: Word8 -> Bool+isOctDigit w = w - 48 < 8++isHexDigit :: Word8 -> Bool+isHexDigit w =+ (w >= 48 && w <= 57) ||+ (w >= 97 && w <= 102) ||+ (w >= 65 && w <= 70)
+ tests/Text/Megaparsec/ByteSpec.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Megaparsec.ByteSpec (spec) where++import Control.Monad+import Data.ByteString (ByteString)+import Data.Char+import Data.Maybe (fromMaybe)+import Data.Semigroup ((<>))+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.QuickCheck+import Text.Megaparsec+import Text.Megaparsec.Byte+import qualified Data.ByteString as B++type Parser = Parsec Void ByteString++spec :: Spec+spec = do++ describe "newline" $+ checkStrLit "newline" "\n" (tokenToChunk bproxy <$> newline)++ describe "csrf" $+ checkStrLit "crlf newline" "\r\n" crlf++ describe "eol" $ do+ context "when stream begins with a newline" $+ it "succeeds returning the newline" $+ property $ \s -> do+ let s' = "\n" <> s+ 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' `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")+ context "when input stream is '\\r'" $+ it "signals correct parse error" $+ 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs eol "" `shouldFailWith` err 0+ (ueof <> elabel "end of line")++ describe "tab" $+ checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab)++ describe "space" $+ it "consumes space up to first non-space character" $+ property $ \s' -> do+ let (s0,s1) = B.partition isSpace' s'+ s = s0 <> s1+ prs space s `shouldParse` ()+ prs' space 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+ 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'+ s = " " <> s0 <> s1+ 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 "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++ describe "printChar" $+ checkCharPred "printable character" (isPrint . toChar) printChar++ describe "digitChar" $+ checkCharRange "digit" [48..57] digitChar++ describe "binDigitChar" $+ checkCharRange "binary digit" [48..49] binDigitChar++ describe "octDigitChar" $+ checkCharRange "octal digit" [48..55] octDigitChar++ describe "hexDigitChar" $+ checkCharRange "hexadecimal digit" ([48..57] ++ [97..102] ++ [65..70]) hexDigitChar++ describe "char'" $ do+ context "when stream begins with the character specified as argument" $+ it "parses the character" $+ property $ \ch s -> do+ 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 `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'+ 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++----------------------------------------------------------------------------+-- Helpers++checkStrLit :: String -> ByteString -> Parser ByteString -> SpecWith ()+checkStrLit name ts p = do+ context ("when stream begins with " ++ name) $+ it ("parses the " ++ name) $+ property $ \s -> do+ let s' = ts <> s+ 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'+ context "when stream is empty" $+ it "signals correct parse error" $+ prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)++checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith ()+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+ 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'+ context "when stream is empty" $+ it "signals correct parse error" $+ prs p "" `shouldFailWith` err 0 (ueof <> elabel name)++checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith ()+checkCharRange name tchs p = do+ forM_ tchs $ \tch ->+ context ("when stream begins with " ++ showTokens bproxy (nes tch)) $+ it ("parses the " ++ showTokens bproxy (nes tch)) $+ property $ \s -> do+ let s' = B.singleton tch <> s+ 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 p = parse p ""++prs'+ :: Parser a+ -- ^ Parser to run+ -> ByteString+ -- ^ Input for the parser+ -> (State ByteString, Either (ParseErrorBundle ByteString Void) a)+ -- ^ Result of parsing+prs' p s = runParser' p (initialState s)++-- | 'Word8'-specialized version of 'isSpace'.++isSpace' :: Word8 -> Bool+isSpace' x+ | x >= 9 && x <= 13 = 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
+ tests/Text/Megaparsec/Char/LexerSpec.hs view
@@ -0,0 +1,567 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module Text.Megaparsec.Char.LexerSpec (spec) where++import Control.Monad+import Data.Char hiding (ord)+import Data.List (isInfixOf)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Scientific (Scientific, fromFloatDigits)+import Data.Void (Void)+import Numeric (showInt, showIntAtBase, showHex, showOct, showFFloatAlt)+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++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` ""++ 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` ""++ 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` ""++ 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 `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 `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 `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+ s = " /* foo bar /* baz */ quux */ "+ prs p s `shouldParse` ()+ prs' p s `succeedsLeaving` ""++ describe "indentLevel" $+ it "returns current indentation level (column)" $+ property $ \s w o -> do+ let p = do+ setTabWidth w+ setOffset o+ indentLevel+ c = sourceColumn (strSourcePos w (initialPos "") (take o s))+ prs p s `shouldParse` c+ prs' p s `succeedsLeaving` s++ describe "incorrectIndent" $+ it "signals correct parse error" $+ property $ \ord ref actual -> do+ let p :: Parser ()+ p = incorrectIndent ord ref actual+ prs p "" `shouldFailWith` errFancy 0 (ii ord ref actual)++ describe "indentGuard" $+ it "works as intended" $+ property $ \n -> do+ let mki = mkIndent sbla (getSmall $ getNonNegative n)+ forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do+ let (col0, col1, col2) = (getCol l0, getCol l1, getCol 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+ 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` ()++ 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))++ describe "indentBlock" $ do+ it "works as indented" $+ property $ \mn'' -> do+ let mkBlock = do+ l0 <- mkIndent sbla 0+ l1 <- mkIndent sblb ib+ l2 <- mkIndent sblc (ib + 2)+ l3 <- mkIndent sblb ib+ l4 <- mkIndent' sblc (ib + 2)+ 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+ let (col0, col1, col2, col3, col4) =+ (getCol l0, getCol l1, getCol l2, getCol l3, getCol 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+ 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])])+ 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` ""+ 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` ""+ it "IndentMany works as intended (whitespace aligned precisely to the ref level)" $ do+ 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])+ 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` ""+ 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+ lvlb = symbol sc sblb+ l x = return . (x,)+ prs p s `shouldFailWith` errFancy 6+ (fancy $ ErrorIndentation EQ (mkPos 5) (mkPos 3))++ describe "lineFold" $+ it "works as intended" $+ property $ do+ let mkFold = do+ l0 <- mkInterspace sbla 0+ l1 <- mkInterspace sblb 1+ l2 <- mkInterspace sblc 1+ 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]+ 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)++ describe "charLiteral" $ do+ let p = charLiteral+ context "when stream begins with a literal character" $+ it "parses it" $+ property $ \ch -> do+ let s = showLitChar 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+ context "when stream is empty" $+ it "signals correct parse error" $+ prs p "" `shouldFailWith` err 0 (ueof <> elabel "literal character")+ context "when given a long escape sequence" $+ it "parses it correctly" $+ property $ \s' -> do+ let s = "\\1114111\\&" ++ s'+ prs p s `shouldParse` '\1114111'+ prs' p s `succeedsLeaving` s'++ describe "decimal" $ do+ context "when stream begins with decimal digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = decimal :: Parser Integer+ n = getNonNegative n'+ s = showInt 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (decimal :: Parser Integer) "" `shouldFailWith`+ err 0 (ueof <> elabel "integer")++ describe "binary" $ do+ context "when stream begins with binary digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = binary :: Parser Integer+ n = getNonNegative n'+ s = showIntAtBase 2 intToDigit 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (binary :: Parser Integer) "" `shouldFailWith`+ err 0 (ueof <> elabel "binary integer")++ describe "octal" $ do+ context "when stream begins with octal digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = octal :: Parser Integer+ n = getNonNegative n'+ s = showOct 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (octal :: Parser Integer) "" `shouldFailWith`+ err 0 (ueof <> elabel "octal integer")++ describe "hexadecimal" $ do+ context "when stream begins with hexadecimal digits" $+ it "they are parsed as an integer" $+ property $ \n' -> do+ let p = hexadecimal :: Parser Integer+ n = getNonNegative n'+ s = showHex 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ 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))+ prs p s `shouldParse` case n' of+ Left x -> fromIntegral (getNonNegative x)+ Right x -> fromFloatDigits (getNonNegative x)+ prs' p s `succeedsLeaving` ""+ context "when fractional part is interrupted" $+ it "signals correct parse error" $+ 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 `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 `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 `succeedsLeaving` "err!"+ context "when stream is empty" $+ it "signals correct parse error" $+ prs (scientific :: Parser Scientific) "" `shouldFailWith`+ err 0 (ueof <> elabel "digit")++ describe "float" $ do+ context "when stream begins with a float" $+ it "parses it" $+ property $ \n' -> do+ let p = float :: Parser Double+ n = getNonNegative n'+ s = show 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+ 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 `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 `succeedsLeaving` "err!"+ context "when stream is empty" $+ it "signals correct parse error" $+ 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` ""++ describe "signed" $ do+ context "with integer" $+ it "parses signed integers" $+ property $ \n -> do+ let p :: Parser Integer+ p = signed (hidden C.space) decimal+ s = show n+ prs p s `shouldParse` n+ prs' p s `succeedsLeaving` ""+ context "with float" $+ it "parses signed floats" $+ property $ \n -> do+ let p :: Parser Double+ p = signed (hidden C.space) float+ s = show n+ prs p s `shouldParse` n+ prs' p s `succeedsLeaving` ""+ context "with scientific" $+ it "parses singed scientific numbers" $+ property $ \n -> do+ 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+ Right x -> fromFloatDigits x+ context "when number is prefixed with plus sign" $+ it "parses the number" $+ property $ \n' -> do+ let p :: Parser Integer+ p = signed (hidden C.space) decimal+ n = getNonNegative n'+ s = '+' : show n+ prs p s `shouldParse` n+ prs' p s `succeedsLeaving` ""+ context "when number is prefixed with white space" $+ it "signals correct parse error" $+ property $ \n -> do+ 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 `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 `succeedsLeaving` ""++----------------------------------------------------------------------------+-- Helpers++mkWhiteSpace :: Gen String+mkWhiteSpace = concat <$> listOf whiteUnit+ where+ whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]++mkWhiteSpaceNl :: Gen String+mkWhiteSpaceNl = (<>) <$> mkWhiteSpace <*> pure "\n"++mkSymbol :: Gen String+mkSymbol = (++) <$> symbolName <*> whiteChars++mkInterspace :: String -> Int -> Gen String+mkInterspace x n = oneof [si, mkIndent x n]+ where+ si = (++ x) <$> listOf (elements " \t")++mkIndent :: String -> Int -> Gen String+mkIndent x n = (++) <$> mkIndent' x n <*> eol+ where+ eol = frequency [(5, return "\n"), (1, (scaleDown . listOf1 . return) '\n')]++mkIndent' :: String -> Int -> Gen String+mkIndent' x n = concat <$> sequence [spc, sym, tra]+ where+ spc = frequency [(5, vectorOf n itm), (1, scaleDown (listOf itm))]+ tra = scaleDown (listOf itm)+ itm = elements " \t"+ sym = return x++whiteChars :: Gen String+whiteChars = scaleDown $ listOf (elements "\t\n ")++whiteLine :: Gen String+whiteLine = commentOut <$> arbitrary `suchThat` goodEnough+ where+ commentOut x = "//" ++ x ++ "\n"+ goodEnough x = '\n' `notElem` x++whiteBlock :: Gen String+whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough+ where+ commentOut x = "/*" ++ x ++ "*/"+ goodEnough x = not $ "*/" `isInfixOf` x++symbolName :: Gen String+symbolName = listOf $ arbitrary `suchThat` isAlphaNum++sc :: Parser ()+sc = space (void $ takeWhile1P Nothing f) empty empty+ where+ f x = x == ' ' || x == '\t'++scn :: Parser ()+scn = space C.space1 l b+ where+ l = skipLineComment "//"+ b = skipBlockComment "/*" "*/"++getIndent :: String -> Int+getIndent = length . takeWhile isSpace++getCol :: String -> Pos+getCol x = sourceColumn .+ strSourcePos defaultTabWidth (initialPos "") $ takeWhile isSpace x++sbla, sblb, sblc :: String+sbla = "aaa"+sblb = "bbb"+sblc = "ccc"++ii :: Ordering -> Pos -> Pos -> EF Void+ii ord ref actual = fancy (ErrorIndentation ord ref actual)
+ tests/Text/Megaparsec/CharSpec.hs view
@@ -0,0 +1,344 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS -fno-warn-orphans #-}++module Text.Megaparsec.CharSpec (spec) where++import Control.Monad+import Data.Char+import Data.List (nub, partition, isPrefixOf)+import Data.Monoid ((<>))+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++instance Arbitrary GeneralCategory where+ arbitrary = elements [minBound..maxBound]++spec :: Spec+spec = do++ describe "newline" $+ checkStrLit "newline" "\n" (pure <$> newline)++ describe "csrf" $+ checkStrLit "crlf newline" "\r\n" crlf++ describe "eol" $ do+ context "when stream begins with a newline" $+ it "succeeds returning the newline" $+ property $ \s -> do+ let s' = '\n' : s+ 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' `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")+ context "when input stream is '\\r'" $+ it "signals correct parse error" $+ 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")+ context "when stream is empty" $+ it "signals correct parse error" $+ prs eol "" `shouldFailWith` err 0+ (ueof <> elabel "end of line")++ describe "tab" $+ checkStrLit "tab" "\t" (pure <$> tab)++ describe "space" $+ it "consumes space up to first non-space character" $+ property $ \s' -> do+ let (s0,s1) = partition isSpace s'+ s = s0 ++ s1+ prs space s `shouldParse` ()+ prs' space 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+ 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'+ s = ' ' : s0 ++ s1+ 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 "controlChar" $+ checkCharPred "control character" isControl controlChar++ describe "spaceChar" $+ checkCharRange "white space" " \160\t\n\r\f\v" spaceChar++ describe "upperChar" $+ checkCharPred "uppercase letter" isUpper upperChar++ describe "lowerChar" $+ checkCharPred "lowercase letter" isLower lowerChar++ 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++ describe "binDigitChar" $+ checkCharRange "binary digit" ['0'..'1'] binDigitChar++ describe "octDigitChar" $+ checkCharRange "octal digit" ['0'..'7'] octDigitChar++ describe "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++ describe "punctuationChar" $+ checkCharPred "punctuation" isPunctuation punctuationChar++ describe "symbolChar" $+ checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar+ describe "separatorChar" $+ checkCharRange "separator" " \160" separatorChar++ describe "asciiChar" $+ checkCharPred "ASCII character" isAscii asciiChar++ 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+ 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` "в"+ context "when stream is empty" $+ it "signals correct parse error" $+ prs latin1Char "" `shouldFailWith` err 0 (ueof <> elabel "Latin-1 character")++ describe "charCategory" $ do+ context "when parser corresponding to general category of next char is used" $+ it "succeeds" $+ property $ \ch s -> do+ let s' = ch : s+ 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'+ context "when stream is empty" $+ it "signals correct parse error" $+ property $ \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' `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'+ context "when stream is empty" $+ it "signals correct parse error" $+ property $ \ch ->+ prs (char ch) "" `shouldFailWith` err 0 (ueof <> etok ch)++ describe "char'" $ do+ context "when stream begins with the character specified as argument" $ do+ it "parses the character" $+ property $ \ch s -> do+ 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 `succeedsLeaving` s+ prs' (char' ch) su `succeedsLeaving` s+ context "when the character is not upper or lower" $+ -- See https://ghc.haskell.org/trac/ghc/ticket/14589+ it "matches it against a form obtained via one of the conversion functions" $+ property $ \s -> do+ let ch = '\9438'+ s' = '\9412' : s+ prs (char' ch) s' `shouldParse` '\9412'+ 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'+ 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+ 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++ 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' `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)++ describe "string'" $ do+ context "when stream is prefixed with given string" $+ it "parses the string" $+ property $ \str s ->+ forAll (fuzzyCase str) $ \str' -> do+ 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' `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)++----------------------------------------------------------------------------+-- Helpers++checkStrLit :: String -> String -> Parser String -> SpecWith ()+checkStrLit name ts p = do+ context ("when stream begins with " ++ name) $+ it ("parses the " ++ name) $+ property $ \s -> do+ let s' = ts ++ s+ 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'+ context "when stream is empty" $+ it "signals correct parse error" $+ prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)++checkCharPred :: String -> (Char -> Bool) -> Parser Char -> SpecWith ()+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+ 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'+ context "when stream is empty" $+ it "signals correct parse error" $+ prs p "" `shouldFailWith` err 0 (ueof <> elabel name)++checkCharRange :: String -> String -> Parser Char -> SpecWith ()+checkCharRange name tchs p = do+ forM_ tchs $ \tch ->+ context ("when stream begins with " ++ showTokens sproxy (nes tch)) $+ it ("parses the " ++ showTokens sproxy (nes tch)) $+ property $ \s -> do+ let s' = tch : s+ 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 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++-- | Case-insensitive equality test for characters.++casei :: Char -> Char -> Bool+casei x y =+ x == toLower y ||+ x == toUpper y ||+ x == toTitle y
+ tests/Text/Megaparsec/DebugSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Text.Megaparsec.DebugSpec+ ( spec )+where++import Control.Monad+import Data.Monoid ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Debug++spec :: Spec+spec = do++ describe "dbg" $ do+ -- NOTE We don't test properties here to avoid flood of debugging output+ -- when the test runs.+ context "when inner parser succeeds consuming input" $ do+ it "has no effect on how parser works" $ do+ let p = dbg "char" (char 'a')+ s = "ab"+ prs p s `shouldParse` 'a'+ prs' p s `succeedsLeaving` "b"+ it "its hints are preserved" $ do+ let p = dbg "many chars" (many (char 'a')) <* empty+ s = "abcd"+ prs p s `shouldFailWith` err 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 `failsLeaving` "bc"+ context "when inner parser succeeds without consuming" $ do+ it "has no effect on how parser works" $ do+ let p = dbg "return" (return 'a')+ s = "abc"+ prs p s `shouldParse` 'a'+ prs' p s `succeedsLeaving` s+ it "its hints are preserved" $ do+ let p = dbg "many chars" (many (char 'a')) <* empty+ s = "bcd"+ prs p s `shouldFailWith` err 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 `failsLeaving` s
+ tests/Text/Megaparsec/ErrorSpec.hs view
@@ -0,0 +1,280 @@+{-# 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.NonEmpty (NonEmpty (..))+import Data.Void+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc ()+import Test.QuickCheck+import Text.Megaparsec+import qualified Data.Semigroup as S+import qualified Data.Set as E++#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++spec :: Spec+spec = do++ describe "Semigroup instance of ParseError" $+ it "associativity" $+ property $ \x y z ->+ (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE)++ describe "Monoid instance of ParseError" $ do+ it "left identity" $+ property $ \x ->+ mempty <> x === (x :: PE)+ it "right identity" $+ property $ \x ->+ x <> mempty === (x :: PE)+ it "associativity" $+ property $ \x y z ->+ (x <> y) <> z === (x <> (y <> z) :: PE)++ describe "error merging with (<>)" $ do+ it "selects greater offset" $+ 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)+ 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)+ 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)+ it "fancy has precedence (right)" $+ property $ \pos us ps xs ->+ TrivialError pos us ps <> FancyError pos xs `shouldBe`+ (FancyError pos xs :: PE)++ describe "errorOffset" $+ it "returns error position" $+ property $ \e ->+ errorOffset e `shouldBe`+ (case e :: PE of+ TrivialError o _ _ -> o+ FancyError o _ -> o)++ describe "attachSourcePos" $+ it "attaches the positions correctly" $+ property $ \xs' s -> do+ let xs = sort $ getSmall . getPositive <$> xs'+ pst = initialPosState (s :: String)+ pst' =+ if null xs+ then pst+ else snd $ reachOffsetNoLine (last xs) pst+ rs = f <$> xs+ f x = (x, fst (reachOffsetNoLine x pst))+ attachSourcePos id (xs :: [Int]) pst `shouldBe` (rs, pst')++ describe "errorBundlePretty" $ do+ it "shows empty line correctly" $ do+ let s = "" :: String+ mkBundlePE s (mempty :: PE) `shouldBe`+ "1:1:\n |\n1 | <empty line>\n | ^\nunknown parse error\n"+ 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"+ 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"+ 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"+ 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"+ 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"+ 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"+ 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"+ context "stream of insufficient size is provided in the bundle" $+ it "handles the situation reasonably" $ do+ let s = "" :: String+ pe = err 3 (ueof <> etok 'x') :: PE+ mkBundlePE s pe `shouldBe`+ "1:1:\n |\n1 | <empty line>\n | ^\nunexpected end of input\nexpecting 'x'\n"+ 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"+ 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 "takes tab width into account correctly" $+ property $ \w' -> do+ 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 = ""+ }+ }+ 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")+ 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 = ""+ }+ }+ 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" $+ parseErrorPretty (mempty :: PE) `shouldBe` "offset=0:\nunknown parse error\n"+ it "result always ends with a newline" $+ property $ \x ->+ parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)+ it "result contains representation of offset" $+ property (contains (Identity . errorOffset) show)+ it "result contains unexpected/expected items" $ do+ let e = err 0 (utoks "foo" <> etoks "bar" <> etoks "baz") :: PE+ parseErrorPretty e `shouldBe` "offset=0:\nunexpected \"foo\"\nexpecting \"bar\" or \"baz\"\n"+ it "result contains representation of custom items" $ do+ let e = errFancy 0 (fancy (ErrorFail "Ooops!")) :: PE+ 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")+ parseErrorPretty pe `shouldBe` "offset=0:\nbar\nfoo\n"++ describe "parseErrorTextPretty" $ do+ it "shows trivial unknown ParseError correctly" $+ parseErrorTextPretty (mempty :: PE)+ `shouldBe` "unknown parse error\n"+ it "shows fancy unknown ParseError correctly" $+ parseErrorTextPretty (FancyError 0 E.empty :: PE)+ `shouldBe` "unknown fancy parse error\n"+ it "result always ends with a newline" $+ property $ \x ->+ parseErrorTextPretty (x :: PE)+ `shouldSatisfy` ("\n" `isSuffixOf`)++ describe "displayException" $+ it "produces the same result as parseErrorPretty" $+ property $ \x ->+ displayException x `shouldBe` parseErrorPretty (x :: PE)++----------------------------------------------------------------------------+-- Helpers++-- | Custom error component to test continuous highlighting for custom+-- components.++newtype CustomErr = CustomErr Int+ deriving (Eq, Ord, Show)++instance ShowErrorComponent CustomErr where+ showErrorComponent _ = "custom thing"+ errorComponentLen (CustomErr n) = n++type PE = ParseError String Void++contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property+contains g r e = property (all f (g e))+ where+ 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 = ""+ }+ }
+ tests/Text/Megaparsec/PosSpec.hs view
@@ -0,0 +1,63 @@+module Text.Megaparsec.PosSpec (spec) where++import Control.Exception (evaluate)+import Data.Function (on)+import Data.List (isInfixOf)+import Data.Semigroup ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec.AdHoc ()+import Test.QuickCheck+import Text.Megaparsec.Pos++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)+ context "when the argument is not 0" $+ it "returns Pos with the given value" $+ property $ \n ->+ (n > 0) ==> (unPos (mkPos n) `shouldBe` n)++ describe "Read and Show instances of Pos" $+ it "printed representation of Pos is isomorphic to its value" $+ property $ \x ->+ read (show x) === (x :: Pos)++ describe "Ord instance of Pos" $+ it "works just like Ord instance of underlying Word" $+ property $ \x y ->+ compare x y === (compare `on` unPos) x y++ 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++ 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++ describe "Read and Show instances of SourcePos" $+ it "printed representation of SourcePos in isomorphic to its value" $+ property $ \x ->+ read (show x) === (x :: SourcePos)++ describe "sourcePosPretty" $ do+ it "displays file name" $+ property $ \x ->+ sourceName x `isInfixOf` sourcePosPretty x+ it "displays line number" $+ property $ \x ->+ (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x+ it "displays column number" $+ property $ \x ->+ (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x
+ tests/Text/Megaparsec/StreamSpec.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Text.Megaparsec.StreamSpec (spec) where++import Control.Monad+import Data.Char (isLetter, chr, isControl, isSpace)+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy+import Data.Semigroup ((<>))+import Data.String (IsString)+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++spec :: Spec+spec = do++ describe "String instance of Stream" $ do+ describe "tokenToChunk" $+ it "produces the same result as singleton with tokensToChunk" $+ property $ \ch ->+ tokenToChunk sproxy ch === tokensToChunk sproxy [ch]+ describe "tokensToChunk" $+ it "list of tokens is isomorphic to chunk" $+ property $ \ts ->+ chunkToTokens sproxy (tokensToChunk sproxy ts) === ts+ describe "chunkToTokens" $+ it "chunk is isomorphic to list of tokens" $+ property $ \chk ->+ tokensToChunk sproxy (chunkToTokens sproxy chk) === chk+ describe "chunkLength" $+ it "returns correct length of given chunk" $+ property $ \chk ->+ chunkLength sproxy chk === length chk+ describe "chunkEmpty" $+ it "only true when chunkLength returns 0" $+ property $ \chk ->+ chunkEmpty sproxy chk === (chunkLength sproxy chk <= 0)+ describe "take1_" $ do+ context "when input in empty" $+ it "returns Nothing" $+ 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)+ describe "takeN_" $ do+ context "requested length is 0" $+ it "returns Just empty chunk and original stream" $+ property $ \s ->+ takeN_ 0 (s :: String) === Just ("", s)+ context "requested length is greater than 0" $ do+ context "stream is empty" $+ it "returns Nothing" $+ property $ \(Positive n) ->+ 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)+ describe "takeWhile_" $+ it "extracts a chunk that is a prefix consisting of matching tokens" $+ property $ \s ->+ takeWhile_ isLetter s === span isLetter s+ describeShowTokens sproxy quotedCharGen+ describeReachOffset sproxy+ describeReachOffsetNoLine sproxy++ describe "ByteString instance of Stream" $ do+ describe "tokenToChunk" $+ it "produces the same result as singleton with tokensToChunk" $+ property $ \ch ->+ tokenToChunk bproxy ch === tokensToChunk bproxy [ch]+ describe "tokensToChunk" $+ it "list of tokens is isomorphic to chunk" $+ property $ \ts ->+ chunkToTokens bproxy (tokensToChunk bproxy ts) === ts+ describe "chunkToTokens" $+ it "chunk is isomorphic to list of tokens" $+ property $ \chk ->+ tokensToChunk bproxy (chunkToTokens bproxy chk) === chk+ describe "chunkLength" $+ it "returns correct length of given chunk" $+ property $ \chk ->+ chunkLength bproxy chk === B.length chk+ describe "chunkEmpty" $+ it "only true when chunkLength returns 0" $+ property $ \chk ->+ chunkEmpty bproxy chk === (chunkLength bproxy chk <= 0)+ describe "take1_" $ do+ context "when input in empty" $+ it "returns Nothing" $+ 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+ describe "takeN_" $ do+ context "requested length is 0" $+ it "returns Just empty chunk and original stream" $+ property $ \s ->+ takeN_ 0 (s :: B.ByteString) === Just ("", s)+ context "requested length is greater than 0" $ do+ context "stream is empty" $+ it "returns Nothing" $+ property $ \(Positive n) ->+ 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)+ 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+ describeShowTokens bproxy quotedWordGen+ describeReachOffset bproxy+ describeReachOffsetNoLine bproxy++ describe "Lazy ByteString instance of Stream" $ do+ describe "tokenToChunk" $+ it "produces the same result as singleton with tokensToChunk" $+ property $ \ch ->+ tokenToChunk blproxy ch === tokensToChunk blproxy [ch]+ describe "tokensToChunk" $+ it "list of tokens is isomorphic to chunk" $+ property $ \ts ->+ chunkToTokens blproxy (tokensToChunk blproxy ts) === ts+ describe "chunkToTokens" $+ it "chunk is isomorphic to list of tokens" $+ property $ \chk ->+ tokensToChunk blproxy (chunkToTokens blproxy chk) === chk+ describe "chunkLength" $+ it "returns correct length of given chunk" $+ property $ \chk ->+ chunkLength blproxy chk === fromIntegral (BL.length chk)+ describe "chunkEmpty" $+ it "only true when chunkLength returns 0" $+ property $ \chk ->+ chunkEmpty blproxy chk === (chunkLength blproxy chk <= 0)+ describe "take1_" $ do+ context "when input in empty" $+ it "returns Nothing" $+ 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+ describe "takeN_" $ do+ context "requested length is 0" $+ it "returns Just empty chunk and original stream" $+ property $ \s ->+ takeN_ 0 (s :: BL.ByteString) === Just ("", s)+ context "requested length is greater than 0" $ do+ context "stream is empty" $+ it "returns Nothing" $+ property $ \(Positive n) ->+ 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)+ 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+ describeShowTokens blproxy quotedWordGen+ describeReachOffset blproxy+ describeReachOffsetNoLine blproxy++ describe "Text instance of Stream" $ do+ describe "tokenToChunk" $+ it "produces the same result as singleton with tokensToChunk" $+ property $ \ch ->+ tokenToChunk tproxy ch === tokensToChunk tproxy [ch]+ describe "tokensToChunk" $+ it "list of tokens is isomorphic to chunk" $+ property $ \ts ->+ chunkToTokens tproxy (tokensToChunk tproxy ts) === ts+ describe "chunkToTokens" $+ it "chunk is isomorphic to list of tokens" $+ property $ \chk ->+ tokensToChunk tproxy (chunkToTokens tproxy chk) === chk+ describe "chunkLength" $+ it "returns correct length of given chunk" $+ property $ \chk ->+ chunkLength tproxy chk === T.length chk+ describe "chunkEmpty" $+ it "only true when chunkLength returns 0" $+ property $ \chk ->+ chunkEmpty tproxy chk === (chunkLength tproxy chk <= 0)+ describe "take1_" $ do+ context "when input in empty" $+ it "returns Nothing" $+ 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+ describe "takeN_" $ do+ context "requested length is 0" $+ it "returns Just empty chunk and original stream" $+ property $ \s ->+ takeN_ 0 (s :: T.Text) === Just ("", s)+ context "requested length is greater than 0" $ do+ context "stream is empty" $+ it "returns Nothing" $+ property $ \(Positive n) ->+ 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)+ describe "takeWhile_" $+ it "extracts a chunk that is a prefix consisting of matching tokens" $+ property $ \s ->+ takeWhile_ isLetter s === T.span isLetter s+ describeShowTokens tproxy quotedCharGen+ describeReachOffset tproxy+ describeReachOffsetNoLine tproxy++ describe "Lazy Text instance of Stream" $ do+ describe "tokenToChunk" $+ it "produces the same result as singleton with tokensToChunk" $+ property $ \ch ->+ tokenToChunk tlproxy ch === tokensToChunk tlproxy [ch]+ describe "tokensToChunk" $+ it "list of tokens is isomorphic to chunk" $+ property $ \ts ->+ chunkToTokens tlproxy (tokensToChunk tlproxy ts) === ts+ describe "chunkToTokens" $+ it "chunk is isomorphic to list of tokens" $+ property $ \chk ->+ tokensToChunk tlproxy (chunkToTokens tlproxy chk) === chk+ describe "chunkLength" $+ it "returns correct length of given chunk" $+ property $ \chk ->+ chunkLength tlproxy chk === fromIntegral (TL.length chk)+ describe "chunkEmpty" $+ it "only true when chunkLength returns 0" $+ property $ \chk ->+ chunkEmpty tlproxy chk === (chunkLength tlproxy chk <= 0)+ describe "take1_" $ do+ context "when input in empty" $+ it "returns Nothing" $+ 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+ describe "takeN_" $ do+ context "requested length is 0" $+ it "returns Just empty chunk and original stream" $+ property $ \s ->+ takeN_ 0 (s :: TL.Text) === Just ("", s)+ context "requested length is greater than 0" $ do+ context "stream is empty" $+ it "returns Nothing" $+ property $ \(Positive n) ->+ 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)+ describe "takeWhile_" $+ it "extracts a chunk that is a prefix consisting of matching tokens" $+ property $ \s ->+ takeWhile_ isLetter s === TL.span isLetter s+ describeShowTokens tlproxy quotedCharGen+ describeReachOffset tlproxy+ describeReachOffsetNoLine tlproxy++----------------------------------------------------------------------------+-- 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 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"+ (f "\r\n" "crlf newline")+ it "shows null byte correctly"+ (f "\NUL" "null")+ it "shows start of heading correctly"+ (f "\SOH" "start of heading")+ it "shows start of text correctly"+ (f "\STX" "start of text")+ it "shows end of text correctly"+ (f "\ETX" "end of text")+ it "shows end of transmission correctly"+ (f "\EOT" "end of transmission")+ it "shows enquiry correctly"+ (f "\ENQ" "enquiry")+ it "shows acknowledge correctly"+ (f "\ACK" "acknowledge")+ it "shows bell correctly"+ (f "\BEL" "bell")+ it "shows backspace correctly"+ (f "\BS" "backspace")+ it "shows tab correctly"+ (f "\t" "tab")+ it "shows newline correctly"+ (f "\n" "newline")+ it "shows vertical tab correctly"+ (f "\v" "vertical tab")+ it "shows form feed correctly"+ (f "\f" "form feed")+ it "shows carriage return correctly"+ (f "\r" "carriage return")+ it "shows shift out correctly"+ (f "\SO" "shift out")+ it "shows shift in correctly"+ (f "\SI" "shift in")+ it "shows data link escape correctly"+ (f "\DLE" "data link escape")+ it "shows device control one correctly"+ (f "\DC1" "device control one")+ it "shows device control two correctly"+ (f "\DC2" "device control two")+ it "shows device control three correctly"+ (f "\DC3" "device control three")+ it "shows device control four correctly"+ (f "\DC4" "device control four")+ it "shows negative acknowledge correctly"+ (f "\NAK" "negative acknowledge")+ it "shows synchronous idle correctly"+ (f "\SYN" "synchronous idle")+ it "shows end of transmission block correctly"+ (f "\ETB" "end of transmission block")+ it "shows cancel correctly"+ (f "\CAN" "cancel")+ it "shows end of medium correctly"+ (f "\EM" "end of medium")+ it "shows substitute correctly"+ (f "\SUB" "substitute")+ 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"+ (f "\DEL" "delete")+ 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` '\''+ 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"+ (f "{\n" "\"{<newline>\"")++-- | Generic block of tests for the 'reachOffset' method.++describeReachOffset+ :: forall s. ( Stream s+ , IsString s+ , Show s+ , Arbitrary s+ )+ => Proxy s -- ^ 'Proxy' that clarifies the type of stream+ -> Spec+describeReachOffset Proxy =+ describe "reachOffset" $ do+ it "returns correct SourcePos (newline)" $+ property $ \pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "\n" :: s+ }+ o = pstateOffset pst + 1+ (r, _, _) = 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+ }+ o = pstateOffset pst + 1+ (r, _, _) = reachOffset o pst+ SourcePos n l c = pstateSourcePos pst+ w = pstateTabWidth pst+ r `shouldBe` SourcePos n l (toNextTab w c)+ it "returns correct SourcePos (other)" $+ property $ \pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "a" :: s+ }+ o = pstateOffset pst + 1+ (r, _, _) = reachOffset o pst+ SourcePos n l c = pstateSourcePos pst+ r `shouldBe` SourcePos n l (c <> pos1)+ it "replaces empty line with <empty line>" $+ property $ \o pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "" :: s+ , pstateLinePrefix = ""+ }+ (_, r, _) = reachOffset o pst+ r `shouldBe` "<empty line>"+ it "replaces tabs with spaces in returned line" $+ property $ \pst' -> do+ 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'+ it "returns correct line (with line prefix)" $+ property $ \pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "foo\nbar\nbaz" :: s+ , pstateLinePrefix = "123"+ }+ (_, r, _) = reachOffset 0 pst+ r `shouldBe` "123foo"+ it "returns correct line (without line prefix)" $+ property $ \pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "foo\nbar\nbaz" :: s+ , pstateOffset = 0+ }+ (_, r, _) = reachOffset 4 pst+ r `shouldBe` "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+ f pst o =+ let (_, _, pst') = reachOffset o 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 Proxy =+ describe "reachOffsetNoLine" $ do+ it "returns correct SourcePos (newline)" $+ property $ \pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "\n" :: s+ }+ o = pstateOffset pst + 1+ (r, _) = 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+ }+ o = pstateOffset pst + 1+ (r, _) = reachOffsetNoLine o pst+ SourcePos n l c = pstateSourcePos pst+ w = pstateTabWidth pst+ r `shouldBe` SourcePos n l (toNextTab w c)+ it "returns correct SourcePos (other)" $+ property $ \pst' -> do+ let pst = (pst' :: PosState s)+ { pstateInput = "a" :: s+ }+ o = pstateOffset pst + 1+ (r, _) = reachOffsetNoLine o pst+ SourcePos n l c = pstateSourcePos pst+ r `shouldBe` SourcePos n l (c <> pos1)+ 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+ f pst o =+ let (_, pst') = reachOffsetNoLine o 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 w' c' = mkPos $ c + w - ((c - 1) `rem` w)+ where+ w = unPos w'+ c = unPos c'++quotedCharGen :: Gen Char+quotedCharGen = arbitrary `suchThat` isQuotedChar++quotedWordGen :: Gen Word8+quotedWordGen = arbitrary `suchThat` (isQuotedChar . toChar)++-- | Return 'True' if the 'Char' should be simply quoted by the 'showTokens'+-- method, i.e. it's not a character with a special representation.++isQuotedChar :: Char -> Bool+isQuotedChar x = not (isControl x) && not (isSpace x)
+ tests/Text/MegaparsecSpec.hs view
@@ -0,0 +1,1651 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# 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.Semigroup as G+import qualified Data.Set as E+import qualified Data.Text as T++#if !MIN_VERSION_QuickCheck(2,8,2)+instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where+ arbitrary = E.fromList <$> arbitrary+ shrink = fmap E.fromList . shrink . E.toList+#endif++spec :: Spec+spec = do++ describe "ParsecT Semigroup instance" $+ it "the associative operation works" $+ property $ \a b -> do+ let p = pure [a] G.<> 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 "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 "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 "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 "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 "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 "region" $ do+ context "when inner parser succeeds" $+ it "has no effect" $+ property $ \st e n -> do+ let p :: Parser Int+ p = region (const e) (pure n)+ runParser' p st `shouldBe` (st, Right (n :: Int))+ context "when inner parser fails" $+ it "the given function is used on the parse error" $+ property $ \st' e o' -> do+ let p :: Parsec Int String Int+ p = region f $+ case e :: ParseError String Int of+ TrivialError _ us ps -> failure us ps+ FancyError _ xs -> fancyFailure xs+ f (TrivialError o us ps) = FancyError+ (max o o')+ (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)+ f (FancyError o xs) = FancyError+ (max o o')+ (E.singleton . ErrorCustom $ E.size xs)+ r = FancyError+ (max (errorOffset e) o')+ (E.singleton . ErrorCustom $+ case e of+ TrivialError _ us ps -> maybe 0 (const 1) us + E.size ps+ FancyError _ xs -> E.size xs )+ finalOffset = max (errorOffset e) o'+ st = st' { stateOffset = errorOffset e }+ runParser' p st `shouldBe`+ ( st { stateOffset = finalOffset }+ , Left (mkBundle st r)+ )++ 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+ (spos, _, pst') = reachOffset (stateOffset st) (statePosState st)+ 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)+ p = do+ st <- getParserState+ guard (st == initialState s)+ setParserState s1+ updateParserState (f s2)+ getParserState <* setInput ""+ f (State s1' o pst) (State s2' _ _) = State (max s1' s2') o pst+ 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+ -> String+ -> (State String, Either (ParseErrorBundle String Void) String)+emulateStrParsing st@(State i o pst) s =+ if s == take l i+ then ( State (drop l i) (o + l) pst+ , Right s )+ else ( st+ , Left (mkBundle st (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 -> ParseError s e -> ParseErrorBundle s e+mkBundle s e = ParseErrorBundle+ { bundleErrors = e :| []+ , bundlePosState = statePosState s+ }++grabTabWidth :: (State a, b) -> Pos+grabTabWidth = pstateTabWidth . statePosState . fst