clean up debug helpers (api change)

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

View File

@ -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 ']')

View File

@ -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)

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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