{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ExistentialQuantification, RecordWildCards, NamedFieldPuns #-}
module Text.Gigaparsec.Debug (debug, debugWith, debugConfig, DebugConfig(..), WatchedReg(..), Break(..)) where
import Text.Gigaparsec.Internal (Parsec)
import Text.Gigaparsec.Internal.RT (Reg, readReg)
import Text.Gigaparsec.Internal qualified as Internal
import Text.Gigaparsec.Internal.RT qualified as Internal
import Control.Monad (when, forM)
import System.IO (hGetEcho, hSetEcho, hPutStr, stdin, stdout, Handle)
import Data.List (intercalate, isPrefixOf)
import Data.List.NonEmpty (NonEmpty((:|)), (<|))
import Data.List.NonEmpty qualified as NonEmpty (toList)
import System.Console.Pretty (color, supportsPretty, Color(Green, White, Red, Blue))
type DebugConfig :: *
data DebugConfig = DebugConfig {
DebugConfig -> Bool
ascii :: !Bool,
DebugConfig -> Break
breakPoint :: !Break,
DebugConfig -> [WatchedReg]
watchedRegs :: ![WatchedReg],
DebugConfig -> Handle
handle :: !Handle
}
debugConfig :: DebugConfig
debugConfig :: DebugConfig
debugConfig = DebugConfig { ascii :: Bool
ascii = Bool
False, breakPoint :: Break
breakPoint = Break
Never, watchedRegs :: [WatchedReg]
watchedRegs = [], handle :: Handle
handle = Handle
stdout }
type WatchedReg :: *
data WatchedReg = forall r a. Show a => WatchedReg String
(Reg r a)
type Break :: *
data Break = OnEntry
| OnExit
| Always
| Never
debug :: String -> Parsec a -> Parsec a
debug :: forall a. String -> Parsec a -> Parsec a
debug = forall a. DebugConfig -> String -> Parsec a -> Parsec a
debugWith DebugConfig
debugConfig
debugWith :: DebugConfig -> String -> Parsec a -> Parsec a
debugWith :: forall a. DebugConfig -> String -> Parsec a -> Parsec a
debugWith config :: DebugConfig
config@DebugConfig{Bool
ascii :: Bool
ascii :: DebugConfig -> Bool
ascii} String
name (Internal.Parsec forall r.
State
-> (a -> State -> RT r) -> (ParseError -> State -> RT r) -> RT r
p) = forall a.
(forall r.
State
-> (a -> State -> RT r) -> (ParseError -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec forall a b. (a -> b) -> a -> b
$ \State
st a -> State -> RT r
good ParseError -> State -> RT r
bad -> do
Bool
ascii' <- (\Bool
colourful -> Bool
ascii Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
colourful) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> RT a
Internal.unsafeIOToRT IO Bool
supportsPretty
let config' :: DebugConfig
config' = DebugConfig
config { ascii :: Bool
ascii = Bool
ascii' }
String -> Direction -> State -> String -> DebugConfig -> RT ()
doDebug String
name Direction
Enter State
st String
"" DebugConfig
config'
let good' :: a -> State -> RT r
good' a
x State
st' = do
let st'' :: State
st'' = State
st' { debugLevel :: Int
Internal.debugLevel = State -> Int
Internal.debugLevel State
st' forall a. Num a => a -> a -> a
- Int
1}
String -> Direction -> State -> String -> DebugConfig -> RT ()
doDebug String
name Direction
Exit State
st'' (Bool -> String -> String
green Bool
ascii' String
" Good") DebugConfig
config'
a -> State -> RT r
good a
x State
st''
let bad' :: ParseError -> State -> RT r
bad' ParseError
err State
st' = do
let st'' :: State
st'' = State
st' { debugLevel :: Int
Internal.debugLevel = State -> Int
Internal.debugLevel State
st' forall a. Num a => a -> a -> a
- Int
1}
String -> Direction -> State -> String -> DebugConfig -> RT ()
doDebug String
name Direction
Exit State
st'' (Bool -> String -> String
red Bool
ascii' String
" Bad") DebugConfig
config'
ParseError -> State -> RT r
bad ParseError
err State
st''
forall r.
State
-> (a -> State -> RT r) -> (ParseError -> State -> RT r) -> RT r
p (State
st { debugLevel :: Int
Internal.debugLevel = State -> Int
Internal.debugLevel State
st forall a. Num a => a -> a -> a
+ Int
1}) a -> State -> RT r
good' ParseError -> State -> RT r
bad'
type Direction :: *
data Direction = Enter | Exit
breakOnEntry :: Break -> Bool
breakOnEntry :: Break -> Bool
breakOnEntry Break
OnEntry = Bool
True
breakOnEntry Break
Always = Bool
True
breakOnEntry Break
_ = Bool
False
breakOnExit :: Break -> Bool
breakOnExit :: Break -> Bool
breakOnExit Break
OnExit = Bool
True
breakOnExit Break
Always = Bool
True
breakOnExit Break
_ = Bool
False
shouldBreak :: Direction -> Break -> Bool
shouldBreak :: Direction -> Break -> Bool
shouldBreak Direction
Enter = Break -> Bool
breakOnEntry
shouldBreak Direction
Exit = Break -> Bool
breakOnExit
doDebug :: String -> Direction -> Internal.State -> String -> DebugConfig -> Internal.RT ()
doDebug :: String -> Direction -> State -> String -> DebugConfig -> RT ()
doDebug String
name Direction
dir State
st String
end DebugConfig{Bool
[WatchedReg]
Handle
Break
handle :: Handle
watchedRegs :: [WatchedReg]
breakPoint :: Break
ascii :: Bool
handle :: DebugConfig -> Handle
watchedRegs :: DebugConfig -> [WatchedReg]
breakPoint :: DebugConfig -> Break
ascii :: DebugConfig -> Bool
..} = do
Handle
-> String
-> Direction
-> State
-> String
-> Bool
-> [WatchedReg]
-> RT ()
printInfo Handle
handle String
name Direction
dir State
st String
end Bool
ascii [WatchedReg]
watchedRegs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Direction -> Break -> Bool
shouldBreak Direction
dir Break
breakPoint) RT ()
waitForUser
printInfo :: Handle -> String -> Direction -> Internal.State -> String -> Bool -> [WatchedReg] -> Internal.RT ()
printInfo :: Handle
-> String
-> Direction
-> State
-> String
-> Bool
-> [WatchedReg]
-> RT ()
printInfo Handle
handle String
name Direction
dir st :: State
st@Internal.State{String
input :: State -> String
input :: String
input, Word
line :: State -> Word
line :: Word
line, Word
col :: State -> Word
col :: Word
col} String
end Bool
ascii [WatchedReg]
regs = do
let cs :: String
cs = String -> String -> String -> String
replace String
"\n" (Bool -> String
newline Bool
ascii)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
" " (Bool -> String
space Bool
ascii)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"\r" (Bool -> String
carriageReturn Bool
ascii)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"\t" (Bool -> String
tab Bool
ascii)
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (Int
5 forall a. Num a => a -> a -> a
+ Int
1) String
input
let cs' :: String
cs' = if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cs forall a. Ord a => a -> a -> Bool
< (Int
5 forall a. Num a => a -> a -> a
+ Int
1) then String
cs forall a. [a] -> [a] -> [a]
++ Bool -> String
endOfInput Bool
ascii else String
cs
let prelude :: String
prelude = Direction -> String -> String
portal Direction
dir String
name forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Word
line, Word
col) forall a. [a] -> [a] -> [a]
++ String
": "
let caret :: String
caret = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prelude) Char
' ' forall a. [a] -> [a] -> [a]
++ Bool -> String -> String
blue Bool
ascii String
"^"
[String]
regSummary <-
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WatchedReg]
regs then forall (m :: * -> *) a. Monad m => a -> m a
return []
else (forall a. [a] -> [a] -> [a]
++ [String
""]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"watched registers:" forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [WatchedReg]
regs (\(WatchedReg String
rname Reg r a
reg) ->
(\a
x -> String
" " forall a. [a] -> [a] -> [a]
++ String
rname forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r a. Reg r a -> RT a
readReg Reg r a
reg)
forall a. IO a -> RT a
Internal.unsafeIOToRT forall a b. (a -> b) -> a -> b
$
Handle -> String -> IO ()
hPutStr Handle
handle forall a b. (a -> b) -> a -> b
$ State -> [String] -> String
indentAndUnlines State
st ((String
prelude forall a. [a] -> [a] -> [a]
++ String
cs' forall a. [a] -> [a] -> [a]
++ String
end) forall a. a -> [a] -> [a]
: String
caret forall a. a -> [a] -> [a]
: [String]
regSummary)
waitForUser :: Internal.RT ()
waitForUser :: RT ()
waitForUser = forall a. IO a -> RT a
Internal.unsafeIOToRT forall a b. (a -> b) -> a -> b
$ do
Bool
echo <- Handle -> IO Bool
hGetEcho Handle
stdin
Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
False
String -> IO ()
putStrLn String
"..."
Char
_ <- IO Char
getChar
Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
echo
render :: Direction -> String
render :: Direction -> String
render Direction
Enter = String
">"
render Direction
Exit = String
"<"
portal :: Direction -> String -> String
portal :: Direction -> String -> String
portal Direction
dir String
name = Direction -> String
render Direction
dir forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ Direction -> String
render Direction
dir
indent :: Internal.State -> String
indent :: State -> String
indent State
st = forall a. Int -> a -> [a]
replicate (State -> Int
Internal.debugLevel State
st forall a. Num a => a -> a -> a
* Int
2) Char
' '
indentAndUnlines :: Internal.State -> [String] -> String
indentAndUnlines :: State -> [String] -> String
indentAndUnlines State
st = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (State -> String
indent State
st forall a. [a] -> [a] -> [a]
++)
green, red, white, blue :: Bool -> String -> String
green :: Bool -> String -> String
green = Color -> Bool -> String -> String
colour Color
Green
red :: Bool -> String -> String
red = Color -> Bool -> String -> String
colour Color
Red
white :: Bool -> String -> String
white = Color -> Bool -> String -> String
colour Color
White
blue :: Bool -> String -> String
blue = Color -> Bool -> String -> String
colour Color
Blue
colour :: Color -> Bool -> String -> String
colour :: Color -> Bool -> String -> String
colour Color
_ Bool
True String
s = String
s
colour Color
c Bool
False String
s = forall a. Pretty a => Color -> a -> a
color Color
c String
s
newline, space, carriageReturn, tab, endOfInput :: Bool -> String
newline :: Bool -> String
newline Bool
ascii = Bool -> String -> String
green Bool
ascii String
"↙"
space :: Bool -> String
space Bool
ascii = Bool -> String -> String
white Bool
ascii String
"·"
carriageReturn :: Bool -> String
carriageReturn Bool
ascii = Bool -> String -> String
green Bool
ascii String
"←"
tab :: Bool -> String
tab Bool
ascii = Bool -> String -> String
white Bool
ascii String
"→"
endOfInput :: Bool -> String
endOfInput Bool
ascii = Bool -> String -> String
red Bool
ascii String
"•"
replace :: String -> String -> String -> String
replace :: String -> String -> String -> String
replace String
needle String
replacement String
haystack =
forall a. [a] -> [[a]] -> [a]
intercalate String
replacement (forall a. NonEmpty a -> [a]
NonEmpty.toList (String -> String -> NonEmpty String
splitOn String
needle String
haystack))
splitOn :: String -> String -> NonEmpty String
splitOn :: String -> String -> NonEmpty String
splitOn String
pat = String -> NonEmpty String
go
where go :: String -> NonEmpty String
go String
src
| forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
pat String
src = String
"" forall a. a -> NonEmpty a -> NonEmpty a
<| String -> NonEmpty String
go (forall a. Int -> [a] -> [a]
drop Int
n String
src)
| Char
c:String
cs <- String
src = let (String
w :| [String]
ws) = String -> NonEmpty String
go String
cs in (Char
c forall a. a -> [a] -> [a]
: String
w) forall a. a -> [a] -> NonEmpty a
:| [String]
ws
| Bool
otherwise = String
"" forall a. a -> [a] -> NonEmpty a
:| []
n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pat