{-# 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. String -> Parsec a -> Parsec a
debug = DebugConfig -> String -> Parsec a -> Parsec a
forall a. DebugConfig -> String -> 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 -> String -> Parsec a -> Parsec a
debugWith config :: DebugConfig
config@DebugConfig{Bool
ascii :: DebugConfig -> Bool
ascii :: Bool
ascii} String
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}
        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' Error
err State
st' = do
        let st'' :: State
st'' = State
st' { Internal.debugLevel = Internal.debugLevel st' - 1}
        String -> Direction -> State -> String -> DebugConfig -> RT ()
doDebug String
name Direction
Exit State
st'' (Bool -> String -> String
red Bool
ascii' String
" 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 :: String -> Direction -> State -> String -> DebugConfig -> RT ()
doDebug String
name Direction
dir State
st String
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
-> String
-> Direction
-> State
-> String
-> Bool
-> [WatchedReg]
-> RT ()
printInfo Handle
handle String
name Direction
dir State
st String
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
-> String
-> Direction
-> State
-> String
-> Bool
-> [WatchedReg]
-> RT ()
printInfo Handle
handle String
name Direction
dir st :: State
st@Internal.State{String
input :: String
input :: State -> String
input, Word
line :: Word
line :: State -> Word
line, Word
col :: Word
col :: State -> 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)
         (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
" " (Bool -> String
space Bool
ascii)
         (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"\r" (Bool -> String
carriageReturn Bool
ascii)
         (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"\t" (Bool -> String
tab Bool
ascii)
         (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
input
  let cs' :: String
cs' = if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
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 String
cs String -> String -> String
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Word, Word) -> String
forall a. Show a => a -> String
show (Word
line, Word
col) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
  let caret :: String
caret = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prelude) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String -> String
blue Bool
ascii String
"^"
  regSummary <-
    if [WatchedReg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WatchedReg]
regs then [String] -> RT [String]
forall a. a -> RT a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""]) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"watched registers:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> RT [String] -> RT [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      [WatchedReg] -> (WatchedReg -> RT String) -> RT [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [WatchedReg]
regs (\(WatchedReg String
rname Ref r a
reg) ->
        (\a
x -> String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x) (a -> String) -> RT a -> RT String
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 -> 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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Direction -> String
render Direction
dir

indent :: Internal.State -> String
indent :: State -> String
indent State
st = Int -> Char -> String
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 -> [String] -> String
indentAndUnlines State
st = [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (State -> String
indent State
st String -> String -> String
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 = Color -> String -> String
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 =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
replacement (NonEmpty String -> [String]
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
          | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
pat String
src = String
"" String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
<| String -> NonEmpty String
go (Int -> String -> String
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 Char -> String -> String
forall a. a -> [a] -> [a]
: String
w) String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [String]
ws
          | Bool
otherwise          = String
"" String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []
        n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pat