mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 18:29:36 +03:00
imp: lib: move hledger-specific things out of Hledger.Utils.Debug
Moved from Hledger.Utils.Debug to Hledger.Utils.Parse: traceParse traceParseAt dbgparse
This commit is contained in:
parent
fd82fa48c9
commit
ddb3ea777e
@ -2,17 +2,19 @@
|
|||||||
|
|
||||||
Helpers for debug logging to console or file.
|
Helpers for debug logging to console or file.
|
||||||
This module also exports Debug.Trace and (from the breakpoint package) Debug.Breakpoint.
|
This module also exports Debug.Trace and (from the breakpoint package) Debug.Breakpoint.
|
||||||
|
Uses Hledger.Utils.Print. See also additional helpers in Hledger.Utils.Parse,
|
||||||
|
Hledger.UI.UIUtils etc.
|
||||||
|
|
||||||
@dbg0@-@dbg9@ will pretty-print values to stderr
|
@dbg0@-@dbg9@ will pretty-print values to stderr
|
||||||
if the program was run with a sufficiently high @--debug=N@ argument.
|
if the program was run with a sufficiently high @--debug=N@ argument.
|
||||||
(@--debug@ with no argument means @--debug=1@; @dbg0@ always prints).
|
(@--debug@ with no argument means @--debug=1@; @dbg0@ always prints).
|
||||||
|
|
||||||
The @debugLevel@ global is set once at startup using unsafePerformIO.
|
Uses unsafePerformIO for simple program-wide read-only access to the debug level
|
||||||
In GHCI, this happens only on the first run of :main, so if you want
|
set by the --debug command-line flag. The @debugLevel@ global is set once at startup,
|
||||||
to change the debug level without restarting GHCI,
|
so in GHCI if you want to change it you must save this file and :reload.
|
||||||
save a dummy change in Debug.hs and do a :reload.
|
(Sometimes it's more convenient to temporarily add dbg0's in your code and :reload.)
|
||||||
(Sometimes it's more convenient to temporarily add dbg0's and :reload.)
|
|
||||||
|
|
||||||
|
Debug level is a number from 1 (least output) to 9 (most output).
|
||||||
In hledger, debug levels are used as follows:
|
In hledger, debug levels are used as follows:
|
||||||
|
|
||||||
Debug level: What to show:
|
Debug level: What to show:
|
||||||
@ -35,6 +37,7 @@ Debug level: What to show:
|
|||||||
-- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.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/htrace/0.1/doc/html/Debug-HTrace.html
|
||||||
-- 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
|
||||||
|
-- https://hackage.haskell.org/package/debug
|
||||||
|
|
||||||
module Hledger.Utils.Debug (
|
module Hledger.Utils.Debug (
|
||||||
-- * Tracing
|
-- * Tracing
|
||||||
@ -82,9 +85,6 @@ module Hledger.Utils.Debug (
|
|||||||
,dbg7IO
|
,dbg7IO
|
||||||
,dbg8IO
|
,dbg8IO
|
||||||
,dbg9IO
|
,dbg9IO
|
||||||
-- ** Trace the state of hledger parsers
|
|
||||||
,traceParse
|
|
||||||
,dbgparse
|
|
||||||
-- ** Debug-logging to a file
|
-- ** Debug-logging to a file
|
||||||
,dlogTrace
|
,dlogTrace
|
||||||
,dlogTraceAt
|
,dlogTraceAt
|
||||||
@ -105,23 +105,20 @@ module Hledger.Utils.Debug (
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.DeepSeq (force)
|
import Control.DeepSeq (force)
|
||||||
import Control.Monad (when)
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.IO.Class
|
import Data.List hiding (uncons)
|
||||||
import Data.List hiding (uncons)
|
import Debug.Breakpoint
|
||||||
import qualified Data.Text as T
|
import Debug.Trace
|
||||||
import Debug.Breakpoint
|
import Safe (readDef)
|
||||||
import Debug.Trace
|
import System.Environment (getArgs)
|
||||||
import Safe (readDef)
|
import System.Exit
|
||||||
import System.Environment (getArgs)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
import System.Exit
|
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
|
||||||
import Text.Megaparsec
|
|
||||||
import Text.Printf
|
|
||||||
import Control.Exception (evaluate)
|
import Control.Exception (evaluate)
|
||||||
|
|
||||||
import Hledger.Utils.Parse
|
-- import Hledger.Utils.Parse
|
||||||
import Hledger.Utils.Print
|
import Hledger.Utils.Print
|
||||||
|
-- import Text.Megaparsec (MonadParsec)
|
||||||
|
|
||||||
-- XXX some of the below can be improved with pretty-simple, https://github.com/cdepillabout/pretty-simple#readme
|
-- XXX some of the below can be improved with pretty-simple, https://github.com/cdepillabout/pretty-simple#readme
|
||||||
|
|
||||||
@ -371,28 +368,3 @@ dlog8 = dlogAt 8
|
|||||||
|
|
||||||
dlog9 :: Show a => String -> a -> a
|
dlog9 :: Show a => String -> a -> a
|
||||||
dlog9 = dlogAt 9
|
dlog9 = dlogAt 9
|
||||||
|
|
||||||
-- | 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 <- getSourcePos
|
|
||||||
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 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
|
|
||||||
|
|
||||||
-- | Convenience alias for traceParseAt
|
|
||||||
dbgparse :: Int -> String -> TextParser m ()
|
|
||||||
dbgparse = traceParseAt
|
|
||||||
|
|
||||||
|
@ -37,6 +37,11 @@ module Hledger.Utils.Parse (
|
|||||||
skipNonNewlineSpaces1,
|
skipNonNewlineSpaces1,
|
||||||
skipNonNewlineSpaces',
|
skipNonNewlineSpaces',
|
||||||
|
|
||||||
|
-- ** Trace the state of hledger parsers
|
||||||
|
traceParse,
|
||||||
|
traceParseAt,
|
||||||
|
dbgparse,
|
||||||
|
|
||||||
-- * re-exports
|
-- * re-exports
|
||||||
HledgerParseErrors,
|
HledgerParseErrors,
|
||||||
HledgerParseErrorData,
|
HledgerParseErrorData,
|
||||||
@ -44,16 +49,20 @@ module Hledger.Utils.Parse (
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Monad (when)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import Text.Megaparsec
|
||||||
|
import Text.Printf
|
||||||
import Control.Monad.State.Strict (StateT, evalStateT)
|
import Control.Monad.State.Strict (StateT, evalStateT)
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Functor (void)
|
import Data.Functor (void)
|
||||||
import Data.Functor.Identity (Identity(..))
|
import Data.Functor.Identity (Identity(..))
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Text.Megaparsec
|
|
||||||
import Text.Megaparsec.Char
|
import Text.Megaparsec.Char
|
||||||
import Text.Megaparsec.Custom
|
import Text.Megaparsec.Custom
|
||||||
import Text.Printf
|
import Debug.Trace (trace)
|
||||||
|
import Hledger.Utils.Debug (debugLevel)
|
||||||
|
|
||||||
-- | A parser of string to some type.
|
-- | A parser of string to some type.
|
||||||
type SimpleStringParser a = Parsec HledgerParseErrorData String a
|
type SimpleStringParser a = Parsec HledgerParseErrorData String a
|
||||||
@ -64,6 +73,32 @@ type SimpleTextParser = Parsec HledgerParseErrorData Text -- XXX an "a" argumen
|
|||||||
-- | A parser of text that runs in some monad.
|
-- | A parser of text that runs in some monad.
|
||||||
type TextParser m a = ParsecT HledgerParseErrorData Text m a
|
type TextParser m a = ParsecT HledgerParseErrorData Text m a
|
||||||
|
|
||||||
|
-- | 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 <- getSourcePos
|
||||||
|
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 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
|
||||||
|
|
||||||
|
-- | Convenience alias for traceParseAt
|
||||||
|
-- class (Stream s, MonadPlus m) => MonadParsec e s m
|
||||||
|
-- dbgparse :: (MonadPlus m, MonadParsec e String m) => Int -> String -> m ()
|
||||||
|
dbgparse :: Int -> String -> TextParser m ()
|
||||||
|
dbgparse = traceParseAt
|
||||||
|
|
||||||
-- | Render a pair of source positions in human-readable form, only displaying the range of lines.
|
-- | Render a pair of source positions in human-readable form, only displaying the range of lines.
|
||||||
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
|
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
|
||||||
sourcePosPairPretty (SourcePos fp l1 _, SourcePos _ l2 c2) =
|
sourcePosPairPretty (SourcePos fp l1 _, SourcePos _ l2 c2) =
|
||||||
@ -150,12 +185,12 @@ restofline = anySingle `manyTill` eolof
|
|||||||
|
|
||||||
-- Skip many non-newline spaces.
|
-- Skip many non-newline spaces.
|
||||||
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
||||||
skipNonNewlineSpaces = () <$ takeWhileP Nothing isNonNewlineSpace
|
skipNonNewlineSpaces = void $ takeWhileP Nothing isNonNewlineSpace
|
||||||
{-# INLINABLE skipNonNewlineSpaces #-}
|
{-# INLINABLE skipNonNewlineSpaces #-}
|
||||||
|
|
||||||
-- Skip many non-newline spaces, failing if there are none.
|
-- Skip many non-newline spaces, failing if there are none.
|
||||||
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
||||||
skipNonNewlineSpaces1 = () <$ takeWhile1P Nothing isNonNewlineSpace
|
skipNonNewlineSpaces1 = void $ takeWhile1P Nothing isNonNewlineSpace
|
||||||
{-# INLINABLE skipNonNewlineSpaces1 #-}
|
{-# INLINABLE skipNonNewlineSpaces1 #-}
|
||||||
|
|
||||||
-- Skip many non-newline spaces, returning True if any have been skipped.
|
-- Skip many non-newline spaces, returning True if any have been skipped.
|
||||||
@ -163,6 +198,5 @@ skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT HledgerParseError
|
|||||||
skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False
|
skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False
|
||||||
{-# INLINABLE skipNonNewlineSpaces' #-}
|
{-# INLINABLE skipNonNewlineSpaces' #-}
|
||||||
|
|
||||||
|
|
||||||
eolof :: TextParser m ()
|
eolof :: TextParser m ()
|
||||||
eolof = void newline <|> eof
|
eolof = void newline <|> eof
|
||||||
|
@ -1,6 +1,8 @@
|
|||||||
{- |
|
{- |
|
||||||
Helpers for pretty-formatting haskell values, pretty-printing to console,
|
Helpers for pretty-formatting haskell values, pretty-printing to console,
|
||||||
deciding if ANSI colour should be used, and detecting an -o/--output-file option.
|
deciding if ANSI colour should be used, and detecting an -o/--output-file option.
|
||||||
|
Uses unsafePerformIO for simple program-wide read-only access to some common
|
||||||
|
command-line flags/environment variables.
|
||||||
|
|
||||||
Limitations:
|
Limitations:
|
||||||
When running in GHCI, this module must be reloaded to see a change (because of unsafePerformIO).
|
When running in GHCI, this module must be reloaded to see a change (because of unsafePerformIO).
|
||||||
|
Loading…
Reference in New Issue
Block a user