mirror of
https://github.com/simonmichael/hledger.git
synced 2024-11-08 07:09:28 +03:00
clean up debug helpers (api change)
This commit is contained in:
parent
9d2e80aa2c
commit
d5430e7ddf
@ -719,7 +719,7 @@ numberp :: Maybe AmountStyle -> TextParser m (Quantity, Int, Maybe Char, Maybe D
|
|||||||
numberp suggestedStyle = label "number" $ do
|
numberp suggestedStyle = label "number" $ do
|
||||||
-- a number is an optional sign followed by a sequence of digits possibly
|
-- a number is an optional sign followed by a sequence of digits possibly
|
||||||
-- interspersed with periods, commas, or both
|
-- interspersed with periods, commas, or both
|
||||||
-- ptrace "numberp"
|
-- dbgparse 0 "numberp"
|
||||||
sign <- signp
|
sign <- signp
|
||||||
rawNum <- either (disambiguateNumber suggestedStyle) id <$> rawnumberp
|
rawNum <- either (disambiguateNumber suggestedStyle) id <$> rawnumberp
|
||||||
mExp <- optional $ try $ exponentp
|
mExp <- optional $ try $ exponentp
|
||||||
@ -1214,7 +1214,7 @@ commenttagsanddatesp mYear = do
|
|||||||
bracketeddatetagsp
|
bracketeddatetagsp
|
||||||
:: Maybe Year -> TextParser m [(TagName, Day)]
|
:: Maybe Year -> TextParser m [(TagName, Day)]
|
||||||
bracketeddatetagsp mYear1 = do
|
bracketeddatetagsp mYear1 = do
|
||||||
-- pdbg 0 "bracketeddatetagsp"
|
-- dbgparse 0 "bracketeddatetagsp"
|
||||||
try $ do
|
try $ do
|
||||||
s <- lookAhead
|
s <- lookAhead
|
||||||
$ between (char '[') (char ']')
|
$ between (char '[') (char ']')
|
||||||
|
@ -441,7 +441,7 @@ rulesp = do
|
|||||||
}
|
}
|
||||||
|
|
||||||
blankorcommentlinep :: CsvRulesParser ()
|
blankorcommentlinep :: CsvRulesParser ()
|
||||||
blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
|
blankorcommentlinep = lift (dbgparse 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
|
||||||
|
|
||||||
blanklinep :: CsvRulesParser ()
|
blanklinep :: CsvRulesParser ()
|
||||||
blanklinep = lift (skipMany spacenonewline) >> newline >> return () <?> "blank line"
|
blanklinep = lift (skipMany spacenonewline) >> newline >> return () <?> "blank line"
|
||||||
@ -454,7 +454,7 @@ commentcharp = oneOf (";#*" :: [Char])
|
|||||||
|
|
||||||
directivep :: CsvRulesParser (DirectiveName, String)
|
directivep :: CsvRulesParser (DirectiveName, String)
|
||||||
directivep = (do
|
directivep = (do
|
||||||
lift $ pdbg 3 "trying directive"
|
lift $ dbgparse 3 "trying directive"
|
||||||
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives
|
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives
|
||||||
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
|
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
|
||||||
<|> (optional (char ':') >> lift (skipMany spacenonewline) >> lift eolof >> return "")
|
<|> (optional (char ':') >> lift (skipMany spacenonewline) >> lift eolof >> return "")
|
||||||
@ -477,7 +477,7 @@ directivevalp = anyChar `manyTill` lift eolof
|
|||||||
|
|
||||||
fieldnamelistp :: CsvRulesParser [CsvFieldName]
|
fieldnamelistp :: CsvRulesParser [CsvFieldName]
|
||||||
fieldnamelistp = (do
|
fieldnamelistp = (do
|
||||||
lift $ pdbg 3 "trying fieldnamelist"
|
lift $ dbgparse 3 "trying fieldnamelist"
|
||||||
string "fields"
|
string "fields"
|
||||||
optional $ char ':'
|
optional $ char ':'
|
||||||
lift (skipSome spacenonewline)
|
lift (skipSome spacenonewline)
|
||||||
@ -503,7 +503,7 @@ barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
|
|||||||
|
|
||||||
fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)
|
fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)
|
||||||
fieldassignmentp = do
|
fieldassignmentp = do
|
||||||
lift $ pdbg 3 "trying fieldassignmentp"
|
lift $ dbgparse 3 "trying fieldassignmentp"
|
||||||
f <- journalfieldnamep
|
f <- journalfieldnamep
|
||||||
assignmentseparatorp
|
assignmentseparatorp
|
||||||
v <- fieldvalp
|
v <- fieldvalp
|
||||||
@ -512,7 +512,7 @@ fieldassignmentp = do
|
|||||||
|
|
||||||
journalfieldnamep :: CsvRulesParser String
|
journalfieldnamep :: CsvRulesParser String
|
||||||
journalfieldnamep = do
|
journalfieldnamep = do
|
||||||
lift (pdbg 2 "trying journalfieldnamep")
|
lift (dbgparse 2 "trying journalfieldnamep")
|
||||||
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
|
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
|
||||||
|
|
||||||
-- Transaction fields and pseudo fields for CSV conversion.
|
-- Transaction fields and pseudo fields for CSV conversion.
|
||||||
@ -536,7 +536,7 @@ journalfieldnames = [
|
|||||||
|
|
||||||
assignmentseparatorp :: CsvRulesParser ()
|
assignmentseparatorp :: CsvRulesParser ()
|
||||||
assignmentseparatorp = do
|
assignmentseparatorp = do
|
||||||
lift $ pdbg 3 "trying assignmentseparatorp"
|
lift $ dbgparse 3 "trying assignmentseparatorp"
|
||||||
choice [
|
choice [
|
||||||
-- try (lift (skipMany spacenonewline) >> oneOf ":="),
|
-- try (lift (skipMany spacenonewline) >> oneOf ":="),
|
||||||
try (lift (skipMany spacenonewline) >> char ':'),
|
try (lift (skipMany spacenonewline) >> char ':'),
|
||||||
@ -547,12 +547,12 @@ assignmentseparatorp = do
|
|||||||
|
|
||||||
fieldvalp :: CsvRulesParser String
|
fieldvalp :: CsvRulesParser String
|
||||||
fieldvalp = do
|
fieldvalp = do
|
||||||
lift $ pdbg 2 "trying fieldvalp"
|
lift $ dbgparse 2 "trying fieldvalp"
|
||||||
anyChar `manyTill` lift eolof
|
anyChar `manyTill` lift eolof
|
||||||
|
|
||||||
conditionalblockp :: CsvRulesParser ConditionalBlock
|
conditionalblockp :: CsvRulesParser ConditionalBlock
|
||||||
conditionalblockp = do
|
conditionalblockp = do
|
||||||
lift $ pdbg 3 "trying conditionalblockp"
|
lift $ dbgparse 3 "trying conditionalblockp"
|
||||||
string "if" >> lift (skipMany spacenonewline) >> optional newline
|
string "if" >> lift (skipMany spacenonewline) >> optional newline
|
||||||
ms <- some recordmatcherp
|
ms <- some recordmatcherp
|
||||||
as <- many (lift (skipSome spacenonewline) >> fieldassignmentp)
|
as <- many (lift (skipSome spacenonewline) >> fieldassignmentp)
|
||||||
@ -563,7 +563,7 @@ conditionalblockp = do
|
|||||||
|
|
||||||
recordmatcherp :: CsvRulesParser [String]
|
recordmatcherp :: CsvRulesParser [String]
|
||||||
recordmatcherp = do
|
recordmatcherp = do
|
||||||
lift $ pdbg 2 "trying recordmatcherp"
|
lift $ dbgparse 2 "trying recordmatcherp"
|
||||||
-- pos <- currentPos
|
-- pos <- currentPos
|
||||||
_ <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline)
|
_ <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline)
|
||||||
ps <- patternsp
|
ps <- patternsp
|
||||||
@ -582,20 +582,20 @@ matchoperatorp = fmap T.unpack $ choiceInState $ map string
|
|||||||
|
|
||||||
patternsp :: CsvRulesParser [String]
|
patternsp :: CsvRulesParser [String]
|
||||||
patternsp = do
|
patternsp = do
|
||||||
lift $ pdbg 3 "trying patternsp"
|
lift $ dbgparse 3 "trying patternsp"
|
||||||
ps <- many regexp
|
ps <- many regexp
|
||||||
return ps
|
return ps
|
||||||
|
|
||||||
regexp :: CsvRulesParser String
|
regexp :: CsvRulesParser String
|
||||||
regexp = do
|
regexp = do
|
||||||
lift $ pdbg 3 "trying regexp"
|
lift $ dbgparse 3 "trying regexp"
|
||||||
notFollowedBy matchoperatorp
|
notFollowedBy matchoperatorp
|
||||||
c <- lift nonspace
|
c <- lift nonspace
|
||||||
cs <- anyChar `manyTill` lift eolof
|
cs <- anyChar `manyTill` lift eolof
|
||||||
return $ strip $ c:cs
|
return $ strip $ c:cs
|
||||||
|
|
||||||
-- fieldmatcher = do
|
-- fieldmatcher = do
|
||||||
-- pdbg 2 "trying fieldmatcher"
|
-- dbgparse 2 "trying fieldmatcher"
|
||||||
-- f <- fromMaybe "all" `fmap` (optional $ do
|
-- f <- fromMaybe "all" `fmap` (optional $ do
|
||||||
-- f' <- fieldname
|
-- f' <- fieldname
|
||||||
-- lift (skipMany spacenonewline)
|
-- lift (skipMany spacenonewline)
|
||||||
|
@ -357,7 +357,7 @@ accountaliasp = regexaliasp <|> basicaliasp
|
|||||||
|
|
||||||
basicaliasp :: TextParser m AccountAlias
|
basicaliasp :: TextParser m AccountAlias
|
||||||
basicaliasp = do
|
basicaliasp = do
|
||||||
-- pdbg 0 "basicaliasp"
|
-- dbgparse 0 "basicaliasp"
|
||||||
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
|
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
|
||||||
char '='
|
char '='
|
||||||
skipMany spacenonewline
|
skipMany spacenonewline
|
||||||
@ -366,7 +366,7 @@ basicaliasp = do
|
|||||||
|
|
||||||
regexaliasp :: TextParser m AccountAlias
|
regexaliasp :: TextParser m AccountAlias
|
||||||
regexaliasp = do
|
regexaliasp = do
|
||||||
-- pdbg 0 "regexaliasp"
|
-- dbgparse 0 "regexaliasp"
|
||||||
char '/'
|
char '/'
|
||||||
re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end
|
re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end
|
||||||
char '/'
|
char '/'
|
||||||
@ -504,7 +504,7 @@ periodictransactionp = do
|
|||||||
-- | Parse a (possibly unbalanced) transaction.
|
-- | Parse a (possibly unbalanced) transaction.
|
||||||
transactionp :: JournalParser m Transaction
|
transactionp :: JournalParser m Transaction
|
||||||
transactionp = do
|
transactionp = do
|
||||||
-- ptrace "transactionp"
|
-- dbgparse 0 "transactionp"
|
||||||
startpos <- getPosition
|
startpos <- getPosition
|
||||||
date <- datep <?> "transaction"
|
date <- datep <?> "transaction"
|
||||||
edate <- optional (lift $ secondarydatep date) <?> "secondary date"
|
edate <- optional (lift $ secondarydatep date) <?> "secondary date"
|
||||||
@ -628,7 +628,7 @@ postingsp mTransactionYear = many (postingp mTransactionYear) <?> "postings"
|
|||||||
|
|
||||||
postingp :: Maybe Year -> JournalParser m Posting
|
postingp :: Maybe Year -> JournalParser m Posting
|
||||||
postingp mTransactionYear = do
|
postingp mTransactionYear = do
|
||||||
-- pdbg 0 "postingp"
|
-- dbgparse 0 "postingp"
|
||||||
(status, account) <- try $ do
|
(status, account) <- try $ do
|
||||||
lift (skipSome spacenonewline)
|
lift (skipSome spacenonewline)
|
||||||
status <- lift statusp
|
status <- lift statusp
|
||||||
|
@ -49,13 +49,13 @@ import Text.Megaparsec.Char
|
|||||||
|
|
||||||
import Hledger.Data
|
import Hledger.Data
|
||||||
import Hledger.Read.Common
|
import Hledger.Read.Common
|
||||||
import Hledger.Utils hiding (ptrace)
|
import Hledger.Utils hiding (traceParse)
|
||||||
|
|
||||||
-- easier to toggle this here sometimes
|
-- easier to toggle this here sometimes
|
||||||
-- import qualified Hledger.Utils (ptrace)
|
-- import qualified Hledger.Utils (parsertrace)
|
||||||
-- ptrace = Hledger.Utils.ptrace
|
-- parsertrace = Hledger.Utils.parsertrace
|
||||||
ptrace :: Monad m => a -> m a
|
traceParse :: Monad m => a -> m a
|
||||||
ptrace = return
|
traceParse = return
|
||||||
|
|
||||||
reader :: Reader
|
reader :: Reader
|
||||||
reader = Reader
|
reader = Reader
|
||||||
@ -76,7 +76,7 @@ timedotfilep = do many timedotfileitemp
|
|||||||
where
|
where
|
||||||
timedotfileitemp :: JournalParser m ()
|
timedotfileitemp :: JournalParser m ()
|
||||||
timedotfileitemp = do
|
timedotfileitemp = do
|
||||||
ptrace "timedotfileitemp"
|
traceParse "timedotfileitemp"
|
||||||
choice [
|
choice [
|
||||||
void $ lift emptyorcommentlinep
|
void $ lift emptyorcommentlinep
|
||||||
,timedotdayp >>= \ts -> modify' (addTransactions ts)
|
,timedotdayp >>= \ts -> modify' (addTransactions ts)
|
||||||
@ -94,7 +94,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
|
|||||||
-- @
|
-- @
|
||||||
timedotdayp :: JournalParser m [Transaction]
|
timedotdayp :: JournalParser m [Transaction]
|
||||||
timedotdayp = do
|
timedotdayp = do
|
||||||
ptrace " timedotdayp"
|
traceParse " timedotdayp"
|
||||||
d <- datep <* lift eolof
|
d <- datep <* lift eolof
|
||||||
es <- catMaybes <$> many (const Nothing <$> try (lift emptyorcommentlinep) <|>
|
es <- catMaybes <$> many (const Nothing <$> try (lift emptyorcommentlinep) <|>
|
||||||
Just <$> (notFollowedBy datep >> timedotentryp))
|
Just <$> (notFollowedBy datep >> timedotentryp))
|
||||||
@ -106,7 +106,7 @@ timedotdayp = do
|
|||||||
-- @
|
-- @
|
||||||
timedotentryp :: JournalParser m Transaction
|
timedotentryp :: JournalParser m Transaction
|
||||||
timedotentryp = do
|
timedotentryp = do
|
||||||
ptrace " timedotentryp"
|
traceParse " timedotentryp"
|
||||||
pos <- genericSourcePos <$> getPosition
|
pos <- genericSourcePos <$> getPosition
|
||||||
lift (skipMany spacenonewline)
|
lift (skipMany spacenonewline)
|
||||||
a <- modifiedaccountnamep
|
a <- modifiedaccountnamep
|
||||||
|
@ -8,7 +8,38 @@
|
|||||||
-- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html
|
-- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html
|
||||||
|
|
||||||
module Hledger.Utils.Debug (
|
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
|
,module Debug.Trace
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -27,31 +58,22 @@ import Text.Megaparsec
|
|||||||
import Text.Printf
|
import Text.Printf
|
||||||
import Text.Show.Pretty (ppShow, pPrint)
|
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 :: Show a => a -> IO ()
|
||||||
pprint = pPrint
|
pprint = pPrint
|
||||||
|
|
||||||
-- | Easier alias for pretty-show's ppShow.
|
-- | Pretty show. Easier alias for pretty-show's ppShow.
|
||||||
pshow :: Show a => a -> String
|
pshow :: Show a => a -> String
|
||||||
pshow = ppShow
|
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.
|
-- | Trace (print to stderr) a showable value using a custom show function.
|
||||||
traceWith :: (a -> String) -> a -> a
|
traceWith :: (a -> String) -> a -> a
|
||||||
traceWith f a = trace (f 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
|
-- | Global debug level, which controls the verbosity of debug output
|
||||||
-- on the console. The default is 0 meaning no debug output. The
|
-- 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
|
-- @--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
|
where
|
||||||
args = unsafePerformIO getArgs
|
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.
|
-- | Pretty-print a message and the showable value to the console, then return it.
|
||||||
-- ("dbg" without the 0 clashes with megaparsec 5.1).
|
|
||||||
dbg0 :: Show a => String -> a -> a
|
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 :: Show a => String -> a -> a
|
||||||
dbg1 = tracePrettyAt 1
|
dbg1 = ptraceAt 1
|
||||||
|
|
||||||
dbg2 :: Show a => String -> a -> a
|
dbg2 :: Show a => String -> a -> a
|
||||||
dbg2 = tracePrettyAt 2
|
dbg2 = ptraceAt 2
|
||||||
|
|
||||||
dbg3 :: Show a => String -> a -> a
|
dbg3 :: Show a => String -> a -> a
|
||||||
dbg3 = tracePrettyAt 3
|
dbg3 = ptraceAt 3
|
||||||
|
|
||||||
dbg4 :: Show a => String -> a -> a
|
dbg4 :: Show a => String -> a -> a
|
||||||
dbg4 = tracePrettyAt 4
|
dbg4 = ptraceAt 4
|
||||||
|
|
||||||
dbg5 :: Show a => String -> a -> a
|
dbg5 :: Show a => String -> a -> a
|
||||||
dbg5 = tracePrettyAt 5
|
dbg5 = ptraceAt 5
|
||||||
|
|
||||||
dbg6 :: Show a => String -> a -> a
|
dbg6 :: Show a => String -> a -> a
|
||||||
dbg6 = tracePrettyAt 6
|
dbg6 = ptraceAt 6
|
||||||
|
|
||||||
dbg7 :: Show a => String -> a -> a
|
dbg7 :: Show a => String -> a -> a
|
||||||
dbg7 = tracePrettyAt 7
|
dbg7 = ptraceAt 7
|
||||||
|
|
||||||
dbg8 :: Show a => String -> a -> a
|
dbg8 :: Show a => String -> a -> a
|
||||||
dbg8 = tracePrettyAt 8
|
dbg8 = ptraceAt 8
|
||||||
|
|
||||||
dbg9 :: Show a => String -> a -> a
|
dbg9 :: Show a => String -> a -> a
|
||||||
dbg9 = tracePrettyAt 9
|
dbg9 = ptraceAt 9
|
||||||
|
|
||||||
-- | Convenience aliases for tracePrettyAtIO.
|
-- | Like ptraceAt, but convenient to insert in an IO monad (plus
|
||||||
-- Like dbg, but convenient to insert in an IO monad.
|
-- convenience aliases).
|
||||||
-- XXX These have a bug; they should use traceIO, not trace,
|
-- XXX These have a bug; they should use
|
||||||
-- otherwise GHC can occasionally over-optimise
|
-- traceIO, not trace, otherwise GHC can occasionally over-optimise
|
||||||
-- (cf lpaste a few days ago where it killed/blocked a child thread).
|
-- (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 :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg0IO = tracePrettyAtIO 0
|
dbg0IO = ptraceAtIO 0
|
||||||
|
|
||||||
dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg1IO = tracePrettyAtIO 1
|
dbg1IO = ptraceAtIO 1
|
||||||
|
|
||||||
dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg2IO = tracePrettyAtIO 2
|
dbg2IO = ptraceAtIO 2
|
||||||
|
|
||||||
dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg3IO = tracePrettyAtIO 3
|
dbg3IO = ptraceAtIO 3
|
||||||
|
|
||||||
dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg4IO = tracePrettyAtIO 4
|
dbg4IO = ptraceAtIO 4
|
||||||
|
|
||||||
dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg5IO = tracePrettyAtIO 5
|
dbg5IO = ptraceAtIO 5
|
||||||
|
|
||||||
dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg6IO = tracePrettyAtIO 6
|
dbg6IO = ptraceAtIO 6
|
||||||
|
|
||||||
dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg7IO = tracePrettyAtIO 7
|
dbg7IO = ptraceAtIO 7
|
||||||
|
|
||||||
dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()
|
dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||||||
dbg8IO = tracePrettyAtIO 8
|
dbg8IO = ptraceAtIO 8
|
||||||
|
|
||||||
dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()
|
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.
|
-- | Log a message and a pretty-printed showable value to ./debug.log, then return it.
|
||||||
-- At level 0, always prints. Otherwise, uses unsafePerformIO.
|
plog :: Show a => String -> a -> a
|
||||||
tracePrettyAt :: Show a => Int -> String -> a -> a
|
plog = plogAt 0
|
||||||
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,
|
-- | 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.
|
-- At level 0, always logs. Otherwise, uses unsafePerformIO.
|
||||||
logPrettyAt :: Show a => Int -> String -> a -> a
|
plogAt :: Show a => Int -> String -> a -> a
|
||||||
logPrettyAt lvl
|
plogAt lvl
|
||||||
| lvl > 0 && debugLevel < lvl = flip const
|
| lvl > 0 && debugLevel < lvl = flip const
|
||||||
| otherwise = \s a ->
|
| otherwise = \s a ->
|
||||||
let p = ppShow a
|
let p = ppShow a
|
||||||
@ -185,66 +211,37 @@ logPrettyAt lvl
|
|||||||
output = s++":"++nlorspace++intercalate "\n" ls'
|
output = s++":"++nlorspace++intercalate "\n" ls'
|
||||||
in unsafePerformIO $ appendFile "debug.log" output >> return a
|
in unsafePerformIO $ appendFile "debug.log" output >> return a
|
||||||
|
|
||||||
-- | print this string to the console before evaluating the expression,
|
-- XXX redundant ? More/less robust than log0 ?
|
||||||
-- if the global debug level is at or above the specified level. Uses unsafePerformIO.
|
-- -- | Like dbg, but writes the output to "debug.log" in the current directory.
|
||||||
-- dbgtrace :: Int -> String -> a -> a
|
-- -- Uses unsafePerformIO. Can fail due to log file contention if called too quickly
|
||||||
-- dbgtrace level
|
-- -- ("*** Exception: debug.log: openFile: resource busy (file is locked)").
|
||||||
-- | debugLevel >= level = trace
|
-- dbglog :: Show a => String -> a -> a
|
||||||
-- | otherwise = flip const
|
-- 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
|
-- | Print the provided label (if non-null) and current parser state
|
||||||
-- debug level is at or above the specified level (uses
|
-- (position and next input) to the console. (See also megaparsec's dbg.)
|
||||||
-- unsafePerformIO).
|
traceParse :: String -> TextParser m ()
|
||||||
-- Values are displayed with show, all on one line, which is hard to read.
|
traceParse msg = do
|
||||||
-- dbgshow :: Show a => Int -> String -> a -> a
|
pos <- getPosition
|
||||||
-- dbgshow level
|
next <- (T.take peeklength) `fmap` getInput
|
||||||
-- | debugLevel >= level = ltrace
|
let (l,c) = (sourceLine pos, sourceColumn pos)
|
||||||
-- | otherwise = flip const
|
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
|
-- | Print the provided label (if non-null) and current parser state
|
||||||
-- debug level is at or above the specified level (uses
|
-- (position and next input) to the console if the global debug level
|
||||||
-- unsafePerformIO).
|
-- is at or above the specified level. Uses unsafePerformIO.
|
||||||
-- Values are displayed with ppShow, each field/constructor on its own line.
|
-- (See also megaparsec's dbg.)
|
||||||
dbgppshow :: Show a => Int -> String -> a -> a
|
traceParseAt :: Int -> String -> TextParser m ()
|
||||||
dbgppshow level
|
traceParseAt level msg = when (level <= debugLevel) $ traceParse msg
|
||||||
| 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 a showable value to the console, with a message, if the
|
-- | Convenience alias for traceParseAt
|
||||||
-- -- debug level is at or above the specified level (uses
|
dbgparse :: Int -> String -> TextParser m ()
|
||||||
-- -- unsafePerformIO).
|
dbgparse level msg = traceParseAt level msg
|
||||||
-- -- 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
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
|
@ -115,7 +115,7 @@ main = do
|
|||||||
(argsbeforecmd, argsaftercmd') = break (==rawcmd) args
|
(argsbeforecmd, argsaftercmd') = break (==rawcmd) args
|
||||||
argsaftercmd = drop 1 argsaftercmd'
|
argsaftercmd = drop 1 argsaftercmd'
|
||||||
dbgIO :: Show a => String -> a -> IO ()
|
dbgIO :: Show a => String -> a -> IO ()
|
||||||
dbgIO = tracePrettyAtIO 2
|
dbgIO = ptraceAtIO 2
|
||||||
|
|
||||||
dbgIO "running" prognameandversion
|
dbgIO "running" prognameandversion
|
||||||
dbgIO "raw args" args
|
dbgIO "raw args" args
|
||||||
|
Loading…
Reference in New Issue
Block a user