mirror of
https://github.com/simonmichael/hledger.git
synced 2024-12-29 13:22:27 +03:00
988c164ec8
Hledger.Utils.Debug's "trace or log" functions are now controlled as follows: to enable logging, append ",logging" to the program name at startup (using withProgName). This also works when running in GHCI. And they log to PROGNAME.log, not debug.log. All (hopefully) debug logging in the hledger packages is now "trace or log" capable. This means that hledger-ui should now log all debug output to ./hledger-ui.log, with none of it appearing on the console.
200 lines
6.2 KiB
Haskell
200 lines
6.2 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Hledger.Utils.Parse (
|
|
SimpleStringParser,
|
|
SimpleTextParser,
|
|
TextParser,
|
|
|
|
-- * SourcePos
|
|
SourcePos(..),
|
|
mkPos,
|
|
unPos,
|
|
initialPos,
|
|
sourcePosPretty,
|
|
sourcePosPairPretty,
|
|
|
|
choice',
|
|
choiceInState,
|
|
surroundedBy,
|
|
parsewith,
|
|
runTextParser,
|
|
rtp,
|
|
parsewithString,
|
|
parseWithState,
|
|
parseWithState',
|
|
fromparse,
|
|
parseerror,
|
|
showDateParseError,
|
|
nonspace,
|
|
isNewline,
|
|
isNonNewlineSpace,
|
|
restofline,
|
|
eolof,
|
|
|
|
spacenonewline,
|
|
skipNonNewlineSpaces,
|
|
skipNonNewlineSpaces1,
|
|
skipNonNewlineSpaces',
|
|
|
|
-- ** Trace the state of hledger parsers
|
|
traceOrLogParse,
|
|
dbgparse,
|
|
|
|
-- * re-exports
|
|
HledgerParseErrors,
|
|
HledgerParseErrorData,
|
|
customErrorBundlePretty,
|
|
)
|
|
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 Data.Char
|
|
import Data.Functor (void)
|
|
import Data.Functor.Identity (Identity(..))
|
|
import Data.List
|
|
import Data.Text (Text)
|
|
import Text.Megaparsec.Char
|
|
import Text.Megaparsec.Custom
|
|
import Hledger.Utils.Debug (debugLevel, traceOrLog)
|
|
|
|
-- | A parser of string to some type.
|
|
type SimpleStringParser a = Parsec HledgerParseErrorData String a
|
|
|
|
-- | A parser of strict text to some type.
|
|
type SimpleTextParser = Parsec HledgerParseErrorData Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
|
|
|
|
-- | A parser of text that runs in some monad.
|
|
type TextParser m a = ParsecT HledgerParseErrorData Text m a
|
|
|
|
-- | Trace to stderr or log to debug log the provided label (if non-null)
|
|
-- and current parser state (position and next input).
|
|
-- See also: Hledger.Utils.Debug, megaparsec's dbg.
|
|
-- Uses unsafePerformIO.
|
|
traceOrLogParse :: String -> TextParser m ()
|
|
traceOrLogParse 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
|
|
traceOrLog s' $ return ()
|
|
where
|
|
peeklength = 30
|
|
|
|
-- class (Stream s, MonadPlus m) => MonadParsec e s m
|
|
-- dbgparse :: (MonadPlus m, MonadParsec e String m) => Int -> String -> m ()
|
|
|
|
-- | Trace to stderr or log to debug log the provided label (if non-null)
|
|
-- and current parser state (position and next input),
|
|
-- if the global debug level is at or above the specified level.
|
|
-- Uses unsafePerformIO.
|
|
dbgparse :: Int -> String -> TextParser m ()
|
|
dbgparse level msg = when (level <= debugLevel) $ traceOrLogParse msg
|
|
|
|
-- | Render a pair of source positions in human-readable form, only displaying the range of lines.
|
|
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
|
|
sourcePosPairPretty (SourcePos fp l1 _, SourcePos _ l2 c2) =
|
|
fp ++ ":" ++ show (unPos l1) ++ "-" ++ show l2'
|
|
where
|
|
l2' = if unPos c2 == 1 then unPos l2 - 1 else unPos l2 -- might be at end of file with a final new line
|
|
|
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
|
-- Consumes no input if all choices fail.
|
|
choice' :: [TextParser m a] -> TextParser m a
|
|
choice' = choice . map try
|
|
|
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
|
-- Consumes no input if all choices fail.
|
|
choiceInState :: [StateT s (ParsecT HledgerParseErrorData Text m) a] -> StateT s (ParsecT HledgerParseErrorData Text m) a
|
|
choiceInState = choice . map try
|
|
|
|
surroundedBy :: Applicative m => m openclose -> m a -> m a
|
|
surroundedBy p = between p p
|
|
|
|
parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
|
|
parsewith p = runParser p ""
|
|
|
|
-- | Run a text parser in the identity monad. See also: parseWithState.
|
|
runTextParser, rtp
|
|
:: TextParser Identity a -> Text -> Either HledgerParseErrors a
|
|
runTextParser = parsewith
|
|
rtp = runTextParser
|
|
|
|
parsewithString
|
|
:: Parsec e String a -> String -> Either (ParseErrorBundle String e) a
|
|
parsewithString p = runParser p ""
|
|
|
|
-- | Run a stateful parser with some initial state on a text.
|
|
-- See also: runTextParser, runJournalParser.
|
|
parseWithState
|
|
:: Monad m
|
|
=> st
|
|
-> StateT st (ParsecT HledgerParseErrorData Text m) a
|
|
-> Text
|
|
-> m (Either HledgerParseErrors a)
|
|
parseWithState ctx p = runParserT (evalStateT p ctx) ""
|
|
|
|
parseWithState'
|
|
:: (Stream s)
|
|
=> st
|
|
-> StateT st (ParsecT e s Identity) a
|
|
-> s
|
|
-> (Either (ParseErrorBundle s e) a)
|
|
parseWithState' ctx p = runParser (evalStateT p ctx) ""
|
|
|
|
fromparse
|
|
:: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a
|
|
fromparse = either parseerror id
|
|
|
|
parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a
|
|
parseerror e = errorWithoutStackTrace $ showParseError e -- PARTIAL:
|
|
|
|
showParseError
|
|
:: (Show t, Show (Token t), Show e)
|
|
=> ParseErrorBundle t e -> String
|
|
showParseError e = "parse error at " ++ show e
|
|
|
|
showDateParseError
|
|
:: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String
|
|
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
|
|
|
|
isNewline :: Char -> Bool
|
|
isNewline '\n' = True
|
|
isNewline _ = False
|
|
|
|
nonspace :: TextParser m Char
|
|
nonspace = satisfy (not . isSpace)
|
|
|
|
isNonNewlineSpace :: Char -> Bool
|
|
isNonNewlineSpace c = not (isNewline c) && isSpace c
|
|
|
|
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT HledgerParseErrorData s m Char
|
|
spacenonewline = satisfy isNonNewlineSpace
|
|
{-# INLINABLE spacenonewline #-}
|
|
|
|
restofline :: TextParser m String
|
|
restofline = anySingle `manyTill` eolof
|
|
|
|
-- Skip many non-newline spaces.
|
|
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
|
skipNonNewlineSpaces = void $ takeWhileP Nothing isNonNewlineSpace
|
|
{-# INLINABLE skipNonNewlineSpaces #-}
|
|
|
|
-- Skip many non-newline spaces, failing if there are none.
|
|
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
|
|
skipNonNewlineSpaces1 = void $ takeWhile1P Nothing isNonNewlineSpace
|
|
{-# INLINABLE skipNonNewlineSpaces1 #-}
|
|
|
|
-- Skip many non-newline spaces, returning True if any have been skipped.
|
|
skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m Bool
|
|
skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False
|
|
{-# INLINABLE skipNonNewlineSpaces' #-}
|
|
|
|
eolof :: TextParser m ()
|
|
eolof = void newline <|> eof
|