diff --git a/megaparsec-tests.cabal b/megaparsec-tests.cabal --- a/megaparsec-tests.cabal +++ b/megaparsec-tests.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: megaparsec-tests -version: 9.3.1 +version: 9.4.0 license: BSD-2-Clause license-file: LICENSE.md maintainer: Mark Karpov @@ -31,7 +31,7 @@ hspec >=2.0 && <3.0, hspec-expectations >=0.8 && <0.9, hspec-megaparsec >=2.0 && <3.0, - megaparsec ==9.3.1, + megaparsec ==9.4.0, mtl >=2.2.2 && <3.0, text >=0.2 && <2.1, transformers >=0.4 && <0.7 @@ -71,7 +71,7 @@ hspec >=2.0 && <3.0, hspec-expectations >=0.8 && <0.9, hspec-megaparsec >=2.0 && <3.0, - megaparsec ==9.3.1, + megaparsec ==9.4.0, megaparsec-tests, mtl >=2.2.2 && <3.0, parser-combinators >=1.0 && <2.0, 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 @@ -119,14 +119,14 @@ 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` () + | 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" $ @@ -165,33 +165,33 @@ 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])]) + | 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 @@ -266,13 +266,13 @@ (col0, col1, col2) = (getCol l0, getCol l1, getCol l2) (end0, end1) = (getEnd l0, getEnd l1) if - | end0 && col1 <= col0 -> - prs p s - `shouldFailWith` errFancy (getIndent l1 + g 1) (ii GT col0 col1) - | end1 && col2 <= col0 -> - prs p s - `shouldFailWith` errFancy (getIndent l2 + g 2) (ii GT col0 col2) - | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc) + | end0 && 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 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 @@ -33,16 +33,23 @@ let p :: (MonadParsecDbg Void String m) => m Char p = dbg "char" (char 'a') s = "ab" - shouldStderr p s "char> IN: \"ab\"\nchar> MATCH (COK): 'a'\nchar> VALUE: 'a'\n\n" + shouldStderr p s "char> IN: \"ab\"\nchar> MATCH (COK): 'a'\nchar> VALUE: 'a'\nchar> HINTS: []\n\n" grs p s (`shouldParse` 'a') grs' p s (`succeedsLeaving` "b") it "its hints are preserved" $ do let p :: (MonadParsecDbg Void String m) => m String p = dbg "many chars" (many (char 'a')) <* empty s = "abcd" - shouldStderr p s "many chars> IN: \"abcd\"\nmany chars> MATCH (COK): 'a'\nmany chars> VALUE: \"a\"\n\n" + shouldStderr p s "many chars> IN: \"abcd\"\nmany chars> MATCH (COK): 'a'\nmany chars> VALUE: \"a\"\nmany chars> HINTS: ['a']\n\n" grs p s (`shouldFailWith` err 1 (etok 'a')) grs' p s (`failsLeaving` "bcd") + it "prints several hints correctly" $ do + let p :: (MonadParsecDbg Void String m) => m (Maybe Char) + p = dbg "a or b" (optional (char 'a' <|> char 'b')) <* empty + s = "" + shouldStderr p s "a or b> IN: \na or b> MATCH (EOK): \na or b> VALUE: Nothing\na or b> HINTS: ['a','b']\n\n" + grs p s (`shouldFailWith` err 0 (etok 'a' <> etok 'b')) + grs' p s (`failsLeaving` "") context "when inner parser fails consuming input" $ it "has no effect on how parser works" $ do let p :: (MonadParsecDbg Void String m) => m Char @@ -56,14 +63,14 @@ let p :: (MonadParsecDbg Void String m) => m Char p = dbg "return" (return 'a') s = "abc" - shouldStderr p s "return> IN: \"abc\"\nreturn> MATCH (EOK): \nreturn> VALUE: 'a'\n\n" + shouldStderr p s "return> IN: \"abc\"\nreturn> MATCH (EOK): \nreturn> VALUE: 'a'\nreturn> HINTS: []\n\n" grs p s (`shouldParse` 'a') grs' p s (`succeedsLeaving` s) it "its hints are preserved" $ do let p :: (MonadParsecDbg Void String m) => m String p = dbg "many chars" (many (char 'a')) <* empty s = "bcd" - shouldStderr p s "many chars> IN: \"bcd\"\nmany chars> MATCH (EOK): \nmany chars> VALUE: \"\"\n\n" + shouldStderr p s "many chars> IN: \"bcd\"\nmany chars> MATCH (EOK): \nmany chars> VALUE: \"\"\nmany chars> HINTS: ['a']\n\n" grs p s (`shouldFailWith` err 0 (etok 'a')) grs' p s (`failsLeaving` "bcd") context "when inner parser fails without consuming" $ @@ -87,8 +94,8 @@ tell [2] s1 = "a" s2 = "abcd" - stderr1 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (LOG: [1])\n\n" - stderr2 = "a> IN: \"abcd\"\na> MATCH (COK): 'a'\na> VALUE: 'a' (LOG: [])\n\nb> IN: \"bcd\"\nb> MATCH (COK): 'b'\nb> VALUE: 'b' (LOG: [])\n\nc> IN: \"cd\"\nc> MATCH (COK): \"cd\"\nc> VALUE: () (LOG: [1,2])\n\n" + stderr1 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (LOG: [1])\na> HINTS: []\n\n" + stderr2 = "a> IN: \"abcd\"\na> MATCH (COK): 'a'\na> VALUE: 'a' (LOG: [])\na> HINTS: []\n\nb> IN: \"bcd\"\nb> MATCH (COK): 'b'\nb> VALUE: 'b' (LOG: [])\nb> HINTS: []\n\nc> IN: \"cd\"\nc> MATCH (COK): \"cd\"\nc> VALUE: () (LOG: [1,2])\nc> HINTS: []\n\n" r1 = ((), [0, 1]) r2 = ((), [0, 1, 2]) context "Lazy WriterT instance of MonadParsecDbg" $ do @@ -118,8 +125,8 @@ modify succ s3 = "a" s4 = "abcd" - stderr3 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (STATE: 2)\n\n" - stderr4 = "a> IN: \"abcd\"\na> MATCH (COK): 'a'\na> VALUE: 'a' (STATE: 0)\n\nb> IN: \"bcd\"\nb> MATCH (COK): 'b'\nb> VALUE: 'b' (STATE: 1)\n\nc> IN: \"cd\"\nc> MATCH (COK): \"cd\"\nc> VALUE: () (STATE: 3)\n\n" + stderr3 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (STATE: 2)\na> HINTS: []\n\n" + stderr4 = "a> IN: \"abcd\"\na> MATCH (COK): 'a'\na> VALUE: 'a' (STATE: 0)\na> HINTS: []\n\nb> IN: \"bcd\"\nb> MATCH (COK): 'b'\nb> VALUE: 'b' (STATE: 1)\nb> HINTS: []\n\nc> IN: \"cd\"\nc> MATCH (COK): \"cd\"\nc> VALUE: () (STATE: 3)\nc> HINTS: []\n\n" r3 = ((), 2) r4 = ((), 3) context "Lazy StateT instance of MonadParsecDbg" $ do @@ -142,8 +149,8 @@ modify succ dbg "a" (single 'a' >> tell [1] >> modify succ) s5 = "a" - stderr5 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (STATE: 2) (LOG: [1])\n\n" - stderr7 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (LOG: [1]) (STATE: 2)\n\n" + stderr5 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (STATE: 2) (LOG: [1])\na> HINTS: []\n\n" + stderr7 = "a> IN: 'a'\na> MATCH (COK): 'a'\na> VALUE: () (LOG: [1]) (STATE: 2)\na> HINTS: []\n\n" r5 = ((), 2, [0, 1]) p6 :: (MonadParsecDbg Void String m, MonadWriter [Int] m, MonadState Int m) => m () p6 = do @@ -179,6 +186,7 @@ -- | Check that running the given parser on the input prints the expected -- string to the 'stderr'. shouldStderr :: + (HasCallStack) => -- | The parser to test Parser a -> -- | Input for the parser diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -42,6 +42,7 @@ import Test.QuickCheck hiding (label) import Text.Megaparsec import Text.Megaparsec.Char +import qualified Text.Megaparsec.Internal as Internal import Prelude hiding (concat, span) spec :: Spec @@ -370,29 +371,54 @@ ) describe "ParsecT MonadReader instance" $ do - describe "ask" $ + describe "ask" $ do 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 + it "preserves hints" $ + property $ \a b (n :: Integer) -> + a /= b ==> do + let p :: ParsecT Void String (Reader Integer) Integer + p = optional (char a) *> ask <* hidden eof + runReader (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a) - describe "local" $ + describe "local" $ do 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) + it "preserves hints" $ + property $ \a b (n :: Integer) -> + a /= b ==> do + let p :: ParsecT Void String (Reader Integer) (Maybe Char) + p = local (+ 1) (optional (char a)) <* hidden eof + runReader (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a) describe "ParsecT MonadState instance" $ do - describe "get" $ + describe "get" $ do 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 "preserves hints" $ + property $ \a b (n :: Integer) -> + a /= b ==> do + let p :: ParsecT Void String (L.State Integer) Integer + p = optional (char a) *> L.get <* hidden eof + L.evalState (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a) + + describe "put" $ do 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 + it "preserves hints" $ + property $ \a b (n :: Integer) (n' :: Integer) -> + a /= b ==> do + let p :: ParsecT Void String (L.State Integer) () + p = optional (char a) *> L.put n' <* hidden eof + L.evalState (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a) describe "ParsecT MonadCont instance" $ describe "callCC" $ @@ -1748,6 +1774,26 @@ let p = observing (S.put s1 <* empty) prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse` (Left (err 0 mempty), s0, mempty :: [Int]) + + describe "mkParsec" $ + it "enables defining new primitives" $ do + -- This example lifts breakOn from text, although in order to re-use + -- the machinery that we have here it parses String, hence + -- conversions. The parser always succeeds. + let breakOn end = mkParsec $ \s -> + let (pre, post) = T.breakOn end (T.pack $ stateInput s) + in Internal.Reply + ( s + { stateInput = T.unpack post, + stateOffset = stateOffset s + T.length pre + } + ) + ( if T.null pre + then Internal.NotConsumed + else Internal.Consumed + ) + (Internal.OK mempty (T.unpack pre)) + prs (breakOn "x") "abxcd" `shouldParse` "ab" ---------------------------------------------------------------------------- -- Helpers