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.2.2 +version: 9.3.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.2.2, + megaparsec ==9.3.0, mtl >=2.2.2 && <3.0, text >=0.2 && <2.1, transformers >=0.4 && <0.7 @@ -71,11 +71,12 @@ hspec >=2.0 && <3.0, hspec-expectations >=0.8 && <0.9, hspec-megaparsec >=2.0 && <3.0, - megaparsec ==9.2.2, + megaparsec ==9.3.0, megaparsec-tests, mtl >=2.2.2 && <3.0, parser-combinators >=1.0 && <2.0, scientific >=0.3.1 && <0.4, + temporary >=1.1 && <1.4, text >=0.2 && <2.1, transformers >=0.4 && <0.7 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 @@ -71,6 +71,7 @@ import Test.Hspec.Megaparsec import Test.QuickCheck import Text.Megaparsec +import Text.Megaparsec.Debug (MonadParsecDbg) ---------------------------------------------------------------------------- -- Types @@ -120,7 +121,7 @@ -- all supported monads transformers in turn). grs :: -- | Parser to run - (forall m. MonadParsec Void String m => m a) -> + (forall m. MonadParsecDbg Void String m => m a) -> -- | Input for the parser String -> -- | How to check result of parsing @@ -140,7 +141,7 @@ -- | 'grs'' to 'grs' is as 'prs'' to 'prs'. grs' :: -- | Parser to run - (forall m. MonadParsec Void String m => m a) -> + (forall m. MonadParsecDbg Void String m => m a) -> -- | Input for the parser String -> -- | How to check result of parsing 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,8 +1,23 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Text.Megaparsec.DebugSpec (spec) where +import Control.Exception (evaluate) import Control.Monad +import Control.Monad.RWS (MonadRWS) +import qualified Control.Monad.RWS.Lazy as L +import qualified Control.Monad.RWS.Strict as S +import Control.Monad.State (MonadState (..), modify) +import qualified Control.Monad.State.Lazy as L +import qualified Control.Monad.State.Strict as S +import Control.Monad.Writer (MonadWriter (..)) +import qualified Control.Monad.Writer.Lazy as L +import qualified Control.Monad.Writer.Strict as S +import Data.Void +import GHC.IO.Handle +import System.IO (stderr) +import System.IO.Temp import Test.Hspec import Test.Hspec.Megaparsec import Test.Hspec.Megaparsec.AdHoc @@ -13,39 +28,170 @@ spec :: Spec spec = do describe "dbg" $ do - -- NOTE We don't test properties here to avoid a 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') + let p :: MonadParsecDbg Void String m => m Char + p = dbg "char" (char 'a') s = "ab" - prs p s `shouldParse` 'a' - prs' p s `succeedsLeaving` "b" + shouldStderr p s "char> IN: \"ab\"\nchar> MATCH (COK): 'a'\nchar> VALUE: 'a'\n\n" + grs p s (`shouldParse` 'a') + grs' p s (`succeedsLeaving` "b") it "its hints are preserved" $ do - let p = dbg "many chars" (many (char 'a')) <* empty + let p :: MonadParsecDbg Void String m => m String + p = dbg "many chars" (many (char 'a')) <* empty s = "abcd" - prs p s `shouldFailWith` err 1 (etok 'a') - prs' p s `failsLeaving` "bcd" + shouldStderr p s "many chars> IN: \"abcd\"\nmany chars> MATCH (COK): 'a'\nmany chars> VALUE: \"a\"\n\n" + grs p s (`shouldFailWith` err 1 (etok 'a')) + grs' 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') + let p :: MonadParsecDbg Void String m => m Char + p = dbg "chars" (char 'a' *> char 'c') s = "abc" - prs p s `shouldFailWith` err 1 (utok 'b' <> etok 'c') - prs' p s `failsLeaving` "bc" + shouldStderr p s "chars> IN: \"abc\"\nchars> MATCH (CERR): 'a'\nchars> ERROR:\nchars> offset=1:\nchars> unexpected 'b'\nchars> expecting 'c'\n\n" + grs p s (`shouldFailWith` err 1 (utok 'b' <> etok 'c')) + grs' 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') + let p :: MonadParsecDbg Void String m => m Char + p = dbg "return" (return 'a') s = "abc" - prs p s `shouldParse` 'a' - prs' p s `succeedsLeaving` s + shouldStderr p s "return> IN: \"abc\"\nreturn> MATCH (EOK): \nreturn> VALUE: 'a'\n\n" + grs p s (`shouldParse` 'a') + grs' p s (`succeedsLeaving` s) it "its hints are preserved" $ do - let p = dbg "many chars" (many (char 'a')) <* empty + let p :: MonadParsecDbg Void String m => m String + p = dbg "many chars" (many (char 'a')) <* empty s = "bcd" - prs p s `shouldFailWith` err 0 (etok 'a') - prs' p s `failsLeaving` "bcd" + shouldStderr p s "many chars> IN: \"bcd\"\nmany chars> MATCH (EOK): \nmany chars> VALUE: \"\"\n\n" + grs p s (`shouldFailWith` err 0 (etok 'a')) + grs' 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) + let p :: MonadParsecDbg Void String m => m () + p = dbg "empty" (void empty) s = "abc" - prs p s `shouldFailWith` err 0 mempty - prs' p s `failsLeaving` s + shouldStderr p s "empty> IN: \"abc\"\nempty> MATCH (EERR): \nempty> ERROR:\nempty> offset=0:\nempty> unknown parse error\n\n" + grs p s (`shouldFailWith` err 0 mempty) + grs' p s (`failsLeaving` s) + let p1, p2 :: (MonadParsecDbg Void String m, MonadWriter [Int] m) => m () + p1 = tell [0] >> dbg "a" (single 'a' >> tell [1]) + p2 = do + void $ dbg "a" (single 'a') + tell [0] + void $ dbg "b" (single 'b') + dbg "c" $ do + void (single 'c') + tell [1] + void (single 'd') + 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" + r1 = ((), [0, 1]) + r2 = ((), [0, 1, 2]) + context "Lazy WriterT instance of MonadParsecDbg" $ do + it "example 1" $ do + shouldStderr (L.runWriterT p1) s1 stderr1 + prs (L.runWriterT p1) s1 `shouldParse` r1 + it "example 2" $ do + shouldStderr (L.runWriterT p2) s2 stderr2 + prs (L.runWriterT p2) s2 `shouldParse` r2 + context "Strict WriterT instance of MonadParsecDbg" $ do + it "example 1" $ do + shouldStderr (S.runWriterT p1) s1 stderr1 + prs (S.runWriterT p1) s1 `shouldParse` r1 + it "example 2" $ do + shouldStderr (S.runWriterT p2) s2 stderr2 + prs (S.runWriterT p2) s2 `shouldParse` r2 + let p3, p4 :: (MonadParsecDbg Void String m, MonadState Int m) => m () + p3 = modify succ >> dbg "a" (single 'a' >> modify succ) + p4 = do + void $ dbg "a" (single 'a') + modify succ + void $ dbg "b" (single 'b') + dbg "c" $ do + void (single 'c') + modify succ + void (single 'd') + 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" + r3 = ((), 2) + r4 = ((), 3) + context "Lazy StateT instance of MonadParsecDbg" $ do + it "example 3" $ do + shouldStderr (L.runStateT p3 0) s3 stderr3 + prs (L.runStateT p3 0) s3 `shouldParse` r3 + it "example 4" $ do + shouldStderr (L.runStateT p4 0) s4 stderr4 + prs (L.runStateT p4 0) s4 `shouldParse` r4 + context "Strict StateT instance of MonadParsecDbg" $ do + it "example 3" $ do + shouldStderr (S.runStateT p3 0) s3 stderr3 + prs (S.runStateT p3 0) s3 `shouldParse` r3 + it "example 4" $ do + shouldStderr (S.runStateT p4 0) s4 stderr4 + prs (S.runStateT p4 0) s4 `shouldParse` r4 + let p5 :: (MonadParsecDbg Void String m, MonadRWS () [Int] Int m) => m () + p5 = do + tell [0] + 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" + r5 = ((), 2, [0, 1]) + p6 :: (MonadParsecDbg Void String m, MonadWriter [Int] m, MonadState Int m) => m () + p6 = do + tell [0] + modify succ + dbg "a" (single 'a' >> tell [1] >> modify succ) + r6 = (((), 2), [0, 1]) + r7 = (((), [0, 1]), 2) + context "Lazy RWST instance of MonadParsecDbg" $ do + it "example 5" $ do + shouldStderr (L.runRWST p5 () 0) s5 stderr5 + prs (L.runRWST p5 () 0) s5 `shouldParse` r5 + it "example 6" $ do + shouldStderr (L.runWriterT (L.runStateT p6 0)) s5 stderr5 + prs (L.runWriterT (L.runStateT p6 0)) s5 `shouldParse` r6 + it "example 7" $ do + shouldStderr (L.runStateT (L.runWriterT p6) 0) s5 stderr7 + prs (L.runStateT (L.runWriterT p6) 0) s5 `shouldParse` r7 + context "Strict RWST instance of MonadParsecDbg" $ do + it "example 5" $ do + shouldStderr (S.runRWST p5 () 0) s5 stderr5 + prs (S.runRWST p5 () 0) s5 `shouldParse` r5 + it "example 6" $ do + shouldStderr (S.runWriterT (S.runStateT p6 0)) s5 stderr5 + prs (S.runWriterT (S.runStateT p6 0)) s5 `shouldParse` r6 + it "example 7" $ do + shouldStderr (S.runStateT (S.runWriterT p6) 0) s5 stderr7 + prs (S.runStateT (S.runWriterT p6) 0) s5 `shouldParse` r7 + +---------------------------------------------------------------------------- +-- Helpers + +-- | Check that running the given parser on the input prints the expected +-- string to the 'stderr'. +shouldStderr :: + -- | The parser to test + Parser a -> + -- | Input for the parser + String -> + -- | The expected 'stderr' output + String -> + Expectation +shouldStderr p s expectedStderr = do + hFlush stderr + withSystemTempFile "megaparsec-dbg-tests" $ \tempPath tempHandle -> do + hDuplicateTo tempHandle stderr + void (evaluate (parse p "" s)) + hFlush stderr + hClose tempHandle + capturedStderr <- readFile tempPath + capturedStderr `shouldBe` expectedStderr diff --git a/tests/Text/MegaparsecSpec.hs b/tests/Text/MegaparsecSpec.hs --- a/tests/Text/MegaparsecSpec.hs +++ b/tests/Text/MegaparsecSpec.hs @@ -470,14 +470,20 @@ 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" $ + context "when inner parser fails without consuming" $ do 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)) - + context "when inner parser is composite with 2-hint sources" $ + it "both hint groups are replaced by the label" $ + property $ \lbl a b -> + not (null lbl) && a /= b ==> do + let p :: MonadParsec Void String m => m (Maybe Char) + p = label lbl (optional (char a) *> optional (char b)) <* 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" $ @@ -1058,6 +1064,21 @@ 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" $ + it "succeeds returning zero-length chunk" $ + property $ \(Negative n) -> do + let p :: MonadParsec Void String m => m String + p = takeP Nothing n + grs p "" (`shouldParse` "") + context "when stream is not empty" $ + it "succeeds returning zero-length chunk" $ + property $ \(Negative n) s -> + not (null s) ==> do + let p :: MonadParsec Void String m => m String + p = takeP Nothing n grs p s (`shouldParse` "") grs' p s (`succeedsLeaving` s) context "when taking >0 tokens" $ do