content: {-# 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
  import Text.Megaparsec
  import Text.Megaparsec.Char
  import Text.Megaparsec.Debug
  
  spec :: Spec
  spec = do
    describe "dbg" $ do
      context "when inner parser succeeds consuming input" $ do
        it "has no effect on how parser works" $ do
          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'\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\"\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: <EMPTY>\na or b> MATCH (EOK): <EMPTY>\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
              p = dbg "chars" (char 'a' *> char 'c')
              s = "abc"
          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 :: (MonadParsecDbg Void String m) => m Char
              p = dbg "return" (return 'a')
              s = "abc"
          shouldStderr p s "return> IN: \"abc\"\nreturn> MATCH (EOK): <EMPTY>\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): <EMPTY>\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" $
        it "has no effect on how parser works" $ do
          let p :: (MonadParsecDbg Void String m) => m ()
              p = dbg "empty" (void empty)
              s = "abc"
          shouldStderr p s "empty> IN: \"abc\"\nempty> MATCH (EERR): <EMPTY>\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])\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
        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)\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
        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])\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
            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 ::
    (HasCallStack) =>
    -- | 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
  