{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Hledger.Utils.Parse (
SimpleStringParser,
SimpleTextParser,
TextParser,
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',
dbgparse,
traceOrLogParse,
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)
type SimpleStringParser a = Parsec HledgerParseErrorData String a
type SimpleTextParser = Parsec HledgerParseErrorData Text
type TextParser m a = ParsecT HledgerParseErrorData Text m a
dbgparse :: Int -> String -> TextParser m ()
dbgparse :: forall (m :: * -> *). Int -> String -> TextParser m ()
dbgparse Int
level String
msg = Bool
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
debugLevel) (ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). String -> TextParser m ()
traceOrLogParse String
msg
traceOrLogParse :: String -> TextParser m ()
traceOrLogParse :: forall (m :: * -> *). String -> TextParser m ()
traceOrLogParse String
msg = do
SourcePos
pos <- ParsecT HledgerParseErrorData Text m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
Text
next <- (Int -> Text -> Text
T.take Int
peeklength) (Text -> Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b.
(a -> b)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT HledgerParseErrorData Text m Text
forall e s (m :: * -> *). MonadParsec e s m => m s
getInput
let (Pos
l,Pos
c) = (SourcePos -> Pos
sourceLine SourcePos
pos, SourcePos -> Pos
sourceColumn SourcePos
pos)
s :: String
s = String -> Int -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"at line %2d col %2d: %s" (Pos -> Int
unPos Pos
l) (Pos -> Int
unPos Pos
c) (Text -> String
forall a. Show a => a -> String
show Text
next) :: String
s' :: String
s' = String -> String -> String
forall r. PrintfType r => String -> r
printf (String
"%-"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (Int
peeklengthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
30)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"s") String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
String -> TextParser m () -> TextParser m ()
forall a. String -> a -> a
traceOrLog String
s' (TextParser m () -> TextParser m ())
-> TextParser m () -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ () -> TextParser m ()
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
peeklength :: Int
peeklength = Int
30
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
sourcePosPairPretty (SourcePos String
fp Pos
l1 Pos
_, SourcePos String
_ Pos
l2 Pos
c2) =
String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
l1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l2'
where
l2' :: Int
l2' = if Pos -> Int
unPos Pos
c2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Pos -> Int
unPos Pos
l2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Pos -> Int
unPos Pos
l2
choice' :: [TextParser m a] -> TextParser m a
choice' :: forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' = [ParsecT HledgerParseErrorData Text m a]
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT HledgerParseErrorData Text m a]
-> ParsecT HledgerParseErrorData Text m a)
-> ([ParsecT HledgerParseErrorData Text m a]
-> [ParsecT HledgerParseErrorData Text m a])
-> [ParsecT HledgerParseErrorData Text m a]
-> ParsecT HledgerParseErrorData Text m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a)
-> [ParsecT HledgerParseErrorData Text m a]
-> [ParsecT HledgerParseErrorData Text m a]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
choiceInState :: [StateT s (ParsecT HledgerParseErrorData Text m) a] -> StateT s (ParsecT HledgerParseErrorData Text m) a
choiceInState :: forall s (m :: * -> *) a.
[StateT s (ParsecT HledgerParseErrorData Text m) a]
-> StateT s (ParsecT HledgerParseErrorData Text m) a
choiceInState = [StateT s (ParsecT HledgerParseErrorData Text m) a]
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([StateT s (ParsecT HledgerParseErrorData Text m) a]
-> StateT s (ParsecT HledgerParseErrorData Text m) a)
-> ([StateT s (ParsecT HledgerParseErrorData Text m) a]
-> [StateT s (ParsecT HledgerParseErrorData Text m) a])
-> [StateT s (ParsecT HledgerParseErrorData Text m) a]
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT s (ParsecT HledgerParseErrorData Text m) a
-> StateT s (ParsecT HledgerParseErrorData Text m) a)
-> [StateT s (ParsecT HledgerParseErrorData Text m) a]
-> [StateT s (ParsecT HledgerParseErrorData Text m) a]
forall a b. (a -> b) -> [a] -> [b]
map StateT s (ParsecT HledgerParseErrorData Text m) a
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall a.
StateT s (ParsecT HledgerParseErrorData Text m) a
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
surroundedBy :: Applicative m => m openclose -> m a -> m a
surroundedBy :: forall (m :: * -> *) openclose a.
Applicative m =>
m openclose -> m a -> m a
surroundedBy m openclose
p = m openclose -> m openclose -> m a -> m a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between m openclose
p m openclose
p
parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith :: forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith Parsec e Text a
p = Parsec e Text a
-> String -> Text -> Either (ParseErrorBundle Text e) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec e Text a
p String
""
runTextParser, rtp
:: TextParser Identity a -> Text -> Either HledgerParseErrors a
runTextParser :: forall a.
TextParser Identity a -> Text -> Either HledgerParseErrors a
runTextParser = Parsec HledgerParseErrorData Text a
-> Text -> Either HledgerParseErrors a
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith
rtp :: forall a.
TextParser Identity a -> Text -> Either HledgerParseErrors a
rtp = TextParser Identity a -> Text -> Either HledgerParseErrors a
forall a.
TextParser Identity a -> Text -> Either HledgerParseErrors a
runTextParser
parsewithString
:: Parsec e String a -> String -> Either (ParseErrorBundle String e) a
parsewithString :: forall e a.
Parsec e String a -> String -> Either (ParseErrorBundle String e) a
parsewithString Parsec e String a
p = Parsec e String a
-> String -> String -> Either (ParseErrorBundle String e) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parsec e String a
p String
""
parseWithState
:: Monad m
=> st
-> StateT st (ParsecT HledgerParseErrorData Text m) a
-> Text
-> m (Either HledgerParseErrors a)
parseWithState :: forall (m :: * -> *) st a.
Monad m =>
st
-> StateT st (ParsecT HledgerParseErrorData Text m) a
-> Text
-> m (Either HledgerParseErrors a)
parseWithState st
ctx StateT st (ParsecT HledgerParseErrorData Text m) a
p = ParsecT HledgerParseErrorData Text m a
-> String -> Text -> m (Either HledgerParseErrors a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> String -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (StateT st (ParsecT HledgerParseErrorData Text m) a
-> st -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT st (ParsecT HledgerParseErrorData Text m) a
p st
ctx) String
""
parseWithState'
:: (Stream s)
=> st
-> StateT st (ParsecT e s Identity) a
-> s
-> (Either (ParseErrorBundle s e) a)
parseWithState' :: forall s st e a.
Stream s =>
st
-> StateT st (ParsecT e s Identity) a
-> s
-> Either (ParseErrorBundle s e) a
parseWithState' st
ctx StateT st (ParsecT e s Identity) a
p = Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (StateT st (ParsecT e s Identity) a -> st -> Parsec e s a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT st (ParsecT e s Identity) a
p st
ctx) String
""
fromparse
:: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a
fromparse :: forall t e a.
(Show t, Show (Token t), Show e) =>
Either (ParseErrorBundle t e) a -> a
fromparse = (ParseErrorBundle t e -> a)
-> (a -> a) -> Either (ParseErrorBundle t e) a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseErrorBundle t e -> a
forall t e a.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> a
parseerror a -> a
forall a. a -> a
id
parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a
parseerror :: forall t e a.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> a
parseerror ParseErrorBundle t e
e = String -> a
forall a. String -> a
errorWithoutStackTrace (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle t e -> String
forall t e.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> String
showParseError ParseErrorBundle t e
e
showParseError
:: (Show t, Show (Token t), Show e)
=> ParseErrorBundle t e -> String
showParseError :: forall t e.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> String
showParseError ParseErrorBundle t e
e = String
"parse error at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseErrorBundle t e -> String
forall a. Show a => a -> String
show ParseErrorBundle t e
e
showDateParseError
:: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String
showDateParseError :: forall t e.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> String
showDateParseError ParseErrorBundle t e
e = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"date parse error (%s)" (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle t e -> String
forall a. Show a => a -> String
show ParseErrorBundle t e
e)
isNewline :: Char -> Bool
isNewline :: Char -> Bool
isNewline Char
'\n' = Bool
True
isNewline Char
_ = Bool
False
nonspace :: TextParser m Char
nonspace :: forall (m :: * -> *). TextParser m Char
nonspace = (Token Text -> Bool)
-> ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
isNonNewlineSpace :: Char -> Bool
isNonNewlineSpace :: Char -> Bool
isNonNewlineSpace Char
c = Bool -> Bool
not (Char -> Bool
isNewline Char
c) Bool -> Bool -> Bool
&& Char -> Bool
isSpace Char
c
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT HledgerParseErrorData s m Char
spacenonewline :: forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT HledgerParseErrorData s m Char
spacenonewline = (Token s -> Bool) -> ParsecT HledgerParseErrorData s m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token s -> Bool
isNonNewlineSpace
{-# INLINABLE spacenonewline #-}
restofline :: TextParser m String
restofline :: forall (m :: * -> *). TextParser m String
restofline = ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). TextParser m ()
eolof
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces = ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ())
-> ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token s -> Bool)
-> ParsecT HledgerParseErrorData s m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token s -> Bool
isNonNewlineSpace
{-# INLINABLE skipNonNewlineSpaces #-}
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1 :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1 = ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ())
-> ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token s -> Bool)
-> ParsecT HledgerParseErrorData s m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token s -> Bool
isNonNewlineSpace
{-# INLINABLE skipNonNewlineSpaces1 #-}
skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m Bool
skipNonNewlineSpaces' :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m Bool
skipNonNewlineSpaces' = Bool
True Bool
-> ParsecT HledgerParseErrorData s m ()
-> ParsecT HledgerParseErrorData s m Bool
forall a b.
a
-> ParsecT HledgerParseErrorData s m b
-> ParsecT HledgerParseErrorData s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT HledgerParseErrorData s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1 ParsecT HledgerParseErrorData s m Bool
-> ParsecT HledgerParseErrorData s m Bool
-> ParsecT HledgerParseErrorData s m Bool
forall a.
ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> ParsecT HledgerParseErrorData s m Bool
forall a. a -> ParsecT HledgerParseErrorData s m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
{-# INLINABLE skipNonNewlineSpaces' #-}
eolof :: TextParser m ()
eolof :: forall (m :: * -> *). TextParser m ()
eolof = ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT HledgerParseErrorData Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof