{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Parsec.Free.Log where
import Control.Lens
import Control.Monad (when)
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Data.Foldable (forM_)
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
import qualified "parsec" Text.Parsec.Error as P
import Text.Parsec.Free
import Text.Parsec.Free.Eval
import qualified "parsec" Text.Parsec.Prim as P
type LogType = IORef [ParseLog]
type LogParsecT s u m a = MonadReader LogType m => P.ParsecT s u m a
data ParseLog
= forall s u m a. ParseAttempt Bool (ParsecF s u m a)
| forall s u m a. ParseFailed Bool P.ParseError (ParsecF s u m a)
| forall s u m a b. Show b => ParseSuccess Bool b (ParsecF s u m a)
| forall s u m a. ParseSuccessful Bool (ParsecF s u m a)
| Indent Bool
| Dedent
instance Show ParseLog where
show :: ParseLog -> String
show (ParseAttempt Bool
b ParsecF s u m a
p) = String
"ParseAttempt " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
b forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParsecF s u m a
p
show (ParseFailed Bool
b ParseError
err ParsecF s u m a
p) = String
"ParseFailed " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
b forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParseError
err forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParsecF s u m a
p
show (ParseSuccess Bool
b b
a ParsecF s u m a
p) = String
"ParseSuccess " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
b forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show b
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParsecF s u m a
p
show (ParseSuccessful Bool
b ParsecF s u m a
p) = String
"ParseSuccessful " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
b forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParsecF s u m a
p
show (Indent Bool
b) = String
"Indent " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
b
show ParseLog
Dedent = String
"Dedent"
$(makePrisms ''ParseLog)
data Result = Failure Bool P.ParseError
| Success Bool
| SuccessValue Bool String
| Pending
data LogEntry = LogEntry
{ LogEntry -> Int
_leDepth :: Int
, LogEntry -> Bool
_leBranch :: Bool
, LogEntry -> Bool
_leShow :: Bool
, LogEntry -> String
_leParser :: String
, LogEntry -> Result
_leResult :: Result
}
$(makeLenses ''LogEntry)
instance Show LogEntry where
show :: LogEntry -> String
show LogEntry {Bool
Int
String
Result
_leResult :: Result
_leParser :: String
_leShow :: Bool
_leBranch :: Bool
_leDepth :: Int
_leResult :: LogEntry -> Result
_leParser :: LogEntry -> String
_leShow :: LogEntry -> Bool
_leBranch :: LogEntry -> Bool
_leDepth :: LogEntry -> Int
..} =
(if Bool
_leBranch
then forall a. Int -> a -> [a]
replicate (forall a. Enum a => a -> a
pred Int
_leDepth forall a. Num a => a -> a -> a
* Int
2) Char
' '
forall a. [a] -> [a] -> [a]
++ case Result
_leResult of
Failure Bool
_ ParseError
_err -> String
"- "
Success Bool
_ -> String
"+ "
SuccessValue Bool
_ String
_ -> String
"+ "
Result
Pending -> String
"? "
else forall a. Int -> a -> [a]
replicate (Int
_leDepth forall a. Num a => a -> a -> a
* Int
2) Char
' ')
forall a. [a] -> [a] -> [a]
++ (case Result
_leResult of
Failure Bool
_ ParseError
_err -> String
"(" forall a. [a] -> [a] -> [a]
++ String
_leParser forall a. [a] -> [a] -> [a]
++ String
")"
Success Bool
_ -> String
_leParser
SuccessValue Bool
_ String
str -> String
_leParser forall a. [a] -> [a] -> [a]
++ String
" => " forall a. [a] -> [a] -> [a]
++ String
str
Result
Pending -> String
_leParser forall a. [a] -> [a] -> [a]
++ String
"...")
forall a. [a] -> [a] -> [a]
++ if case Result
_leResult of
Failure Bool
b ParseError
_ -> Bool
b
Success Bool
b -> Bool
False
SuccessValue Bool
b String
_ -> Bool
False
Result
Pending -> Bool
False
then String
" *"
else String
""
data RenderState = RenderState
{ RenderState -> Int
_rsIndex :: Int
, RenderState -> Bool
_rsBranch :: Bool
, :: [Int]
, RenderState -> Map Int LogEntry
_rsMap :: Map Int LogEntry
}
$
newRenderState :: RenderState
newRenderState :: RenderState
newRenderState = Int -> Bool -> [Int] -> Map Int LogEntry -> RenderState
RenderState Int
1 Bool
False [] forall k a. Map k a
M.empty
renderLog :: Bool -> [ParseLog] -> String
renderLog :: Bool -> [ParseLog] -> String
renderLog Bool
showAll [ParseLog]
l =
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
(\LogEntry
a -> if Bool
showAll Bool -> Bool -> Bool
|| LogEntry -> Bool
_leShow LogEntry
a
then Char
'\n' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show LogEntry
a
else forall a. Monoid a => a
mempty)
(RenderState -> Map Int LogEntry
_rsMap (forall s a. State s a -> s -> s
execState (forall {m :: * -> *}.
Monad m =>
Int -> [ParseLog] -> StateT RenderState m String
go (Int
0 :: Int) (forall a. [a] -> [a]
reverse [ParseLog]
l)) RenderState
newRenderState))
where
go :: Int -> [ParseLog] -> StateT RenderState m String
go Int
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return String
""
go Int
n (ParseLog
x:[ParseLog]
xs) = case ParseLog
x of
Indent Bool
b -> Lens' RenderState Bool
rsBranch forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> [ParseLog] -> StateT RenderState m String
go (Int
nforall a. Num a => a -> a -> a
+Int
1) [ParseLog]
xs
ParseLog
Dedent -> Int -> [ParseLog] -> StateT RenderState m String
go (Int
nforall a. Num a => a -> a -> a
-Int
1) [ParseLog]
xs
ParseAttempt Bool
shouldShow ParsecF s u m a
p -> do
Int
i <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' RenderState Int
rsIndex
Bool
b <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' RenderState Bool
rsBranch
Lens' RenderState Bool
rsBranch forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
Lens' RenderState (Map Int LogEntry)
rsMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
i forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= LogEntry { _leDepth :: Int
_leDepth = Int
n
, _leBranch :: Bool
_leBranch = Bool
b
, _leShow :: Bool
_leShow = Bool
shouldShow
, _leParser :: String
_leParser = forall a. Show a => a -> String
show ParsecF s u m a
p
, _leResult :: Result
_leResult = Result
Pending
}
Lens' RenderState [Int]
rsStack forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Int
iforall a. a -> [a] -> [a]
:)
Lens' RenderState Int
rsIndex forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1
Int -> [ParseLog] -> StateT RenderState m String
go Int
n [ParseLog]
xs
ParseFailed Bool
b ParseError
err ParsecF s u m a
_ -> forall {m :: * -> *}. Monad m => Result -> StateT RenderState m ()
setResult (Bool -> ParseError -> Result
Failure Bool
b ParseError
err) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> [ParseLog] -> StateT RenderState m String
go Int
n [ParseLog]
xs
ParseSuccessful Bool
b ParsecF s u m a
_ -> forall {m :: * -> *}. Monad m => Result -> StateT RenderState m ()
setResult (Bool -> Result
Success Bool
b) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> [ParseLog] -> StateT RenderState m String
go Int
n [ParseLog]
xs
ParseSuccess Bool
b b
v ParsecF s u m a
_ -> forall {m :: * -> *}. Monad m => Result -> StateT RenderState m ()
setResult (Bool -> String -> Result
SuccessValue Bool
b (forall a. Show a => a -> String
show b
v)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> [ParseLog] -> StateT RenderState m String
go Int
n [ParseLog]
xs
where
setResult :: Result -> StateT RenderState m ()
setResult Result
str = do
Int
i <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Lens' RenderState [Int]
rsStackforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. Cons s s a a => Traversal' s a
_head)
Lens' RenderState (Map Int LogEntry)
rsMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
iforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' LogEntry Result
leResult forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Result
str
Lens' RenderState [Int]
rsStack forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. [a] -> [a]
tail
appendLog :: (MonadIO m, MonadReader LogType m) => ParseLog -> m ()
appendLog :: forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog ParseLog
l = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LogType
ref -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> (a -> a) -> IO ()
modifyIORef LogType
ref (ParseLog
lforall a. a -> [a] -> [a]
:))
attempt :: (MonadIO m, MonadReader LogType m)
=> Bool -> ParsecF s u' m b -> P.ParsecT s u m a
-> P.ParsecT s u m a
attempt :: forall (m :: * -> *) s u' b u a.
(MonadIO m, MonadReader LogType m) =>
Bool -> ParsecF s u' m b -> ParsecT s u m a -> ParsecT s u m a
attempt Bool
b ParsecF s u' m b
t ParsecT s u m a
p = forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
P.mkPT forall a b. (a -> b) -> a -> b
$ \State s u
s -> do
forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (forall s u (m :: * -> *) a. Bool -> ParsecF s u m a -> ParseLog
ParseAttempt Bool
b ParsecF s u' m b
t)
Consumed (m (Reply s u a))
res <- forall (m :: * -> *) s u a.
Monad m =>
ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))
P.runParsecT ParsecT s u m a
p State s u
s
Reply s u a
r <- forall {a}. Consumed a -> a
parserReply Consumed (m (Reply s u a))
res
let consumed :: Bool
consumed = case Consumed (m (Reply s u a))
res of
P.Consumed m (Reply s u a)
_ -> Bool
True
P.Empty m (Reply s u a)
_ -> Bool
False
case Reply s u a
r of
P.Ok a
_ State s u
_ ParseError
_ -> forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (forall s u (m :: * -> *) a. Bool -> ParsecF s u m a -> ParseLog
ParseSuccessful Bool
consumed ParsecF s u' m b
t)
P.Error ParseError
err -> forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (forall s u (m :: * -> *) a.
Bool -> ParseError -> ParsecF s u m a -> ParseLog
ParseFailed Bool
consumed ParseError
err ParsecF s u' m b
t)
forall (m :: * -> *) a. Monad m => a -> m a
return Consumed (m (Reply s u a))
res
where
parserReply :: Consumed a -> a
parserReply Consumed a
res = case Consumed a
res of
P.Consumed a
r -> a
r
P.Empty a
r -> a
r
attemptShow :: (MonadIO m, MonadReader LogType m, Show a)
=> Bool -> ParsecF s u' m b -> P.ParsecT s u m a
-> P.ParsecT s u m a
attemptShow :: forall (m :: * -> *) a s u' b u.
(MonadIO m, MonadReader LogType m, Show a) =>
Bool -> ParsecF s u' m b -> ParsecT s u m a -> ParsecT s u m a
attemptShow Bool
b ParsecF s u' m b
t ParsecT s u m a
p = forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
P.mkPT forall a b. (a -> b) -> a -> b
$ \State s u
s -> do
forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (forall s u (m :: * -> *) a. Bool -> ParsecF s u m a -> ParseLog
ParseAttempt Bool
b ParsecF s u' m b
t)
Consumed (m (Reply s u a))
res <- forall (m :: * -> *) s u a.
Monad m =>
ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))
P.runParsecT ParsecT s u m a
p State s u
s
Reply s u a
r <- forall {a}. Consumed a -> a
parserReply Consumed (m (Reply s u a))
res
let consumed :: Bool
consumed = case Consumed (m (Reply s u a))
res of
P.Consumed m (Reply s u a)
_ -> Bool
True
P.Empty m (Reply s u a)
_ -> Bool
False
case Reply s u a
r of
P.Ok a
x State s u
_ ParseError
_ -> forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (forall s u (m :: * -> *) a b.
Show b =>
Bool -> b -> ParsecF s u m a -> ParseLog
ParseSuccess Bool
consumed a
x ParsecF s u' m b
t)
P.Error ParseError
err -> forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (forall s u (m :: * -> *) a.
Bool -> ParseError -> ParsecF s u m a -> ParseLog
ParseFailed Bool
consumed ParseError
err ParsecF s u' m b
t)
forall (m :: * -> *) a. Monad m => a -> m a
return Consumed (m (Reply s u a))
res
where
parserReply :: Consumed a -> a
parserReply Consumed a
res = case Consumed a
res of
P.Consumed a
r -> a
r
P.Empty a
r -> a
r
indented :: (MonadIO m, MonadReader LogType m)
=> Bool -> P.ParsecT s u m a -> P.ParsecT s u m a
indented :: forall (m :: * -> *) s u a.
(MonadIO m, MonadReader LogType m) =>
Bool -> ParsecT s u m a -> ParsecT s u m a
indented Bool
b ParsecT s u m a
p = forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
P.mkPT forall a b. (a -> b) -> a -> b
$ \State s u
s -> do
forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog (Bool -> ParseLog
Indent Bool
b)
Consumed (m (Reply s u a))
res <- forall (m :: * -> *) s u a.
Monad m =>
ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a)))
P.runParsecT ParsecT s u m a
p State s u
s
forall (m :: * -> *).
(MonadIO m, MonadReader LogType m) =>
ParseLog -> m ()
appendLog ParseLog
Dedent
forall (m :: * -> *) a. Monad m => a -> m a
return Consumed (m (Reply s u a))
res
evalLog :: (MonadIO m, MonadReader LogType m, P.Stream s m t, Show t)
=> ParsecDSL s u m a -> P.ParsecT s u m a
evalLog :: forall (m :: * -> *) s t u a.
(MonadIO m, MonadReader LogType m, Stream s m t, Show t) =>
ParsecDSL s u m a -> ParsecT s u m a
evalLog = forall s u (m :: * -> *) t a.
(Show t, Stream s m t) =>
(forall u' b c.
Bool -> ParsecF s u' m c -> ParsecT s u m b -> ParsecT s u m b)
-> (forall u' b c.
Show b =>
Bool -> ParsecF s u' m c -> ParsecT s u m b -> ParsecT s u m b)
-> (forall b. Bool -> ParsecT s u m b -> ParsecT s u m b)
-> ParsecDSL s u m a
-> ParsecT s u m a
eval' forall (m :: * -> *) s u' b u a.
(MonadIO m, MonadReader LogType m) =>
Bool -> ParsecF s u' m b -> ParsecT s u m a -> ParsecT s u m a
attempt forall (m :: * -> *) a s u' b u.
(MonadIO m, MonadReader LogType m, Show a) =>
Bool -> ParsecF s u' m b -> ParsecT s u m a -> ParsecT s u m a
attemptShow forall (m :: * -> *) s u a.
(MonadIO m, MonadReader LogType m) =>
Bool -> ParsecT s u m a -> ParsecT s u m a
indented
dumpLog :: MonadIO m => [ParseLog] -> m ()
dumpLog :: forall (m :: * -> *). MonadIO m => [ParseLog] -> m ()
dumpLog [ParseLog]
theLog = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Int
0, forall k a. Map k a
M.empty :: Map Int String) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [ParseLog]
theLog) forall a b. (a -> b) -> a -> b
$ \ParseLog
l -> do
(Int
i, Map Int String
m) <- forall (m :: * -> *) s. Monad m => StateT s m s
get
let go :: String -> StateT (Int, Map Int String) m ()
go String
p = do
let p' :: String
p' = Map Int String
m forall k a. Ord k => Map k a -> k -> a
M.! (Int
iforall a. Num a => a -> a -> a
-Int
1)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
p forall a. Eq a => a -> a -> Bool
/= String
p') forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
p forall a. [a] -> [a] -> [a]
++ String
" /= " forall a. [a] -> [a] -> [a]
++ String
p'
forall {m :: * -> *}. MonadIO m => Int -> m ()
indent (Int
iforall a. Num a => a -> a -> a
-Int
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int
iforall a. Num a => a -> a -> a
-Int
1, forall k a. Ord k => k -> Map k a -> Map k a
M.delete Int
i Map Int String
m)
case ParseLog
l of
ParseAttempt Bool
_ ParsecF s u m a
p -> forall {m :: * -> *}. MonadIO m => Int -> m ()
indent Int
i forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int
iforall a. Num a => a -> a -> a
+Int
1, forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i (forall a. Show a => a -> String
show ParsecF s u m a
p) Map Int String
m)
ParseSuccess Bool
_ b
_ ParsecF s u m a
p -> forall {m :: * -> *}.
MonadIO m =>
String -> StateT (Int, Map Int String) m ()
go (forall a. Show a => a -> String
show ParsecF s u m a
p)
ParseSuccessful Bool
_ ParsecF s u m a
p -> forall {m :: * -> *}.
MonadIO m =>
String -> StateT (Int, Map Int String) m ()
go (forall a. Show a => a -> String
show ParsecF s u m a
p)
ParseFailed Bool
_ ParseError
_ ParsecF s u m a
p -> forall {m :: * -> *}.
MonadIO m =>
String -> StateT (Int, Map Int String) m ()
go (forall a. Show a => a -> String
show ParsecF s u m a
p)
ParseLog
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
case ParseLog
l of
Indent Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ParseLog
Dedent -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ParseLog
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print ParseLog
l
where
indent :: Int -> m ()
indent Int
n = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n Char
' '