diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/megaparsec-tests.cabal b/megaparsec-tests.cabal new file mode 100644 --- /dev/null +++ b/megaparsec-tests.cabal @@ -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 +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 diff --git a/src/Test/Hspec/Megaparsec/AdHoc.hs b/src/Test/Hspec/Megaparsec/AdHoc.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Megaparsec/AdHoc.hs @@ -0,0 +1,338 @@ +-- | +-- Module : Test.Hspec.Megaparsec.AdHoc +-- Copyright : © 2019 Megaparsec contributors +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- 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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Text/Megaparsec/Byte/LexerSpec.hs b/tests/Text/Megaparsec/Byte/LexerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/Byte/LexerSpec.hs @@ -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) diff --git a/tests/Text/Megaparsec/ByteSpec.hs b/tests/Text/Megaparsec/ByteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/ByteSpec.hs @@ -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 diff --git a/tests/Text/Megaparsec/Char/LexerSpec.hs b/tests/Text/Megaparsec/Char/LexerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/Char/LexerSpec.hs @@ -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) diff --git a/tests/Text/Megaparsec/CharSpec.hs b/tests/Text/Megaparsec/CharSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/CharSpec.hs @@ -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 diff --git a/tests/Text/Megaparsec/DebugSpec.hs b/tests/Text/Megaparsec/DebugSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/DebugSpec.hs @@ -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 diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/ErrorSpec.hs @@ -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 | \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 | \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 = "" + } + } diff --git a/tests/Text/Megaparsec/PosSpec.hs b/tests/Text/Megaparsec/PosSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/PosSpec.hs @@ -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 diff --git a/tests/Text/Megaparsec/StreamSpec.hs b/tests/Text/Megaparsec/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Megaparsec/StreamSpec.hs @@ -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" "\"{\"") + +-- | 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 " $ + property $ \o pst' -> do + let pst = (pst' :: PosState s) + { pstateInput = "" :: s + , pstateLinePrefix = "" + } + (_, r, _) = reachOffset o pst + r `shouldBe` "" + 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) diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Text/MegaparsecSpec.hs @@ -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