-- |
-- Module      :  Text.Megaparsec.Debug
-- Copyright   :  © 2015–present Megaparsec contributors
-- License     :  FreeBSD
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Debugging helpers.
--
-- @since 7.0.0

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.Megaparsec.Debug
  ( dbg )
where

import Data.Proxy
import Debug.Trace
import Text.Megaparsec.Error
import Text.Megaparsec.Internal
import Text.Megaparsec.State
import Text.Megaparsec.Stream
import qualified Data.List.NonEmpty as NE

-- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated
-- it also prints information useful for debugging. The @label@ is only used
-- to refer to this parser in the debugging output. This combinator uses the
-- 'trace' function from "Debug.Trace" under the hood.
--
-- Typical usage is to wrap every sub-parser in misbehaving parser with
-- 'dbg' assigning meaningful labels. Then give it a shot and go through the
-- print-out. As of current version, this combinator prints all available
-- information except for /hints/, which are probably only interesting to
-- the maintainer of Megaparsec itself and may be quite verbose to output in
-- general. Let me know if you would like to be able to see hints in the
-- debugging output.
--
-- The output itself is pretty self-explanatory, although the following
-- abbreviations should be clarified (they are derived from the low-level
-- source code):
--
--     * @COK@—“consumed OK”. The parser consumed input and succeeded.
--     * @CERR@—“consumed error”. The parser consumed input and failed.
--     * @EOK@—“empty OK”. The parser succeeded without consuming input.
--     * @EERR@—“empty error”. The parser failed without consuming input.
--
-- Finally, it's not possible to lift this function into some monad
-- transformers without introducing surprising behavior (e.g. unexpected
-- state backtracking) or adding otherwise redundant constraints (e.g.
-- 'Show' instance for state), so this helper is only available for
-- 'ParsecT' monad, not any instance of 'Text.Megaparsec.MonadParsec' in
-- general.

dbg :: forall e s m a.
  ( Stream s
  , ShowErrorComponent e
  , Show a )
  => String            -- ^ Debugging label
  -> ParsecT e s m a   -- ^ Parser to debug
  -> ParsecT e s m a   -- ^ Parser that prints debugging messages
dbg :: String -> ParsecT e s m a -> ParsecT e s m a
dbg lbl :: String
lbl p :: ParsecT e s m a
p = (forall b.
 State s e
 -> (a -> State s e -> Hints (Token s) -> m b)
 -> (ParseError s e -> State s e -> m b)
 -> (a -> State s e -> Hints (Token s) -> m b)
 -> (ParseError s e -> State s e -> m b)
 -> m b)
-> ParsecT e s m a
forall e s (m :: * -> *) a.
(forall b.
 State s e
 -> (a -> State s e -> Hints (Token s) -> m b)
 -> (ParseError s e -> State s e -> m b)
 -> (a -> State s e -> Hints (Token s) -> m b)
 -> (ParseError s e -> State s e -> m b)
 -> m b)
-> ParsecT e s m a
ParsecT ((forall b.
  State s e
  -> (a -> State s e -> Hints (Token s) -> m b)
  -> (ParseError s e -> State s e -> m b)
  -> (a -> State s e -> Hints (Token s) -> m b)
  -> (ParseError s e -> State s e -> m b)
  -> m b)
 -> ParsecT e s m a)
-> (forall b.
    State s e
    -> (a -> State s e -> Hints (Token s) -> m b)
    -> (ParseError s e -> State s e -> m b)
    -> (a -> State s e -> Hints (Token s) -> m b)
    -> (ParseError s e -> State s e -> m b)
    -> m b)
-> ParsecT e s m a
forall a b. (a -> b) -> a -> b
$ \s :: State s e
s cok :: a -> State s e -> Hints (Token s) -> m b
cok cerr :: ParseError s e -> State s e -> m b
cerr eok :: a -> State s e -> Hints (Token s) -> m b
eok eerr :: ParseError s e -> State s e -> m b
eerr ->
  let l :: DbgItem s e a -> String
l = String -> DbgItem s e a -> String
forall s e a.
(Stream s, ShowErrorComponent e, Show a) =>
String -> DbgItem s e a -> String
dbgLog String
lbl :: DbgItem s e a -> String
      unfold :: s -> [Token s]
unfold = Int -> s -> [Token s]
forall s. Stream s => Int -> s -> [Token s]
streamTake 40
      cok' :: a -> State s e -> Hints (Token s) -> m b
cok' x :: a
x s' :: State s e
s' hs :: Hints (Token s)
hs = (String -> m b -> m b) -> m b -> String -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> m b -> m b
forall a. String -> a -> a
trace (a -> State s e -> Hints (Token s) -> m b
cok a
x State s e
s' Hints (Token s)
hs) (String -> m b) -> String -> m b
forall a b. (a -> b) -> a -> b
$
        DbgItem s e a -> String
l ([Token s] -> DbgItem s e a
forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (State s e -> s
forall s e. State s e -> s
stateInput State s e
s))) String -> String -> String
forall a. [a] -> [a] -> [a]
++
        DbgItem s e a -> String
l ([Token s] -> a -> DbgItem s e a
forall s e a. [Token s] -> a -> DbgItem s e a
DbgCOK (Int -> s -> [Token s]
forall s. Stream s => Int -> s -> [Token s]
streamTake (State s e -> State s e -> Int
forall s e. State s e -> State s e -> Int
streamDelta State s e
s State s e
s') (State s e -> s
forall s e. State s e -> s
stateInput State s e
s)) a
x)
      cerr' :: ParseError s e -> State s e -> m b
cerr' err :: ParseError s e
err s' :: State s e
s' = (String -> m b -> m b) -> m b -> String -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> m b -> m b
forall a. String -> a -> a
trace (ParseError s e -> State s e -> m b
cerr ParseError s e
err State s e
s') (String -> m b) -> String -> m b
forall a b. (a -> b) -> a -> b
$
        DbgItem s e a -> String
l ([Token s] -> DbgItem s e a
forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (State s e -> s
forall s e. State s e -> s
stateInput State s e
s))) String -> String -> String
forall a. [a] -> [a] -> [a]
++
        DbgItem s e a -> String
l ([Token s] -> ParseError s e -> DbgItem s e a
forall s e a. [Token s] -> ParseError s e -> DbgItem s e a
DbgCERR (Int -> s -> [Token s]
forall s. Stream s => Int -> s -> [Token s]
streamTake (State s e -> State s e -> Int
forall s e. State s e -> State s e -> Int
streamDelta State s e
s State s e
s') (State s e -> s
forall s e. State s e -> s
stateInput State s e
s)) ParseError s e
err)
      eok' :: a -> State s e -> Hints (Token s) -> m b
eok' x :: a
x s' :: State s e
s' hs :: Hints (Token s)
hs = (String -> m b -> m b) -> m b -> String -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> m b -> m b
forall a. String -> a -> a
trace (a -> State s e -> Hints (Token s) -> m b
eok a
x State s e
s' Hints (Token s)
hs) (String -> m b) -> String -> m b
forall a b. (a -> b) -> a -> b
$
        DbgItem s e a -> String
l ([Token s] -> DbgItem s e a
forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (State s e -> s
forall s e. State s e -> s
stateInput State s e
s))) String -> String -> String
forall a. [a] -> [a] -> [a]
++
        DbgItem s e a -> String
l ([Token s] -> a -> DbgItem s e a
forall s e a. [Token s] -> a -> DbgItem s e a
DbgEOK (Int -> s -> [Token s]
forall s. Stream s => Int -> s -> [Token s]
streamTake (State s e -> State s e -> Int
forall s e. State s e -> State s e -> Int
streamDelta State s e
s State s e
s') (State s e -> s
forall s e. State s e -> s
stateInput State s e
s)) a
x)
      eerr' :: ParseError s e -> State s e -> m b
eerr' err :: ParseError s e
err s' :: State s e
s' = (String -> m b -> m b) -> m b -> String -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> m b -> m b
forall a. String -> a -> a
trace (ParseError s e -> State s e -> m b
eerr ParseError s e
err State s e
s') (String -> m b) -> String -> m b
forall a b. (a -> b) -> a -> b
$
        DbgItem s e a -> String
l ([Token s] -> DbgItem s e a
forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (State s e -> s
forall s e. State s e -> s
stateInput State s e
s))) String -> String -> String
forall a. [a] -> [a] -> [a]
++
        DbgItem s e a -> String
l ([Token s] -> ParseError s e -> DbgItem s e a
forall s e a. [Token s] -> ParseError s e -> DbgItem s e a
DbgEERR (Int -> s -> [Token s]
forall s. Stream s => Int -> s -> [Token s]
streamTake (State s e -> State s e -> Int
forall s e. State s e -> State s e -> Int
streamDelta State s e
s State s e
s') (State s e -> s
forall s e. State s e -> s
stateInput State s e
s)) ParseError s e
err)
  in ParsecT e s m a
-> State s e
-> (a -> State s e -> Hints (Token s) -> m b)
-> (ParseError s e -> State s e -> m b)
-> (a -> State s e -> Hints (Token s) -> m b)
-> (ParseError s e -> State s e -> m b)
-> m b
forall e s (m :: * -> *) a.
ParsecT e s m a
-> forall b.
   State s e
   -> (a -> State s e -> Hints (Token s) -> m b)
   -> (ParseError s e -> State s e -> m b)
   -> (a -> State s e -> Hints (Token s) -> m b)
   -> (ParseError s e -> State s e -> m b)
   -> m b
unParser ParsecT e s m a
p State s e
s a -> State s e -> Hints (Token s) -> m b
cok' ParseError s e -> State s e -> m b
cerr' a -> State s e -> Hints (Token s) -> m b
eok' ParseError s e -> State s e -> m b
eerr'

-- | A single piece of info to be rendered with 'dbgLog'.

data DbgItem s e a
  = DbgIn   [Token s]
  | DbgCOK  [Token s] a
  | DbgCERR [Token s] (ParseError s e)
  | DbgEOK  [Token s] a
  | DbgEERR [Token s] (ParseError s e)

-- | Render a single piece of debugging info.

dbgLog
  :: forall s e a. (Stream s, ShowErrorComponent e, Show a)
  => String            -- ^ Debugging label
  -> DbgItem s e a     -- ^ Information to render
  -> String            -- ^ Rendered result
dbgLog :: String -> DbgItem s e a -> String
dbgLog lbl :: String
lbl item :: DbgItem s e a
item = String -> String
prefix String
msg
  where
    prefix :: String -> String
prefix = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
lbl String -> String -> String
forall a. [a] -> [a] -> [a]
++ "> ") String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    pxy :: Proxy s
pxy = Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s
    msg :: String
msg = case DbgItem s e a
item of
      DbgIn   ts :: [Token s]
ts   ->
        "IN: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy s -> [Token s] -> String
forall s. Stream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts
      DbgCOK  ts :: [Token s]
ts a :: a
a ->
        "MATCH (COK): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy s -> [Token s] -> String
forall s. Stream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\nVALUE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a
      DbgCERR ts :: [Token s]
ts e :: ParseError s e
e ->
        "MATCH (CERR): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy s -> [Token s] -> String
forall s. Stream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\nERROR:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError s e -> String
forall s e.
(Stream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorPretty ParseError s e
e
      DbgEOK  ts :: [Token s]
ts a :: a
a ->
        "MATCH (EOK): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy s -> [Token s] -> String
forall s. Stream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\nVALUE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a
      DbgEERR ts :: [Token s]
ts e :: ParseError s e
e ->
        "MATCH (EERR): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy s -> [Token s] -> String
forall s. Stream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\nERROR:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError s e -> String
forall s e.
(Stream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorPretty ParseError s e
e

-- | Pretty-print a list of tokens.

showStream :: Stream s => Proxy s -> [Token s] -> String
showStream :: Proxy s -> [Token s] -> String
showStream pxy :: Proxy s
pxy ts :: [Token s]
ts =
  case [Token s] -> Maybe (NonEmpty (Token s))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Token s]
ts of
    Nothing -> "<EMPTY>"
    Just ne :: NonEmpty (Token s)
ne ->
      let (h :: String
h, r :: String
r) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 40 (Proxy s -> NonEmpty (Token s) -> String
forall s. Stream s => Proxy s -> NonEmpty (Token s) -> String
showTokens Proxy s
pxy NonEmpty (Token s)
ne)
      in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r then String
h else String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ " <…>"

-- | Calculate number of consumed tokens given 'State' of parser before and
-- after parsing.

streamDelta
  :: State s e         -- ^ State of parser before consumption
  -> State s e         -- ^ State of parser after consumption
  -> Int               -- ^ Number of consumed tokens
streamDelta :: State s e -> State s e -> Int
streamDelta s0 :: State s e
s0 s1 :: State s e
s1 = State s e -> Int
forall s e. State s e -> Int
stateOffset State s e
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- State s e -> Int
forall s e. State s e -> Int
stateOffset State s e
s0

-- | Extract a given number of tokens from the stream.

streamTake :: forall s. Stream s => Int -> s -> [Token s]
streamTake :: Int -> s -> [Token s]
streamTake n :: Int
n s :: s
s =
  case (Tokens s, s) -> Tokens s
forall a b. (a, b) -> a
fst ((Tokens s, s) -> Tokens s)
-> Maybe (Tokens s, s) -> Maybe (Tokens s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> s -> Maybe (Tokens s, s)
forall s. Stream s => Int -> s -> Maybe (Tokens s, s)
takeN_ Int
n s
s of
    Nothing -> []
    Just chk :: Tokens s
chk -> Proxy s -> Tokens s -> [Token s]
forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) Tokens s
chk