slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

clean up debug helpers (api change)

Browse Source
This commit is contained in:
Simon Michael 2018-07-16 15:28:58 +01:00
parent 9d2e80aa2c
commit d5430e7ddf
6 changed files with 153 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
hledger-lib/Hledger/Read/Common.hs
View File

@ -719,7 +719,7 @@ numberp :: Maybe AmountStyle -> TextParser m (Quantity, Int, Maybe Char, Maybe D
numberp suggestedStyle = label "number" $ do
-- a number is an optional sign followed by a sequence of digits possibly
-- interspersed with periods, commas, or both
-- ptrace "numberp"
-- dbgparse 0 "numberp"
sign <- signp
rawNum <- either (disambiguateNumber suggestedStyle) id <$> rawnumberp
mExp <- optional $ try $ exponentp
@ -1214,7 +1214,7 @@ commenttagsanddatesp mYear = do
bracketeddatetagsp
:: Maybe Year -> TextParser m [(TagName, Day)]
bracketeddatetagsp mYear1 = do
-- pdbg 0 "bracketeddatetagsp"
-- dbgparse 0 "bracketeddatetagsp"
try $ do
s <- lookAhead
$ between (char '[') (char ']')

24
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -441,7 +441,7 @@ rulesp = do
}
blankorcommentlinep :: CsvRulesParser ()
blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
blankorcommentlinep = lift (dbgparse 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
blanklinep :: CsvRulesParser ()
blanklinep = lift (skipMany spacenonewline) >> newline >> return () <?> "blank line"
@ -454,7 +454,7 @@ commentcharp = oneOf (";#*" :: [Char])
directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do
lift $ pdbg 3 "trying directive"
lift $ dbgparse 3 "trying directive"
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> lift (skipMany spacenonewline) >> lift eolof >> return "")
@ -477,7 +477,7 @@ directivevalp = anyChar `manyTill` lift eolof
fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do
lift $ pdbg 3 "trying fieldnamelist"
lift $ dbgparse 3 "trying fieldnamelist"
string "fields"
optional $ char ':'
lift (skipSome spacenonewline)
@ -503,7 +503,7 @@ barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)
fieldassignmentp = do
lift $ pdbg 3 "trying fieldassignmentp"
lift $ dbgparse 3 "trying fieldassignmentp"
f <- journalfieldnamep
assignmentseparatorp
v <- fieldvalp
@ -512,7 +512,7 @@ fieldassignmentp = do
journalfieldnamep :: CsvRulesParser String
journalfieldnamep = do
lift (pdbg 2 "trying journalfieldnamep")
lift (dbgparse 2 "trying journalfieldnamep")
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
-- Transaction fields and pseudo fields for CSV conversion.
@ -536,7 +536,7 @@ journalfieldnames = [
assignmentseparatorp :: CsvRulesParser ()
assignmentseparatorp = do
lift $ pdbg 3 "trying assignmentseparatorp"
lift $ dbgparse 3 "trying assignmentseparatorp"
choice [
-- try (lift (skipMany spacenonewline) >> oneOf ":="),
try (lift (skipMany spacenonewline) >> char ':'),
@ -547,12 +547,12 @@ assignmentseparatorp = do
fieldvalp :: CsvRulesParser String
fieldvalp = do
lift $ pdbg 2 "trying fieldvalp"
lift $ dbgparse 2 "trying fieldvalp"
anyChar `manyTill` lift eolof
conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do
lift $ pdbg 3 "trying conditionalblockp"
lift $ dbgparse 3 "trying conditionalblockp"
string "if" >> lift (skipMany spacenonewline) >> optional newline
ms <- some recordmatcherp
as <- many (lift (skipSome spacenonewline) >> fieldassignmentp)
@ -563,7 +563,7 @@ conditionalblockp = do
recordmatcherp :: CsvRulesParser [String]
recordmatcherp = do
lift $ pdbg 2 "trying recordmatcherp"
lift $ dbgparse 2 "trying recordmatcherp"
-- pos <- currentPos
_ <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline)
ps <- patternsp
@ -582,20 +582,20 @@ matchoperatorp = fmap T.unpack $ choiceInState $ map string
patternsp :: CsvRulesParser [String]
patternsp = do
lift $ pdbg 3 "trying patternsp"
lift $ dbgparse 3 "trying patternsp"
ps <- many regexp
return ps
regexp :: CsvRulesParser String
regexp = do
lift $ pdbg 3 "trying regexp"
lift $ dbgparse 3 "trying regexp"
notFollowedBy matchoperatorp
c <- lift nonspace
cs <- anyChar `manyTill` lift eolof
return $ strip $ c:cs
-- fieldmatcher = do
-- pdbg 2 "trying fieldmatcher"
-- dbgparse 2 "trying fieldmatcher"
-- f <- fromMaybe "all" `fmap` (optional $ do
-- f' <- fieldname
-- lift (skipMany spacenonewline)

8
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -357,7 +357,7 @@ accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: TextParser m AccountAlias
basicaliasp = do
-- pdbg 0 "basicaliasp"
-- dbgparse 0 "basicaliasp"
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
char '='
skipMany spacenonewline
@ -366,7 +366,7 @@ basicaliasp = do
regexaliasp :: TextParser m AccountAlias
regexaliasp = do
-- pdbg 0 "regexaliasp"
-- dbgparse 0 "regexaliasp"
char '/'
re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end
char '/'
@ -504,7 +504,7 @@ periodictransactionp = do
-- | Parse a (possibly unbalanced) transaction.
transactionp :: JournalParser m Transaction
transactionp = do
-- ptrace "transactionp"
-- dbgparse 0 "transactionp"
startpos <- getPosition
date <- datep <?> "transaction"
edate <- optional (lift $ secondarydatep date) <?> "secondary date"
@ -628,7 +628,7 @@ postingsp mTransactionYear = many (postingp mTransactionYear) <?> "postings"
postingp :: Maybe Year -> JournalParser m Posting
postingp mTransactionYear = do
-- pdbg 0 "postingp"
-- dbgparse 0 "postingp"
(status, account) <- try $ do
lift (skipSome spacenonewline)
status <- lift statusp

16
hledger-lib/Hledger/Read/TimedotReader.hs
View File

@ -49,13 +49,13 @@ import Text.Megaparsec.Char
import Hledger.Data
import Hledger.Read.Common
import Hledger.Utils hiding (ptrace)
import Hledger.Utils hiding (traceParse)
-- easier to toggle this here sometimes
-- import qualified Hledger.Utils (ptrace)
-- ptrace = Hledger.Utils.ptrace
ptrace :: Monad m => a -> m a
ptrace = return
-- import qualified Hledger.Utils (parsertrace)
-- parsertrace = Hledger.Utils.parsertrace
traceParse :: Monad m => a -> m a
traceParse = return
reader :: Reader
reader = Reader
@ -76,7 +76,7 @@ timedotfilep = do many timedotfileitemp
where
timedotfileitemp :: JournalParser m ()
timedotfileitemp = do
ptrace "timedotfileitemp"
traceParse "timedotfileitemp"
choice [
void $ lift emptyorcommentlinep
,timedotdayp >>= \ts -> modify' (addTransactions ts)
@ -94,7 +94,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
-- @
timedotdayp :: JournalParser m [Transaction]
timedotdayp = do
ptrace " timedotdayp"
traceParse " timedotdayp"
d <- datep <* lift eolof
es <- catMaybes <$> many (const Nothing <$> try (lift emptyorcommentlinep) <|>
Just <$> (notFollowedBy datep >> timedotentryp))
@ -106,7 +106,7 @@ timedotdayp = do
-- @
timedotentryp :: JournalParser m Transaction
timedotentryp = do
ptrace " timedotentryp"
traceParse " timedotentryp"
pos <- genericSourcePos <$> getPosition
lift (skipMany spacenonewline)
a <- modifiedaccountnamep

255
hledger-lib/Hledger/Utils/Debug.hs
View File

@ -8,7 +8,38 @@
-- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html
module Hledger.Utils.Debug (
module Hledger.Utils.Debug
pprint
,pshow
,ptrace
,traceWith
,debugLevel
,ptraceAt
,dbg0
,dbgExit
,dbg1
,dbg2
,dbg3
,dbg4
,dbg5
,dbg6
,dbg7
,dbg8
,dbg9
,ptraceAtIO
,dbg0IO
,dbg1IO
,dbg2IO
,dbg3IO
,dbg4IO
,dbg5IO
,dbg6IO
,dbg7IO
,dbg8IO
,dbg9IO
,plog
,plogAt
,traceParse
,dbgparse
,module Debug.Trace
)
where
@ -27,31 +58,22 @@ import Text.Megaparsec
import Text.Printf
import Text.Show.Pretty (ppShow, pPrint)
-- | Easier alias for pretty-show's pPrint.
-- | Pretty print. Easier alias for pretty-show's pPrint.
pprint :: Show a => a -> IO ()
pprint = pPrint
-- | Easier alias for pretty-show's ppShow.
-- | Pretty show. Easier alias for pretty-show's ppShow.
pshow :: Show a => a -> String
pshow = ppShow
-- | Pretty trace. Easier alias for traceShowId + ppShow.
ptrace :: Show a => a -> a
ptrace = traceWith pshow
-- | Trace (print to stderr) a showable value using a custom show function.
traceWith :: (a -> String) -> a -> a
traceWith f a = trace (f a) a
-- | Parsec trace - show the current parsec position and next input,
-- and the provided label if it's non-null.
ptrace :: String -> TextParser m ()
ptrace msg = do
pos <- getPosition
next <- (T.take peeklength) `fmap` getInput
let (l,c) = (sourceLine pos, sourceColumn pos)
s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String
s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg
trace s' $ return ()
where
peeklength = 30
-- | Global debug level, which controls the verbosity of debug output
-- on the console. The default is 0 meaning no debug output. The
-- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to
@ -75,105 +97,109 @@ debugLevel = case snd $ break (=="--debug") args of
where
args = unsafePerformIO getArgs
-- | Convenience aliases for tracePrettyAt.
-- | Pretty-print a label and a showable value to the console
-- if the global debug level is at or above the specified level.
-- At level 0, always prints. Otherwise, uses unsafePerformIO.
ptraceAt :: Show a => Int -> String -> a -> a
ptraceAt level
| level > 0 && debugLevel < level = flip const
| otherwise = \s a -> let p = ppShow a
ls = lines p
nlorspace | length ls > 1 = "\n"
| otherwise = " " ++ take (10 - length s) (repeat ' ')
ls' | length ls > 1 = map (" "++) ls
| otherwise = ls
in trace (s++":"++nlorspace++intercalate "\n" ls') a
-- Always pretty-print a message and the showable value to the console, then return it.
-- ("dbg" without the 0 clashes with megaparsec 5.1).
-- | Pretty-print a message and the showable value to the console, then return it.
dbg0 :: Show a => String -> a -> a
dbg0 = tracePrettyAt 0
dbg0 = ptraceAt 0
-- "dbg" would clash with megaparsec
-- | Pretty-print a message and the showable value to the console when the debug level is >= 1, then return it. Uses unsafePerformIO.
-- | Like dbg0, but also exit the program. Uses unsafePerformIO.
dbgExit :: Show a => String -> a -> a
dbgExit msg = const (unsafePerformIO exitFailure) . dbg0 msg
-- | Pretty-print a message and the showable value to the console when the global debug level is >= 1, then return it.
-- Uses unsafePerformIO.
dbg1 :: Show a => String -> a -> a
dbg1 = tracePrettyAt 1
dbg1 = ptraceAt 1
dbg2 :: Show a => String -> a -> a
dbg2 = tracePrettyAt 2
dbg2 = ptraceAt 2
dbg3 :: Show a => String -> a -> a
dbg3 = tracePrettyAt 3
dbg3 = ptraceAt 3
dbg4 :: Show a => String -> a -> a
dbg4 = tracePrettyAt 4
dbg4 = ptraceAt 4
dbg5 :: Show a => String -> a -> a
dbg5 = tracePrettyAt 5
dbg5 = ptraceAt 5
dbg6 :: Show a => String -> a -> a
dbg6 = tracePrettyAt 6
dbg6 = ptraceAt 6
dbg7 :: Show a => String -> a -> a
dbg7 = tracePrettyAt 7
dbg7 = ptraceAt 7
dbg8 :: Show a => String -> a -> a
dbg8 = tracePrettyAt 8
dbg8 = ptraceAt 8
dbg9 :: Show a => String -> a -> a
dbg9 = tracePrettyAt 9
dbg9 = ptraceAt 9
-- | Convenience aliases for tracePrettyAtIO.
-- Like dbg, but convenient to insert in an IO monad.
-- XXX These have a bug; they should use traceIO, not trace,
-- otherwise GHC can occasionally over-optimise
-- | Like ptraceAt, but convenient to insert in an IO monad (plus
-- convenience aliases).
-- XXX These have a bug; they should use
-- traceIO, not trace, otherwise GHC can occasionally over-optimise
-- (cf lpaste a few days ago where it killed/blocked a child thread).
ptraceAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()
ptraceAtIO lvl lbl x = liftIO $ ptraceAt lvl lbl x `seq` return ()
-- XXX Could not deduce (a ~ ())
-- ptraceAtM :: (Monad m, Show a) => Int -> String -> a -> m a
-- ptraceAtM lvl lbl x = ptraceAt lvl lbl x `seq` return x
dbg0IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg0IO = tracePrettyAtIO 0
dbg0IO = ptraceAtIO 0
dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg1IO = tracePrettyAtIO 1
dbg1IO = ptraceAtIO 1
dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg2IO = tracePrettyAtIO 2
dbg2IO = ptraceAtIO 2
dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg3IO = tracePrettyAtIO 3
dbg3IO = ptraceAtIO 3
dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg4IO = tracePrettyAtIO 4
dbg4IO = ptraceAtIO 4
dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg5IO = tracePrettyAtIO 5
dbg5IO = ptraceAtIO 5
dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg6IO = tracePrettyAtIO 6
dbg6IO = ptraceAtIO 6
dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg7IO = tracePrettyAtIO 7
dbg7IO = ptraceAtIO 7
dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg8IO = tracePrettyAtIO 8
dbg8IO = ptraceAtIO 8
dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()
dbg9IO = tracePrettyAtIO 9
dbg9IO = ptraceAtIO 9
-- | Pretty-print a message and a showable value to the console if the debug level is at or above the specified level.
-- At level 0, always prints. Otherwise, uses unsafePerformIO.
tracePrettyAt :: Show a => Int -> String -> a -> a
tracePrettyAt lvl = dbgppshow lvl
-- tracePrettyAtM :: (Monad m, Show a) => Int -> String -> a -> m a
-- tracePrettyAtM lvl lbl x = tracePrettyAt lvl lbl x `seq` return x
-- XXX Could not deduce (a ~ ())
-- from the context (Show a)
-- bound by the type signature for
-- dbgM :: Show a => String -> a -> IO ()
-- at hledger/Hledger/Cli/Main.hs:200:13-42
-- ‘a’ is a rigid type variable bound by
-- the type signature for dbgM :: Show a => String -> a -> IO ()
-- at hledger/Hledger/Cli/Main.hs:200:13
-- Expected type: String -> a -> IO ()
-- Actual type: String -> a -> IO a
tracePrettyAtIO :: (MonadIO m, Show a) => Int -> String -> a -> m ()
tracePrettyAtIO lvl lbl x = liftIO $ tracePrettyAt lvl lbl x `seq` return ()
log0 :: Show a => String -> a -> a
log0 = logPrettyAt 0
-- | Log a message and a pretty-printed showable value to ./debug.log, then return it.
plog :: Show a => String -> a -> a
plog = plogAt 0
-- | Log a message and a pretty-printed showable value to ./debug.log,
-- if the debug level is at or above the specified level.
-- if the global debug level is at or above the specified level.
-- At level 0, always logs. Otherwise, uses unsafePerformIO.
logPrettyAt :: Show a => Int -> String -> a -> a
logPrettyAt lvl
plogAt :: Show a => Int -> String -> a -> a
plogAt lvl
| lvl > 0 && debugLevel < lvl = flip const
| otherwise = \s a ->
let p = ppShow a
@ -185,66 +211,37 @@ logPrettyAt lvl
output = s++":"++nlorspace++intercalate "\n" ls'
in unsafePerformIO $ appendFile "debug.log" output >> return a
-- | print this string to the console before evaluating the expression,
-- if the global debug level is at or above the specified level. Uses unsafePerformIO.
-- dbgtrace :: Int -> String -> a -> a
-- dbgtrace level
-- | debugLevel >= level = trace
-- | otherwise = flip const
-- XXX redundant ? More/less robust than log0 ?
-- -- | Like dbg, but writes the output to "debug.log" in the current directory.
-- -- Uses unsafePerformIO. Can fail due to log file contention if called too quickly
-- -- ("*** Exception: debug.log: openFile: resource busy (file is locked)").
-- dbglog :: Show a => String -> a -> a
-- dbglog label a =
-- (unsafePerformIO $
-- appendFile "debug.log" $ label ++ ": " ++ ppShow a ++ "\n")
-- `seq` a
-- | Print a showable value to the console, with a message, if the
-- debug level is at or above the specified level (uses
-- unsafePerformIO).
-- Values are displayed with show, all on one line, which is hard to read.
-- dbgshow :: Show a => Int -> String -> a -> a
-- dbgshow level
-- | debugLevel >= level = ltrace
-- | otherwise = flip const
-- | Print the provided label (if non-null) and current parser state
-- (position and next input) to the console. (See also megaparsec's dbg.)
traceParse :: String -> TextParser m ()
traceParse msg = do
pos <- getPosition
next <- (T.take peeklength) `fmap` getInput
let (l,c) = (sourceLine pos, sourceColumn pos)
s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String
s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg
trace s' $ return ()
where
peeklength = 30
-- | Print a showable value to the console, with a message, if the
-- debug level is at or above the specified level (uses
-- unsafePerformIO).
-- Values are displayed with ppShow, each field/constructor on its own line.
dbgppshow :: Show a => Int -> String -> a -> a
dbgppshow level
| level > 0 && debugLevel < level = flip const
| otherwise = \s a -> let p = ppShow a
ls = lines p
nlorspace | length ls > 1 = "\n"
| otherwise = " " ++ take (10 - length s) (repeat ' ')
ls' | length ls > 1 = map (" "++) ls
| otherwise = ls
in trace (s++":"++nlorspace++intercalate "\n" ls') a
-- | Print the provided label (if non-null) and current parser state
-- (position and next input) to the console if the global debug level
-- is at or above the specified level. Uses unsafePerformIO.
-- (See also megaparsec's dbg.)
traceParseAt :: Int -> String -> TextParser m ()
traceParseAt level msg = when (level <= debugLevel) $ traceParse msg
-- -- | Print a showable value to the console, with a message, if the
-- -- debug level is at or above the specified level (uses
-- -- unsafePerformIO).
-- -- Values are displayed with pprint. Field names are not shown, but the
-- -- output is compact with smart line wrapping, long data elided,
-- -- and slow calculations timed out.
-- dbgpprint :: Data a => Int -> String -> a -> a
-- dbgpprint level msg a
-- | debugLevel >= level = unsafePerformIO $ do
-- pprint a >>= putStrLn . ((msg++": \n") ++) . show
-- return a
-- | otherwise = a
-- | Convenience alias for traceParseAt
dbgparse :: Int -> String -> TextParser m ()
dbgparse level msg = traceParseAt level msg
-- | Like dbg, then exit the program. Uses unsafePerformIO.
dbgExit :: Show a => String -> a -> a
dbgExit msg = const (unsafePerformIO exitFailure) . dbg0 msg
-- | Print a message and parsec debug info (parse position and next
-- input) to the console when the debug level is at or above
-- this level. Uses unsafePerformIO.
-- pdbgAt :: GenParser m => Float -> String -> m ()
pdbg :: Int -> String -> TextParser m ()
pdbg level msg = when (level <= debugLevel) $ ptrace msg
-- | Like dbg, but writes the output to "debug.log" in the current directory.
-- Uses unsafePerformIO. Can fail due to log file contention if called too quickly
-- ("*** Exception: debug.log: openFile: resource busy (file is locked)").
dbglog :: Show a => String -> a -> a
dbglog label a =
(unsafePerformIO $
appendFile "debug.log" $ label ++ ": " ++ ppShow a ++ "\n")
`seq` a

2
hledger/Hledger/Cli/Main.hs
View File

@ -115,7 +115,7 @@ main = do
(argsbeforecmd, argsaftercmd') = break (==rawcmd) args
argsaftercmd = drop 1 argsaftercmd'
dbgIO :: Show a => String -> a -> IO ()
dbgIO = tracePrettyAtIO 2
dbgIO = ptraceAtIO 2
dbgIO "running" prognameandversion
dbgIO "raw args" args