mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 10:47:29 +03:00
256 lines
9.5 KiB
Haskell
256 lines
9.5 KiB
Haskell
{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-}
|
||
-- | Debugging helpers
|
||
|
||
-- more:
|
||
-- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html
|
||
-- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html
|
||
-- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.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 Debug.Trace
|
||
#if __GLASGOW_HASKELL__ >= 704
|
||
,ppShow
|
||
#endif
|
||
)
|
||
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
|
||
|
||
#if __GLASGOW_HASKELL__ >= 704
|
||
import Text.Show.Pretty (ppShow)
|
||
#else
|
||
-- the required pretty-show version requires GHC >= 7.4
|
||
ppShow :: Show a => a -> String
|
||
ppShow = show
|
||
#endif
|
||
|
||
pprint :: Show a => a -> IO ()
|
||
pprint = putStrLn . ppShow
|
||
|
||
-- | 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
|
||
-- a higher value (note: not @--debug N@ for some reason). This uses
|
||
-- unsafePerformIO and can be accessed from anywhere and before normal
|
||
-- command-line processing. When running with :main in GHCI, you must
|
||
-- touch and reload this module to see the effect of a new --debug option.
|
||
-- After command-line processing, it is also available as the @debug_@
|
||
-- field of 'Hledger.Cli.CliOptions.CliOpts'.
|
||
-- {-# OPTIONS_GHC -fno-cse #-}
|
||
-- {-# NOINLINE debugLevel #-}
|
||
debugLevel :: Int
|
||
debugLevel = case snd $ break (=="--debug") args of
|
||
"--debug":[] -> 1
|
||
"--debug":n:_ -> readDef 1 n
|
||
_ ->
|
||
case take 1 $ filter ("--debug" `isPrefixOf`) args of
|
||
['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v
|
||
_ -> 0
|
||
|
||
where
|
||
args = unsafePerformIO getArgs
|
||
|
||
-- | Convenience aliases for tracePrettyAt.
|
||
|
||
-- Always 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 = tracePrettyAt 0
|
||
|
||
-- | Pretty-print a message and the showable value to the console when the debug level is >= 1, then return it. Uses unsafePerformIO.
|
||
dbg1 :: Show a => String -> a -> a
|
||
dbg1 = tracePrettyAt 1
|
||
|
||
dbg2 :: Show a => String -> a -> a
|
||
dbg2 = tracePrettyAt 2
|
||
|
||
dbg3 :: Show a => String -> a -> a
|
||
dbg3 = tracePrettyAt 3
|
||
|
||
dbg4 :: Show a => String -> a -> a
|
||
dbg4 = tracePrettyAt 4
|
||
|
||
dbg5 :: Show a => String -> a -> a
|
||
dbg5 = tracePrettyAt 5
|
||
|
||
dbg6 :: Show a => String -> a -> a
|
||
dbg6 = tracePrettyAt 6
|
||
|
||
dbg7 :: Show a => String -> a -> a
|
||
dbg7 = tracePrettyAt 7
|
||
|
||
dbg8 :: Show a => String -> a -> a
|
||
dbg8 = tracePrettyAt 8
|
||
|
||
dbg9 :: Show a => String -> a -> a
|
||
dbg9 = tracePrettyAt 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
|
||
-- (cf lpaste a few days ago where it killed/blocked a child thread).
|
||
dbg0IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg0IO = tracePrettyAtIO 0
|
||
|
||
dbg1IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg1IO = tracePrettyAtIO 1
|
||
|
||
dbg2IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg2IO = tracePrettyAtIO 2
|
||
|
||
dbg3IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg3IO = tracePrettyAtIO 3
|
||
|
||
dbg4IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg4IO = tracePrettyAtIO 4
|
||
|
||
dbg5IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg5IO = tracePrettyAtIO 5
|
||
|
||
dbg6IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg6IO = tracePrettyAtIO 6
|
||
|
||
dbg7IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg7IO = tracePrettyAtIO 7
|
||
|
||
dbg8IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg8IO = tracePrettyAtIO 8
|
||
|
||
dbg9IO :: (MonadIO m, Show a) => String -> a -> m ()
|
||
dbg9IO = tracePrettyAtIO 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,
|
||
-- if the 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
|
||
| lvl > 0 && debugLevel < lvl = 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
|
||
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
|
||
|
||
-- | 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 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 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
|
||
|
||
-- | 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
|