{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}
{-|
Module      : Text.Gigaparsec.Debug
Description : This module contains the very useful debugging combinator, as well as breakpoints.
License     : BSD-3-Clause
Maintainer  : Jamie Willis, Gigaparsec Maintainers
Stability   : stable

This module contains the very useful debugging combinators 'debug' and 'debugWith', as well as
breakpoints that can be used to pause parsing execution.

@since 0.2.1.0
-}
module Text.Gigaparsec.Debug (debug, debugWith, debugConfig, DebugConfig(..), WatchedReg(..), Break(..)) where

import Text.Gigaparsec.Internal (Parsec)
import Text.Gigaparsec.Internal qualified as Internal

import Data.Ref (Ref, readRef)
import Control.Monad (when, forM)
import Control.Monad.RT.Unsafe (RT, unsafeIOToRT)
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))

{-|
Configuration that allows for customising the behaviour of a 'debugWith'
combinator.
-}
type DebugConfig :: *
data DebugConfig = DebugConfig {
    DebugConfig -> Bool
ascii :: !Bool, -- ^ should the output of the combinator be in plain uncoloured ascii?
    DebugConfig -> Break
breakPoint :: !Break, -- ^ should parsing execution be paused when entering or leaving this combinator?
    DebugConfig -> [WatchedReg]
watchedRegs :: ![WatchedReg], -- ^ what registers should have their values tracked during debugging?
    DebugConfig -> Handle
handle :: !Handle -- ^ where should the output of the combinator be sent?
  }

{-|
The plain configuration used by the 'debug' combinator itself. It will have coloured
terminal output (if available), never pause the parsing execution, not track any registers,
and print its output to 'stdout'.
-}
debugConfig :: DebugConfig
debugConfig :: DebugConfig
debugConfig = DebugConfig { ascii :: Bool
ascii = Bool
False, breakPoint :: Break
breakPoint = Break
Never, watchedRegs :: [WatchedReg]
watchedRegs = [], handle :: Handle
handle = Handle
stdout }

{-|
This type allows for a specified register to be watched by a debug combinator. The
contents of the register must be 'Show'able, and it should be given a name to identify
it within the print-out. Registers containing different types can be simultaneously
tracked, which is why this datatype is existential.
-}
type WatchedReg :: *
data WatchedReg = forall r a. Show a => WatchedReg String    -- ^ the name of the register
                                                   (Ref r a) -- ^ the register itself

{-|
This is used by 'DebugConfig' to specify whether the parsing should be paused
when passing through a 'debugWith' combinator.
-}
type Break :: *
data Break = OnEntry -- ^ pause the parsing just after entering a debug combinator
           | OnExit  -- ^ pause the parsing just after leaving a debug combinator
           | Always  -- ^ pause the parsing both just after entry and exit of a debug combinator
           | Never   -- ^ do not pause execution when passing through (__default__)

{-|
This combinator allows this parser to be debugged by providing a trace through the execution.

When this combinator is entered, it will print the name assigned to the parser to the console,
as well as the current input context for a few characters that follow.
This parser is then executed. If it succeeded, this combinator again reports the
name along with \"@Good@\" and the input context. If it failed, it reports the name
along with \"@Bad@\" and the input context.
-}
debug :: String -> Parsec a -> Parsec a
debug :: forall a. [Char] -> Parsec a -> Parsec a
debug = DebugConfig -> [Char] -> Parsec a -> Parsec a
forall a. DebugConfig -> [Char] -> Parsec a -> Parsec a
debugWith DebugConfig
debugConfig

{-|
This combinator allows this parser to be debugged by providing a trace through the execution.
An additional 'DebugConfig' is provided to customise behaviour.

When this combinator is entered, it will print the name assigned to the parser to the
configured handle, as well as the current input context for a few characters that follow.
This parser is then executed. If it succeeded, this combinator again reports the
name along with \"@Good@\" and the input context. If it failed, it reports the name
along with \"@Bad@\" and the input context.

When breakpoints are enabled within the config, the execution of the combinator will pause
on either entry, exit, or both. The parse is resumed by entering any character on standard input.
-}
debugWith :: DebugConfig -> String -> Parsec a -> Parsec a
debugWith :: forall a. DebugConfig -> [Char] -> Parsec a -> Parsec a
debugWith config :: DebugConfig
config@DebugConfig{Bool
ascii :: DebugConfig -> Bool
ascii :: Bool
ascii} [Char]
name (Internal.Parsec forall r.
State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r
p) = (forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
forall a.
(forall r.
 State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
Internal.Parsec ((forall r.
  State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
 -> Parsec a)
-> (forall r.
    State -> (a -> State -> RT r) -> (Error -> State -> RT r) -> RT r)
-> Parsec a
forall a b. (a -> b) -> a -> b
$ \State
st a -> State -> RT r
good Error -> State -> RT r
bad -> do
  -- TODO: could make it so the postamble can print input information from the entry?
  ascii' <- (\Bool
colourful -> Bool
ascii Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
colourful) (Bool -> Bool) -> RT Bool -> RT Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> RT Bool
forall a. IO a -> RT a
unsafeIOToRT IO Bool
supportsPretty
  let config' = DebugConfig
config { ascii = ascii' }
  doDebug name Enter st ""  config'
  let good' a
x State
st' = do
        let st'' :: State
st'' = State
st' { Internal.debugLevel = Internal.debugLevel st' - 1}
        [Char] -> Direction -> State -> [Char] -> DebugConfig -> RT ()
doDebug [Char]
name Direction
Exit State
st'' (Bool -> [Char] -> [Char]
green Bool
ascii' [Char]
" Good") DebugConfig
config'
        a -> State -> RT r
good a
x State
st''
  let bad' Error
err State
st' = do
        let st'' :: State
st'' = State
st' { Internal.debugLevel = Internal.debugLevel st' - 1}
        [Char] -> Direction -> State -> [Char] -> DebugConfig -> RT ()
doDebug [Char]
name Direction
Exit State
st'' (Bool -> [Char] -> [Char]
red Bool
ascii' [Char]
" Bad") DebugConfig
config'
        Error -> State -> RT r
bad Error
err State
st''
  p (st { Internal.debugLevel = Internal.debugLevel st + 1}) good' bad'

---------------------------------------------
---- INTERNALS

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 -> RT ()
doDebug :: [Char] -> Direction -> State -> [Char] -> DebugConfig -> RT ()
doDebug [Char]
name Direction
dir State
st [Char]
end DebugConfig{Bool
[WatchedReg]
Handle
Break
ascii :: DebugConfig -> Bool
breakPoint :: DebugConfig -> Break
watchedRegs :: DebugConfig -> [WatchedReg]
handle :: DebugConfig -> Handle
ascii :: Bool
breakPoint :: Break
watchedRegs :: [WatchedReg]
handle :: Handle
..} = do
  Handle
-> [Char]
-> Direction
-> State
-> [Char]
-> Bool
-> [WatchedReg]
-> RT ()
printInfo Handle
handle [Char]
name Direction
dir State
st [Char]
end Bool
ascii [WatchedReg]
watchedRegs
  Bool -> RT () -> RT ()
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] -> RT ()
printInfo :: Handle
-> [Char]
-> Direction
-> State
-> [Char]
-> Bool
-> [WatchedReg]
-> RT ()
printInfo Handle
handle [Char]
name Direction
dir st :: State
st@Internal.State{[Char]
input :: [Char]
input :: State -> [Char]
input, Word
line :: Word
line :: State -> Word
line, Word
col :: Word
col :: State -> Word
col} [Char]
end Bool
ascii [WatchedReg]
regs = do
  let cs :: [Char]
cs = [Char] -> [Char] -> [Char] -> [Char]
replace [Char]
"\n" (Bool -> [Char]
newline Bool
ascii)
         ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char] -> [Char]
replace [Char]
" " (Bool -> [Char]
space Bool
ascii)
         ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char] -> [Char]
replace [Char]
"\r" (Bool -> [Char]
carriageReturn Bool
ascii)
         ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char] -> [Char]
replace [Char]
"\t" (Bool -> [Char]
tab Bool
ascii)
         ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Char]
input
  let cs' :: [Char]
cs' = if [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) then [Char]
cs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Bool -> [Char]
endOfInput Bool
ascii else [Char]
cs
  let prelude :: [Char]
prelude = Direction -> [Char] -> [Char]
portal Direction
dir [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Word, Word) -> [Char]
forall a. Show a => a -> [Char]
show (Word
line, Word
col) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
  let caret :: [Char]
caret = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
prelude) Char
' ' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Bool -> [Char] -> [Char]
blue Bool
ascii [Char]
"^"
  regSummary <-
    if [WatchedReg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WatchedReg]
regs then [[Char]] -> RT [[Char]]
forall a. a -> RT a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else ([[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
""]) ([[Char]] -> [[Char]])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"watched registers:" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) ([[Char]] -> [[Char]]) -> RT [[Char]] -> RT [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      [WatchedReg] -> (WatchedReg -> RT [Char]) -> RT [[Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [WatchedReg]
regs (\(WatchedReg [Char]
rname Ref r a
reg) ->
        (\a
x -> [Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
x) (a -> [Char]) -> RT a -> RT [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ref r a -> RT a
forall r a. Ref r a -> RT a
readRef Ref r a
reg)
  unsafeIOToRT $
    hPutStr handle $ indentAndUnlines st ((prelude ++ cs' ++ end) : caret : regSummary)

waitForUser :: RT ()
waitForUser :: RT ()
waitForUser = IO () -> RT ()
forall a. IO a -> RT a
unsafeIOToRT (IO () -> RT ()) -> IO () -> RT ()
forall a b. (a -> b) -> a -> b
$ do
  echo <- Handle -> IO Bool
hGetEcho Handle
stdin
  hSetEcho stdin False
  putStrLn "..."
  _ <- getChar
  hSetEcho stdin echo

render :: Direction -> String
render :: Direction -> [Char]
render Direction
Enter = [Char]
">"
render Direction
Exit = [Char]
"<"

portal :: Direction -> String -> String
portal :: Direction -> [Char] -> [Char]
portal Direction
dir [Char]
name = Direction -> [Char]
render Direction
dir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Direction -> [Char]
render Direction
dir

indent :: Internal.State -> String
indent :: State -> [Char]
indent State
st = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (State -> Int
Internal.debugLevel State
st Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '

indentAndUnlines :: Internal.State -> [String] -> String
indentAndUnlines :: State -> [[Char]] -> [Char]
indentAndUnlines State
st = [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (State -> [Char]
indent State
st [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

green, red, white, blue :: Bool -> String -> String
green :: Bool -> [Char] -> [Char]
green = Color -> Bool -> [Char] -> [Char]
colour Color
Green
red :: Bool -> [Char] -> [Char]
red = Color -> Bool -> [Char] -> [Char]
colour Color
Red
white :: Bool -> [Char] -> [Char]
white = Color -> Bool -> [Char] -> [Char]
colour Color
White
blue :: Bool -> [Char] -> [Char]
blue = Color -> Bool -> [Char] -> [Char]
colour Color
Blue

colour :: Color -> Bool -> String -> String
colour :: Color -> Bool -> [Char] -> [Char]
colour Color
_ Bool
True [Char]
s = [Char]
s
colour Color
c Bool
False [Char]
s = Color -> [Char] -> [Char]
forall a. Pretty a => Color -> a -> a
color Color
c [Char]
s

newline, space, carriageReturn, tab, endOfInput :: Bool -> String
newline :: Bool -> [Char]
newline Bool
ascii = Bool -> [Char] -> [Char]
green Bool
ascii [Char]
"↙"
space :: Bool -> [Char]
space Bool
ascii = Bool -> [Char] -> [Char]
white Bool
ascii [Char]
"·"
carriageReturn :: Bool -> [Char]
carriageReturn Bool
ascii = Bool -> [Char] -> [Char]
green Bool
ascii [Char]
"←"
tab :: Bool -> [Char]
tab Bool
ascii = Bool -> [Char] -> [Char]
white Bool
ascii [Char]
"→"
endOfInput :: Bool -> [Char]
endOfInput Bool
ascii = Bool -> [Char] -> [Char]
red Bool
ascii [Char]
"•"

replace :: String -> String -> String -> String
replace :: [Char] -> [Char] -> [Char] -> [Char]
replace [Char]
needle [Char]
replacement [Char]
haystack =
  [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
replacement (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NonEmpty.toList ([Char] -> [Char] -> NonEmpty [Char]
splitOn [Char]
needle [Char]
haystack))

splitOn :: String -> String -> NonEmpty String
splitOn :: [Char] -> [Char] -> NonEmpty [Char]
splitOn [Char]
pat = [Char] -> NonEmpty [Char]
go
  where go :: [Char] -> NonEmpty [Char]
go [Char]
src
          | [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
pat [Char]
src = [Char]
"" [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
<| [Char] -> NonEmpty [Char]
go (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
n [Char]
src)
          | Char
c:[Char]
cs <- [Char]
src        = let ([Char]
w :| [[Char]]
ws) = [Char] -> NonEmpty [Char]
go [Char]
cs in (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
w) [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [[Char]]
ws
          | Bool
otherwise          = [Char]
"" [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| []
        n :: Int
n = [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
pat