diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2015–2019 Megaparsec contributors +Copyright © 2015–present Megaparsec contributors All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +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. +Megaparsec's test suite as a standalone package. The reason for the +separation 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 +Copyright © 2015–present Megaparsec contributors Distributed under FreeBSD license. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,2 @@ -module Main (main) where - import Distribution.Simple - -main :: IO () main = defaultMain diff --git a/megaparsec-tests.cabal b/megaparsec-tests.cabal --- a/megaparsec-tests.cabal +++ b/megaparsec-tests.cabal @@ -1,7 +1,7 @@ name: megaparsec-tests -version: 7.0.5 +version: 8.0.0 cabal-version: 1.18 -tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 +tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 license: BSD2 license-file: LICENSE.md author: Megaparsec contributors @@ -21,15 +21,15 @@ library hs-source-dirs: src - build-depends: QuickCheck >= 2.7 && < 2.13 - , base >= 4.9 && < 5.0 + build-depends: QuickCheck >= 2.10 && < 2.14 + , base >= 4.11 && < 5.0 , bytestring >= 0.2 && < 0.11 , containers >= 0.5 && < 0.7 , hspec >= 2.0 && < 3.0 , hspec-expectations >= 0.8 && < 0.9 , hspec-megaparsec >= 2.0 && < 3.0 - , megaparsec == 7.0.5 - , mtl >= 2.0 && < 3.0 + , megaparsec == 8.0.0 + , mtl >= 2.2.2 && < 3.0 , text >= 0.2 && < 1.3 , transformers >= 0.4 && < 0.6 exposed-modules: Test.Hspec.Megaparsec.AdHoc @@ -38,7 +38,6 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances else ghc-options: -O2 -Wall default-language: Haskell2010 @@ -60,17 +59,17 @@ , Text.Megaparsec.PosSpec , Text.Megaparsec.StreamSpec , Text.MegaparsecSpec - build-depends: QuickCheck >= 2.7 && < 2.13 - , base >= 4.9 && < 5.0 + build-depends: QuickCheck >= 2.10 && < 2.14 + , base >= 4.11 && < 5.0 , bytestring >= 0.2 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5 && < 0.7 , hspec >= 2.0 && < 3.0 , hspec-expectations >= 0.8 && < 0.9 , hspec-megaparsec >= 2.0 && < 3.0 - , megaparsec == 7.0.5 + , megaparsec == 8.0.0 , megaparsec-tests - , mtl >= 2.0 && < 3.0 + , mtl >= 2.2.2 && < 3.0 , parser-combinators >= 1.0 && < 2.0 , scientific >= 0.3.1 && < 0.4 , text >= 0.2 && < 1.3 diff --git a/src/Test/Hspec/Megaparsec/AdHoc.hs b/src/Test/Hspec/Megaparsec/AdHoc.hs --- a/src/Test/Hspec/Megaparsec/AdHoc.hs +++ b/src/Test/Hspec/Megaparsec/AdHoc.hs @@ -1,6 +1,6 @@ -- | -- Module : Test.Hspec.Megaparsec.AdHoc --- Copyright : © 2019 Megaparsec contributors +-- Copyright : © 2019–present Megaparsec contributors -- License : FreeBSD -- -- Maintainer : Mark Karpov @@ -9,7 +9,6 @@ -- -- Ad-hoc helpers used in Megaparsec's test suite. -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -98,7 +97,7 @@ -- ^ Parser to run -> String -- ^ Input for the parser - -> (State String, Either (ParseErrorBundle String Void) a) + -> (State String Void, Either (ParseErrorBundle String Void) a) -- ^ Result of parsing prs' p s = runParser' p (initialState s) @@ -141,7 +140,7 @@ 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) + -> ((State String Void, Either (ParseErrorBundle String Void) a) -> Expectation) -- ^ How to check result of parsing -> Expectation grs' p s r = do @@ -217,7 +216,7 @@ strSourcePos :: Pos -> SourcePos -> String -> SourcePos strSourcePos tabWidth ipos input = - let (x, _, _) = reachOffset maxBound pstate in x + let (_, pst') = reachOffset maxBound pstate in pstateSourcePos pst' where pstate = PosState { pstateInput = input @@ -298,7 +297,7 @@ <$> (getNonNegative <$> arbitrary) <*> (E.fromList <$> scaleDown arbitrary) ] -instance Arbitrary s => Arbitrary (State s) where +instance Arbitrary s => Arbitrary (State s e) where arbitrary = do input <- scaleDown arbitrary offset <- choose (1, 10000) @@ -310,6 +309,7 @@ { pstateInput = input , pstateOffset = offset } + , stateParseErrors = [] } instance Arbitrary s => Arbitrary (PosState s) where @@ -332,7 +332,5 @@ 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/Text/Megaparsec/Byte/LexerSpec.hs b/tests/Text/Megaparsec/Byte/LexerSpec.hs --- a/tests/Text/Megaparsec/Byte/LexerSpec.hs +++ b/tests/Text/Megaparsec/Byte/LexerSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.Byte.LexerSpec (spec) where @@ -5,7 +6,6 @@ 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) @@ -19,6 +19,10 @@ import qualified Data.ByteString.Char8 as B8 import qualified Text.Megaparsec.Byte as B +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif + type Parser = Parsec Void ByteString spec :: Spec @@ -297,7 +301,7 @@ -- ^ Parser to run -> ByteString -- ^ Input for the parser - -> (State ByteString, Either (ParseErrorBundle ByteString Void) a) + -> (State ByteString Void, Either (ParseErrorBundle ByteString Void) a) -- ^ Result of parsing prs' p s = runParser' p (initialState s) diff --git a/tests/Text/Megaparsec/ByteSpec.hs b/tests/Text/Megaparsec/ByteSpec.hs --- a/tests/Text/Megaparsec/ByteSpec.hs +++ b/tests/Text/Megaparsec/ByteSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.ByteSpec (spec) where @@ -6,7 +7,6 @@ import Data.ByteString (ByteString) import Data.Char import Data.Maybe (fromMaybe) -import Data.Semigroup ((<>)) import Data.Void import Data.Word (Word8) import Test.Hspec @@ -17,6 +17,10 @@ import Text.Megaparsec.Byte import qualified Data.ByteString as B +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif + type Parser = Parsec Void ByteString spec :: Spec @@ -209,7 +213,7 @@ -- ^ Parser to run -> ByteString -- ^ Input for the parser - -> (State ByteString, Either (ParseErrorBundle ByteString Void) a) + -> (State ByteString Void, Either (ParseErrorBundle ByteString Void) a) -- ^ Result of parsing prs' p s = runParser' p (initialState s) diff --git a/tests/Text/Megaparsec/Char/LexerSpec.hs b/tests/Text/Megaparsec/Char/LexerSpec.hs --- a/tests/Text/Megaparsec/Char/LexerSpec.hs +++ b/tests/Text/Megaparsec/Char/LexerSpec.hs @@ -10,7 +10,6 @@ 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) @@ -22,6 +21,10 @@ import Text.Megaparsec.Char.Lexer import qualified Data.CaseInsensitive as CI import qualified Text.Megaparsec.Char as C + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif spec :: Spec spec = do diff --git a/tests/Text/Megaparsec/CharSpec.hs b/tests/Text/Megaparsec/CharSpec.hs --- a/tests/Text/Megaparsec/CharSpec.hs +++ b/tests/Text/Megaparsec/CharSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# OPTIONS -fno-warn-orphans #-} module Text.Megaparsec.CharSpec (spec) where @@ -6,7 +6,6 @@ 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 @@ -14,6 +13,10 @@ import Text.Megaparsec import Text.Megaparsec.Char import qualified Data.CaseInsensitive as CI + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif instance Arbitrary GeneralCategory where arbitrary = elements [minBound..maxBound] diff --git a/tests/Text/Megaparsec/DebugSpec.hs b/tests/Text/Megaparsec/DebugSpec.hs --- a/tests/Text/Megaparsec/DebugSpec.hs +++ b/tests/Text/Megaparsec/DebugSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.DebugSpec @@ -5,13 +6,16 @@ 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 + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif spec :: Spec spec = do diff --git a/tests/Text/Megaparsec/ErrorSpec.hs b/tests/Text/Megaparsec/ErrorSpec.hs --- a/tests/Text/Megaparsec/ErrorSpec.hs +++ b/tests/Text/Megaparsec/ErrorSpec.hs @@ -13,11 +13,10 @@ import Test.Hspec.Megaparsec.AdHoc () import Test.QuickCheck import Text.Megaparsec -import qualified Data.Semigroup as S -import qualified Data.Set as E +import qualified Data.Set as E -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) #endif spec :: Spec @@ -26,7 +25,7 @@ describe "Semigroup instance of ParseError" $ it "associativity" $ property $ \x y z -> - (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE) + (x <> y) <> z === (x <> (y <> z) :: PE) describe "Monoid instance of ParseError" $ do it "left identity" $ @@ -67,13 +66,7 @@ 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) + -- NOTE 'errorOffset' and 'setErrorOffset' are trivial. describe "attachSourcePos" $ it "attaches the positions correctly" $ @@ -83,9 +76,9 @@ pst' = if null xs then pst - else snd $ reachOffsetNoLine (last xs) pst + else reachOffsetNoLine (last xs) pst rs = f <$> xs - f x = (x, fst (reachOffsetNoLine x pst)) + f x = (x, pstateSourcePos (reachOffsetNoLine x pst)) attachSourcePos id (xs :: [Int]) pst `shouldBe` (rs, pst') describe "errorBundlePretty" $ do diff --git a/tests/Text/Megaparsec/PosSpec.hs b/tests/Text/Megaparsec/PosSpec.hs --- a/tests/Text/Megaparsec/PosSpec.hs +++ b/tests/Text/Megaparsec/PosSpec.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE CPP #-} + 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 + +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif spec :: Spec spec = do diff --git a/tests/Text/Megaparsec/StreamSpec.hs b/tests/Text/Megaparsec/StreamSpec.hs --- a/tests/Text/Megaparsec/StreamSpec.hs +++ b/tests/Text/Megaparsec/StreamSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,7 +10,6 @@ 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 @@ -22,6 +22,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif + spec :: Spec spec = do @@ -404,7 +408,7 @@ { pstateInput = "\n" :: s } o = pstateOffset pst + 1 - (r, _, _) = reachOffset o pst + r = pstateSourcePos . snd $ reachOffset o pst SourcePos n l _ = pstateSourcePos pst r `shouldBe` SourcePos n (l <> pos1) pos1 it "returns correct SourcePos (tab)" $ @@ -413,7 +417,7 @@ { pstateInput = "\t" :: s } o = pstateOffset pst + 1 - (r, _, _) = reachOffset o pst + r = pstateSourcePos . snd $ reachOffset o pst SourcePos n l c = pstateSourcePos pst w = pstateTabWidth pst r `shouldBe` SourcePos n l (toNextTab w c) @@ -423,7 +427,7 @@ { pstateInput = "a" :: s } o = pstateOffset pst + 1 - (r, _, _) = reachOffset o pst + r = pstateSourcePos . snd $ reachOffset o pst SourcePos n l c = pstateSourcePos pst r `shouldBe` SourcePos n l (c <> pos1) it "replaces empty line with " $ @@ -432,7 +436,7 @@ { pstateInput = "" :: s , pstateLinePrefix = "" } - (_, r, _) = reachOffset o pst + (r, _) = reachOffset o pst r `shouldBe` "" it "replaces tabs with spaces in returned line" $ property $ \pst' -> do @@ -440,7 +444,7 @@ { pstateInput = "\ta\t" :: s , pstateLinePrefix = "\t" } - (_, r, _) = reachOffset 2 pst + (r, _) = reachOffset 2 pst w = unPos (pstateTabWidth pst) r' = replicate (w * 2) ' ' ++ "a" ++ replicate w ' ' r `shouldBe` r' @@ -450,7 +454,7 @@ { pstateInput = "foo\nbar\nbaz" :: s , pstateLinePrefix = "123" } - (_, r, _) = reachOffset 0 pst + (r, _) = reachOffset 0 pst r `shouldBe` "123foo" it "returns correct line (without line prefix)" $ property $ \pst' -> do @@ -458,7 +462,7 @@ { pstateInput = "foo\nbar\nbaz" :: s , pstateOffset = 0 } - (_, r, _) = reachOffset 4 pst + (r, _) = reachOffset 4 pst r `shouldBe` "bar" it "works incrementally" $ property $ \os' (NonNegative d) s -> do @@ -469,7 +473,7 @@ [] -> d xs -> maximum xs + d f pst o = - let (_, _, pst') = reachOffset o pst + let (_, pst') = reachOffset o pst in pst' reachOffset o' s `shouldBe` reachOffset o' s' @@ -491,7 +495,7 @@ { pstateInput = "\n" :: s } o = pstateOffset pst + 1 - (r, _) = reachOffsetNoLine o pst + r = pstateSourcePos (reachOffsetNoLine o pst) SourcePos n l _ = pstateSourcePos pst r `shouldBe` SourcePos n (l <> pos1) pos1 it "returns correct SourcePos (tab)" $ @@ -500,7 +504,7 @@ { pstateInput = "\t" :: s } o = pstateOffset pst + 1 - (r, _) = reachOffsetNoLine o pst + r = pstateSourcePos (reachOffsetNoLine o pst) SourcePos n l c = pstateSourcePos pst w = pstateTabWidth pst r `shouldBe` SourcePos n l (toNextTab w c) @@ -510,7 +514,7 @@ { pstateInput = "a" :: s } o = pstateOffset pst + 1 - (r, _) = reachOffsetNoLine o pst + r = pstateSourcePos (reachOffsetNoLine o pst) SourcePos n l c = pstateSourcePos pst r `shouldBe` SourcePos n l (c <> pos1) it "works incrementally" $ @@ -522,7 +526,7 @@ [] -> d xs -> maximum xs + d f pst o = - let (_, pst') = reachOffsetNoLine o pst + let pst' = reachOffsetNoLine o pst in pst' reachOffsetNoLine o' s `shouldBe` reachOffsetNoLine o' s' diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} @@ -37,23 +37,17 @@ 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.List.NonEmpty as NE 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] + let p = pure [a] <> pure [b] prs p "" `shouldParse` ([a,b] :: [Int]) describe "ParsecT Monoid instance" $ do @@ -416,19 +410,12 @@ 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 + describe "parseError" $ do + it "immediately fails with given parse error" $ + property $ \st e -> do let p :: MonadParsec Void String m => m () - p = void (fancyFailure xs) - grs p "" (`shouldFailWith` FancyError 0 xs) + p = parseError e + runParser' p st `shouldBe` (st, Left (mkBundle st (nes e))) describe "label" $ do context "when inner parser succeeds consuming input" $ do @@ -1058,6 +1045,111 @@ grs p s (`shouldFailWith` pe) grs' p s (`failsLeaving` drop n s) + describe "signaling parse errors" $ do + + describe "failure" $ + it "signals correct parse error" $ + property $ \us ps -> do + let p :: MonadParsec Void String m => m () + p = void (failure us ps) + grs p "" (`shouldFailWith` TrivialError 0 us ps) + + describe "fancyFailure" $ + it "singals correct parse error" $ + property $ \xs -> do + let p :: MonadParsec Void String m => m () + p = void (fancyFailure xs) + grs p "" (`shouldFailWith` FancyError 0 xs) + + describe "unexpected" $ + it "signals correct parse error" $ + property $ \item -> do + let p :: MonadParsec Void String m => m () + p = void (unexpected item) + grs p "" (`shouldFailWith` TrivialError 0 (pure item) E.empty) + + describe "customFailure" $ + it "signals correct parse error" $ + property $ \n st -> do + let p :: MonadParsec Int String m => m () + p = void (customFailure n) + xs = E.singleton (ErrorCustom n) + runParser p "" (stateInput st) `shouldFailWith` FancyError 0 xs + runParser' p st `failsLeaving` stateInput st + + describe "region" $ do + let f o' = \case + TrivialError o us ps -> + FancyError + (max o o') + (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps) + FancyError o xs -> + FancyError + (max o o') + (E.singleton . ErrorCustom $ E.size xs) + context "when inner parser succeeds" $ do + it "delayed parse errors get updated correctly" $ + property $ \st es0 es1 es2 o' n -> do + let p :: Parsec Int String Int + p = do + forM_ (NE.reverse es0) registerParseError + region (f o') $ + forM_ (NE.reverse es1) registerParseError + forM_ (NE.reverse es2) registerParseError + return n + es = es2 <> fmap (f o') es1 <> es0 + st' = st + { stateParseErrors = NE.toList es + } + runParser' p st `shouldBe` + ( st' + , Left (mkBundle st es) + ) + context "when inner parser fails" $ do + it "delayed and normal parse errors get updated correctly" $ + property $ \st es0 es1 e o' -> do + let p :: Parsec Int String () + p = do + forM_ (NE.reverse es0) registerParseError + region (f o') $ do + forM_ (NE.reverse es1) registerParseError + void (parseError e) + es = fmap (f o') es1 <> es0 + st' = st + { stateParseErrors = NE.toList es + } + runParser' p st `shouldBe` + ( st' + , Left (mkBundle st (nes (f o' e) <> es)) + ) + + describe "registerParseError" $ do + it "immediately fails with given parse error" $ + property $ \st es -> do + let p :: MonadParsec Void String m => m () + p = forM_ (NE.reverse es) registerParseError + st' = st + { stateParseErrors = NE.toList es + } + runParser' p st `shouldBe` + ( st' + , Left (mkBundle st es) + ) + + describe "registerFailure" $ + it "signals correct parse error" $ + property $ \us ps -> do + let p :: MonadParsec Void String m => m () + p = void (registerFailure us ps) + grs p "" (`shouldFailWith` TrivialError 0 us ps) + + describe "reisterFancyFailure" $ + it "singals correct parse error" $ + property $ \xs -> do + let p :: MonadParsec Void String m => m () + p = void (registerFancyFailure xs) + grs p "" (`shouldFailWith` FancyError 0 xs) + describe "derivatives from primitive combinators" $ do -- NOTE 'single' is tested via 'char' in "Text.Megaparsec.Char" and @@ -1139,22 +1231,6 @@ -- 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 @@ -1162,40 +1238,6 @@ 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 @@ -1247,7 +1289,8 @@ property $ \st -> do let p :: Parser SourcePos p = getSourcePos - (spos, _, pst') = reachOffset (stateOffset st) (statePosState st) + pst' = snd $ reachOffset (stateOffset st) (statePosState st) + spos = pstateSourcePos pst' runParser' p st `shouldBe` (st { statePosState = pst' }, Right spos) describe "setOffset and getOffset" $ @@ -1259,14 +1302,15 @@ 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) + let p :: MonadParsec Void String m => m (State String Void) p = do st <- getParserState guard (st == initialState s) setParserState s1 updateParserState (f s2) getParserState <* setInput "" - f (State s1' o pst) (State s2' _ _) = State (max s1' s2') o pst + f (State s1' o pst de1) (State s2' _ _ de2) = + State (max s1' s2') o pst (de1 <> de2) s = "" grs p s (`shouldParse` f s2 s1) @@ -1621,15 +1665,16 @@ showErrorComponent = show emulateStrParsing - :: State String + :: State String Void -> String - -> (State String, Either (ParseErrorBundle String Void) String) -emulateStrParsing st@(State i o pst) s = + -> (State String Void, Either (ParseErrorBundle String Void) String) +emulateStrParsing st@(State i o pst de) s = if s == take l i - then ( State (drop l i) (o + l) pst - , Right s ) + then ( State (drop l i) (o + l) pst de + , Right s + ) else ( st - , Left (mkBundle st (err o (etoks s <> utoks (take l i)))) + , Left (mkBundle st (nes (err o (etoks s <> utoks (take l i))))) ) where l = length s @@ -1641,11 +1686,14 @@ -> 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 :| [] +mkBundle + :: State s e + -> NonEmpty (ParseError s e) -- FIXME change back if we don't use it + -> ParseErrorBundle s e +mkBundle s es = ParseErrorBundle + { bundleErrors = NE.sortWith errorOffset es , bundlePosState = statePosState s } -grabTabWidth :: (State a, b) -> Pos +grabTabWidth :: (State a e, b) -> Pos grabTabWidth = pstateTabWidth . statePosState . fst