{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Hledger.Utils.Debug (
pprint
,pshow
,ptrace
,traceWith
,debugLevel
,ptraceAt
,ptraceAtWith
,dbg0
,dbg1
,dbg2
,dbg3
,dbg4
,dbg5
,dbg6
,dbg7
,dbg8
,dbg9
,dbg0With
,dbg1With
,dbg2With
,dbg3With
,dbg4With
,dbg5With
,dbg6With
,dbg7With
,dbg8With
,dbg9With
,dbgExit
,ptraceAtIO
,dbg0IO
,dbg1IO
,dbg2IO
,dbg3IO
,dbg4IO
,dbg5IO
,dbg6IO
,dbg7IO
,dbg8IO
,dbg9IO
,plog
,plogAt
,traceParse
,dbgparse
,module Debug.Trace
)
where
import Control.Monad (when)
import Control.Monad.IO.Class
import Data.List hiding (uncons)
import qualified Data.Text as T
import Debug.Trace
import Hledger.Utils.Parse
import Safe (readDef)
import System.Environment (getArgs)
import System.Exit
import System.IO.Unsafe (unsafePerformIO)
import Text.Megaparsec
import Text.Printf
import Text.Show.Pretty (ppShow, pPrint)
pprint :: Show a => a -> IO ()
pprint :: a -> IO ()
pprint = a -> IO ()
forall a. Show a => a -> IO ()
pPrint
pshow :: Show a => a -> String
pshow :: a -> String
pshow = a -> String
forall a. Show a => a -> String
ppShow
ptrace :: Show a => a -> a
ptrace :: a -> a
ptrace = (a -> String) -> a -> a
forall a. (a -> String) -> a -> a
traceWith a -> String
forall a. Show a => a -> String
pshow
traceWith :: (a -> String) -> a -> a
traceWith :: (a -> String) -> a -> a
traceWith f :: a -> String
f a :: a
a = String -> a -> a
forall a. String -> a -> a
trace (a -> String
f a
a) a
a
debugLevel :: Int
debugLevel :: Int
debugLevel = case ([String], [String]) -> [String]
forall a b. (a, b) -> b
snd (([String], [String]) -> [String])
-> ([String], [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
=="--debug") [String]
args of
"--debug":[] -> 1
"--debug":n :: String
n:_ -> Int -> String -> Int
forall a. Read a => a -> String -> a
readDef 1 String
n
_ ->
case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take 1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("--debug" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args of
['-':'-':'d':'e':'b':'u':'g':'=':v :: String
v] -> Int -> String -> Int
forall a. Read a => a -> String -> a
readDef 1 String
v
_ -> 0
where
args :: [String]
args = IO [String] -> [String]
forall a. IO a -> a
unsafePerformIO IO [String]
getArgs
ptraceAt :: Show a => Int -> String -> a -> a
ptraceAt :: Int -> String -> a -> a
ptraceAt level :: Int
level
| Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Int
debugLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
level = (a -> String -> a) -> String -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> String -> a
forall a b. a -> b -> a
const
| Bool
otherwise = \s :: String
s a :: a
a -> let p :: String
p = a -> String
forall a. Show a => a -> String
ppShow a
a
ls :: [String]
ls = String -> [String]
lines String
p
nlorspace :: String
nlorspace | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = "\n"
| Bool
otherwise = " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take (10 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (Char -> String
forall a. a -> [a]
repeat ' ')
ls' :: [String]
ls' | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" "String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
ls
| Bool
otherwise = [String]
ls
in String -> a -> a
forall a. String -> a -> a
trace (String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nlorspaceString -> String -> String
forall a. [a] -> [a] -> [a]
++String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
ls') a
a
ptraceAtWith :: Show a => Int -> (a -> String) -> a -> a
ptraceAtWith :: Int -> (a -> String) -> a -> a
ptraceAtWith level :: Int
level f :: a -> String
f
| Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Int
debugLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
level = a -> a
forall a. a -> a
id
| Bool
otherwise = \a :: a
a -> let p :: String
p = a -> String
f a
a
in String -> a -> a
forall a. String -> a -> a
trace String
p a
a
dbg0 :: Show a => String -> a -> a
dbg0 :: String -> a -> a
dbg0 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 0
dbg1 :: Show a => String -> a -> a
dbg1 :: String -> a -> a
dbg1 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 1
dbg2 :: Show a => String -> a -> a
dbg2 :: String -> a -> a
dbg2 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 2
dbg3 :: Show a => String -> a -> a
dbg3 :: String -> a -> a
dbg3 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 3
dbg4 :: Show a => String -> a -> a
dbg4 :: String -> a -> a
dbg4 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 4
dbg5 :: Show a => String -> a -> a
dbg5 :: String -> a -> a
dbg5 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 5
dbg6 :: Show a => String -> a -> a
dbg6 :: String -> a -> a
dbg6 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 6
dbg7 :: Show a => String -> a -> a
dbg7 :: String -> a -> a
dbg7 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 7
dbg8 :: Show a => String -> a -> a
dbg8 :: String -> a -> a
dbg8 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 8
dbg9 :: Show a => String -> a -> a
dbg9 :: String -> a -> a
dbg9 = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt 9
dbg0With :: Show a => (a -> String) -> a -> a
dbg0With :: (a -> String) -> a -> a
dbg0With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 0
dbg1With :: Show a => (a -> String) -> a -> a
dbg1With :: (a -> String) -> a -> a
dbg1With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 1
dbg2With :: Show a => (a -> String) -> a -> a
dbg2With :: (a -> String) -> a -> a
dbg2With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 2
dbg3With :: Show a => (a -> String) -> a -> a
dbg3With :: (a -> String) -> a -> a
dbg3With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 3
dbg4With :: Show a => (a -> String) -> a -> a
dbg4With :: (a -> String) -> a -> a
dbg4With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 4
dbg5With :: Show a => (a -> String) -> a -> a
dbg5With :: (a -> String) -> a -> a
dbg5With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 5
dbg6With :: Show a => (a -> String) -> a -> a
dbg6With :: (a -> String) -> a -> a
dbg6With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 6
dbg7With :: Show a => (a -> String) -> a -> a
dbg7With :: (a -> String) -> a -> a
dbg7With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 7
dbg8With :: Show a => (a -> String) -> a -> a
dbg8With :: (a -> String) -> a -> a
dbg8With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 8
dbg9With :: Show a => (a -> String) -> a -> a
dbg9With :: (a -> String) -> a -> a
dbg9With = Int -> (a -> String) -> a -> a
forall a. Show a => Int -> (a -> String) -> a -> a
ptraceAtWith 9
dbgExit :: Show a => String -> a -> a
dbgExit :: String -> a -> a
dbgExit msg :: String
msg = a -> a -> a
forall a b. a -> b -> a
const (IO a -> a
forall a. IO a -> a
unsafePerformIO IO a
forall a. IO a
exitFailure) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> a
forall a. Show a => String -> a -> a
dbg0 String
msg
ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()
ptraceAtIO :: Int -> String -> a -> m ()
ptraceAtIO lvl :: Int
lvl lbl :: String
lbl x :: a
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
ptraceAt Int
lvl String
lbl a
x a -> IO () -> IO ()
forall a b. a -> b -> b
`seq` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dbg0IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg0IO :: String -> a -> m ()
dbg0IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 0
dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg1IO :: String -> a -> m ()
dbg1IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 1
dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg2IO :: String -> a -> m ()
dbg2IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 2
dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg3IO :: String -> a -> m ()
dbg3IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 3
dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg4IO :: String -> a -> m ()
dbg4IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 4
dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg5IO :: String -> a -> m ()
dbg5IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 5
dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg6IO :: String -> a -> m ()
dbg6IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 6
dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg7IO :: String -> a -> m ()
dbg7IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 7
dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg8IO :: String -> a -> m ()
dbg8IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 8
dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg9IO :: String -> a -> m ()
dbg9IO = Int -> String -> a -> m ()
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
Int -> String -> a -> m ()
ptraceAtIO 9
plog :: Show a => String -> a -> a
plog :: String -> a -> a
plog = Int -> String -> a -> a
forall a. Show a => Int -> String -> a -> a
plogAt 0
plogAt :: Show a => Int -> String -> a -> a
plogAt :: Int -> String -> a -> a
plogAt lvl :: Int
lvl
| Int
lvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Int
debugLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lvl = (a -> String -> a) -> String -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> String -> a
forall a b. a -> b -> a
const
| Bool
otherwise = \s :: String
s a :: a
a ->
let p :: String
p = a -> String
forall a. Show a => a -> String
ppShow a
a
ls :: [String]
ls = String -> [String]
lines String
p
nlorspace :: String
nlorspace | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = "\n"
| Bool
otherwise = " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take (10 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (Char -> String
forall a. a -> [a]
repeat ' ')
ls' :: [String]
ls' | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" "String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
ls
| Bool
otherwise = [String]
ls
output :: String
output = String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nlorspaceString -> String -> String
forall a. [a] -> [a] -> [a]
++String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
ls'String -> String -> String
forall a. [a] -> [a] -> [a]
++"\n"
in IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
appendFile "debug.log" String
output IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
traceParse :: String -> TextParser m ()
traceParse :: String -> TextParser m ()
traceParse msg :: String
msg = do
SourcePos
pos <- ParsecT CustomErr Text m SourcePos
forall e s (m :: * -> *). MonadParsec e s m => m SourcePos
getSourcePos
Text
next <- (Int -> Text -> Text
T.take Int
peeklength) (Text -> Text)
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT CustomErr Text m Text
forall e s (m :: * -> *). MonadParsec e s m => m s
getInput
let (l :: Pos
l,c :: Pos
c) = (SourcePos -> Pos
sourceLine SourcePos
pos, SourcePos -> Pos
sourceColumn SourcePos
pos)
s :: String
s = String -> Int -> Int -> String -> String
forall r. PrintfType r => String -> r
printf "at line %2d col %2d: %s" (Pos -> Int
unPos Pos
l) (Pos -> Int
unPos Pos
c) (Text -> String
forall a. Show a => a -> String
show Text
next) :: String
s' :: String
s' = String -> String -> String
forall r. PrintfType r => String -> r
printf ("%-"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (Int
peeklengthInt -> Int -> Int
forall a. Num a => a -> a -> a
+30)String -> String -> String
forall a. [a] -> [a] -> [a]
++"s") String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
String -> TextParser m () -> TextParser m ()
forall a. String -> a -> a
trace String
s' (TextParser m () -> TextParser m ())
-> TextParser m () -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ () -> TextParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
peeklength :: Int
peeklength = 30
traceParseAt :: Int -> String -> TextParser m ()
traceParseAt :: Int -> String -> TextParser m ()
traceParseAt level :: Int
level msg :: String
msg = Bool -> TextParser m () -> TextParser m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
debugLevel) (TextParser m () -> TextParser m ())
-> TextParser m () -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ String -> TextParser m ()
forall (m :: * -> *). String -> TextParser m ()
traceParse String
msg
dbgparse :: Int -> String -> TextParser m ()
dbgparse :: Int -> String -> TextParser m ()
dbgparse level :: Int
level msg :: String
msg = Int -> String -> TextParser m ()
forall (m :: * -> *). Int -> String -> TextParser m ()
traceParseAt Int
level String
msg