{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Unsafe #-}
module Text.Megaparsec.Debug
( MonadParsecDbg (..),
dbg',
)
where
import Control.Monad.Identity (IdentityT, mapIdentityT)
import qualified Control.Monad.Trans.RWS.Lazy as L
import qualified Control.Monad.Trans.RWS.Strict as S
import qualified Control.Monad.Trans.Reader as L
import qualified Control.Monad.Trans.State.Lazy as L
import qualified Control.Monad.Trans.State.Strict as S
import qualified Control.Monad.Trans.Writer.Lazy as L
import qualified Control.Monad.Trans.Writer.Strict as S
import Data.Bifunctor (Bifunctor (first))
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import Data.Proxy
import qualified Data.Set as E
import Debug.Trace
import Text.Megaparsec.Class (MonadParsec)
import Text.Megaparsec.Error
import Text.Megaparsec.Internal
import Text.Megaparsec.State
import Text.Megaparsec.Stream
class (MonadParsec e s m) => MonadParsecDbg e s m where
dbg ::
(Show a) =>
String ->
m a ->
m a
instance
(Show st, MonadParsecDbg e s m) =>
MonadParsecDbg e s (L.StateT st m)
where
dbg :: forall a. Show a => String -> StateT st m a -> StateT st m a
dbg String
str StateT st m a
sma = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
L.StateT forall a b. (a -> b) -> a -> b
$ \st
s ->
forall e s (m :: * -> *) a c.
(MonadParsecDbg e s m, Show a, Show c) =>
String -> String -> m (a, c) -> m (a, c)
dbgWithComment String
"STATE" String
str forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
L.runStateT StateT st m a
sma st
s
instance
(Show st, MonadParsecDbg e s m) =>
MonadParsecDbg e s (S.StateT st m)
where
dbg :: forall a. Show a => String -> StateT st m a -> StateT st m a
dbg String
str StateT st m a
sma = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
S.StateT forall a b. (a -> b) -> a -> b
$ \st
s ->
forall e s (m :: * -> *) a c.
(MonadParsecDbg e s m, Show a, Show c) =>
String -> String -> m (a, c) -> m (a, c)
dbgWithComment String
"STATE" String
str forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S.runStateT StateT st m a
sma st
s
instance
(MonadParsecDbg e s m) =>
MonadParsecDbg e s (L.ReaderT r m)
where
dbg :: forall a. Show a => String -> ReaderT r m a -> ReaderT r m a
dbg = forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
L.mapReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
dbg
instance
(Monoid w, Show w, MonadParsecDbg e s m) =>
MonadParsecDbg e s (L.WriterT w m)
where
dbg :: forall a. Show a => String -> WriterT w m a -> WriterT w m a
dbg String
str WriterT w m a
wma = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
L.WriterT forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a c.
(MonadParsecDbg e s m, Show a, Show c) =>
String -> String -> m (a, c) -> m (a, c)
dbgWithComment String
"LOG" String
str forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
L.runWriterT WriterT w m a
wma
instance
(Monoid w, Show w, MonadParsecDbg e s m) =>
MonadParsecDbg e s (S.WriterT w m)
where
dbg :: forall a. Show a => String -> WriterT w m a -> WriterT w m a
dbg String
str WriterT w m a
wma = forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
S.WriterT forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a c.
(MonadParsecDbg e s m, Show a, Show c) =>
String -> String -> m (a, c) -> m (a, c)
dbgWithComment String
"LOG" String
str forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
S.runWriterT WriterT w m a
wma
instance
(Monoid w, Show w, Show st, MonadParsecDbg e s m) =>
MonadParsecDbg e s (L.RWST r w st m)
where
dbg :: forall a. Show a => String -> RWST r w st m a -> RWST r w st m a
dbg String
str RWST r w st m a
sma = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
L.RWST forall a b. (a -> b) -> a -> b
$ \r
r st
s -> do
let smth :: m (ShowComment w (ShowComment st a))
smth =
(\(a
a, st
st, w
w) -> forall c a. String -> (a, c) -> ShowComment c a
ShowComment String
"LOG" (forall c a. String -> (a, c) -> ShowComment c a
ShowComment String
"STATE" (a
a, st
st), w
w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
L.runRWST RWST r w st m a
sma r
r st
s
((a
a, st
st), w
w) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall c a. ShowComment c a -> (a, c)
unComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a. ShowComment c a -> (a, c)
unComment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
dbg String
str m (ShowComment w (ShowComment st a))
smth
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, st
st, w
w)
instance
(Monoid w, Show w, Show st, MonadParsecDbg e s m) =>
MonadParsecDbg e s (S.RWST r w st m)
where
dbg :: forall a. Show a => String -> RWST r w st m a -> RWST r w st m a
dbg String
str RWST r w st m a
sma = forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
S.RWST forall a b. (a -> b) -> a -> b
$ \r
r st
s -> do
let smth :: m (ShowComment w (ShowComment st a))
smth =
(\(a
a, st
st, w
w) -> forall c a. String -> (a, c) -> ShowComment c a
ShowComment String
"LOG" (forall c a. String -> (a, c) -> ShowComment c a
ShowComment String
"STATE" (a
a, st
st), w
w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
S.runRWST RWST r w st m a
sma r
r st
s
((a
a, st
st), w
w) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall c a. ShowComment c a -> (a, c)
unComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a. ShowComment c a -> (a, c)
unComment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
dbg String
str m (ShowComment w (ShowComment st a))
smth
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, st
st, w
w)
instance (MonadParsecDbg e s m) => MonadParsecDbg e s (IdentityT m) where
dbg :: forall a. Show a => String -> IdentityT m a -> IdentityT m a
dbg = forall {k1} {k2} (m :: k1 -> *) (a :: k1) (n :: k2 -> *) (b :: k2).
(m a -> n b) -> IdentityT m a -> IdentityT n b
mapIdentityT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
dbg
dbgWithComment ::
(MonadParsecDbg e s m, Show a, Show c) =>
String ->
String ->
m (a, c) ->
m (a, c)
String
lbl String
str m (a, c)
ma =
forall c a. ShowComment c a -> (a, c)
unComment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
dbg String
str (forall c a. String -> (a, c) -> ShowComment c a
ShowComment String
lbl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a, c)
ma)
data c a = String (a, c)
unComment :: ShowComment c a -> (a, c)
(ShowComment String
_ (a, c)
val) = (a, c)
val
instance (Show c, Show a) => Show (ShowComment c a) where
show :: ShowComment c a -> String
show (ShowComment String
lbl (a
a, c
c)) = forall a. Show a => a -> String
show a
a forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
lbl forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show c
c forall a. [a] -> [a] -> [a]
++ String
")"
instance
(VisualStream s, ShowErrorComponent e) =>
MonadParsecDbg e s (ParsecT e s m)
where
dbg :: forall a. Show a => String -> ParsecT e s m a -> ParsecT e s m a
dbg String
lbl ParsecT e s m a
p = 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 a b. (a -> b) -> a -> b
$ \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 ->
let l :: DbgItem s e a -> String
l = forall s e a.
(VisualStream s, ShowErrorComponent e, Show a) =>
String -> DbgItem s e a -> String
dbgLog String
lbl
unfold :: s -> [Token s]
unfold = forall s. Stream s => Int -> s -> [Token s]
streamTake Int
40
cok' :: a -> State s e -> Hints (Token s) -> m b
cok' a
x State s e
s' Hints (Token s)
hs =
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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) forall a b. (a -> b) -> a -> b
$
DbgItem s e a -> String
l (forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (forall s e. State s e -> s
stateInput State s e
s)))
forall a. [a] -> [a] -> [a]
++ DbgItem s e a -> String
l (forall s e a. [Token s] -> a -> Hints (Token s) -> DbgItem s e a
DbgCOK (forall s. Stream s => Int -> s -> [Token s]
streamTake (forall s e. State s e -> State s e -> Int
streamDelta State s e
s State s e
s') (forall s e. State s e -> s
stateInput State s e
s)) a
x Hints (Token s)
hs)
cerr' :: ParseError s e -> State s e -> m b
cerr' ParseError s e
err State s e
s' =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. String -> a -> a
trace (ParseError s e -> State s e -> m b
cerr ParseError s e
err State s e
s') forall a b. (a -> b) -> a -> b
$
DbgItem s e a -> String
l (forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (forall s e. State s e -> s
stateInput State s e
s)))
forall a. [a] -> [a] -> [a]
++ DbgItem s e a -> String
l (forall s e a. [Token s] -> ParseError s e -> DbgItem s e a
DbgCERR (forall s. Stream s => Int -> s -> [Token s]
streamTake (forall s e. State s e -> State s e -> Int
streamDelta 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' a
x State s e
s' Hints (Token s)
hs =
forall a b c. (a -> b -> c) -> b -> a -> c
flip 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) forall a b. (a -> b) -> a -> b
$
DbgItem s e a -> String
l (forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (forall s e. State s e -> s
stateInput State s e
s)))
forall a. [a] -> [a] -> [a]
++ DbgItem s e a -> String
l (forall s e a. [Token s] -> a -> Hints (Token s) -> DbgItem s e a
DbgEOK (forall s. Stream s => Int -> s -> [Token s]
streamTake (forall s e. State s e -> State s e -> Int
streamDelta State s e
s State s e
s') (forall s e. State s e -> s
stateInput State s e
s)) a
x Hints (Token s)
hs)
eerr' :: ParseError s e -> State s e -> m b
eerr' ParseError s e
err State s e
s' =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. String -> a -> a
trace (ParseError s e -> State s e -> m b
eerr ParseError s e
err State s e
s') forall a b. (a -> b) -> a -> b
$
DbgItem s e a -> String
l (forall s e a. [Token s] -> DbgItem s e a
DbgIn (s -> [Token s]
unfold (forall s e. State s e -> s
stateInput State s e
s)))
forall a. [a] -> [a] -> [a]
++ DbgItem s e a -> String
l (forall s e a. [Token s] -> ParseError s e -> DbgItem s e a
DbgEERR (forall s. Stream s => Int -> s -> [Token s]
streamTake (forall s e. State s e -> State s e -> Int
streamDelta 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 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'
data DbgItem s e a
= DbgIn [Token s]
| DbgCOK [Token s] a (Hints (Token s))
| DbgCERR [Token s] (ParseError s e)
| DbgEOK [Token s] a (Hints (Token s))
| DbgEERR [Token s] (ParseError s e)
dbgLog ::
forall s e a.
(VisualStream s, ShowErrorComponent e, Show a) =>
String ->
DbgItem s e a ->
String
dbgLog :: forall s e a.
(VisualStream s, ShowErrorComponent e, Show a) =>
String -> DbgItem s e a -> String
dbgLog String
lbl DbgItem s e a
item = ShowS
prefix String
msg
where
prefix :: ShowS
prefix = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String
lbl forall a. [a] -> [a] -> [a]
++ String
"> ") forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
pxy :: Proxy s
pxy = forall {k} (t :: k). Proxy t
Proxy :: Proxy s
showHints :: Set (ErrorItem (Token s)) -> String
showHints Set (ErrorItem (Token s))
hs = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
List.intercalate String
"," (forall s.
VisualStream s =>
Proxy s -> ErrorItem (Token s) -> String
showErrorItem Proxy s
pxy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
E.toAscList Set (ErrorItem (Token s))
hs) forall a. [a] -> [a] -> [a]
++ String
"]"
msg :: String
msg = case DbgItem s e a
item of
DbgIn [Token s]
ts ->
String
"IN: " forall a. [a] -> [a] -> [a]
++ forall s. VisualStream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts
DbgCOK [Token s]
ts a
a (Hints Set (ErrorItem (Token s))
hs) ->
String
"MATCH (COK): "
forall a. [a] -> [a] -> [a]
++ forall s. VisualStream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts
forall a. [a] -> [a] -> [a]
++ String
"\nVALUE: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a
forall a. [a] -> [a] -> [a]
++ String
"\nHINTS: "
forall a. [a] -> [a] -> [a]
++ Set (ErrorItem (Token s)) -> String
showHints Set (ErrorItem (Token s))
hs
DbgCERR [Token s]
ts ParseError s e
e ->
String
"MATCH (CERR): " forall a. [a] -> [a] -> [a]
++ forall s. VisualStream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts forall a. [a] -> [a] -> [a]
++ String
"\nERROR:\n" forall a. [a] -> [a] -> [a]
++ forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorPretty ParseError s e
e
DbgEOK [Token s]
ts a
a (Hints Set (ErrorItem (Token s))
hs) ->
String
"MATCH (EOK): "
forall a. [a] -> [a] -> [a]
++ forall s. VisualStream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts
forall a. [a] -> [a] -> [a]
++ String
"\nVALUE: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a
forall a. [a] -> [a] -> [a]
++ String
"\nHINTS: "
forall a. [a] -> [a] -> [a]
++ Set (ErrorItem (Token s)) -> String
showHints Set (ErrorItem (Token s))
hs
DbgEERR [Token s]
ts ParseError s e
e ->
String
"MATCH (EERR): " forall a. [a] -> [a] -> [a]
++ forall s. VisualStream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts forall a. [a] -> [a] -> [a]
++ String
"\nERROR:\n" forall a. [a] -> [a] -> [a]
++ forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorPretty ParseError s e
e
showStream :: (VisualStream s) => Proxy s -> [Token s] -> String
showStream :: forall s. VisualStream s => Proxy s -> [Token s] -> String
showStream Proxy s
pxy [Token s]
ts =
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Token s]
ts of
Maybe (NonEmpty (Token s))
Nothing -> String
"<EMPTY>"
Just NonEmpty (Token s)
ne ->
let (String
h, String
r) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
40 (forall s. VisualStream s => Proxy s -> NonEmpty (Token s) -> String
showTokens Proxy s
pxy NonEmpty (Token s)
ne)
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r then String
h else String
h forall a. [a] -> [a] -> [a]
++ String
" <…>"
streamDelta ::
State s e ->
State s e ->
Int
streamDelta :: forall s e. State s e -> State s e -> Int
streamDelta State s e
s0 State s e
s1 = forall s e. State s e -> Int
stateOffset State s e
s1 forall a. Num a => a -> a -> a
- forall s e. State s e -> Int
stateOffset State s e
s0
streamTake :: forall s. (Stream s) => Int -> s -> [Token s]
streamTake :: forall s. Stream s => Int -> s -> [Token s]
streamTake Int
n s
s =
case forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Stream s => Int -> s -> Maybe (Tokens s, s)
takeN_ Int
n s
s of
Maybe (Tokens s)
Nothing -> []
Just Tokens s
chk -> forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens (forall {k} (t :: k). Proxy t
Proxy :: Proxy s) Tokens s
chk
dbg' ::
(MonadParsecDbg e s m) =>
String ->
m a ->
m a
dbg' :: forall e s (m :: * -> *) a.
MonadParsecDbg e s m =>
String -> m a -> m a
dbg' String
lbl m a
p = forall x. Blind x -> x
unBlind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsecDbg e s m, Show a) =>
String -> m a -> m a
dbg String
lbl (forall x. x -> Blind x
Blind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p)
newtype Blind x = Blind {forall x. Blind x -> x
unBlind :: x}
instance Show (Blind x) where
show :: Blind x -> String
show Blind x
_ = String
"NOT SHOWN"