{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
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',
traceOrLogParse,
dbgparse,
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
traceOrLogParse :: String -> TextParser m ()
traceOrLogParse :: forall (m :: * -> *). String -> TextParser m ()
traceOrLogParse String
msg = do
SourcePos
pos <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
Text
next <- (Int -> Text -> Text
T.take Int
peeklength) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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 = forall r. PrintfType r => String -> r
printf String
"at line %2d col %2d: %s" (Pos -> Int
unPos Pos
l) (Pos -> Int
unPos Pos
c) (forall a. Show a => a -> String
show Text
next) :: String
s' :: String
s' = forall r. PrintfType r => String -> r
printf (String
"%-"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (Int
peeklengthforall a. Num a => a -> a -> a
+Int
30)forall a. [a] -> [a] -> [a]
++String
"s") String
s forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
msg
forall a. String -> a -> a
traceOrLog String
s' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
peeklength :: Int
peeklength = Int
30
dbgparse :: Int -> String -> TextParser m ()
dbgparse :: forall (m :: * -> *). Int -> String -> TextParser m ()
dbgparse Int
level String
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
level forall a. Ord a => a -> a -> Bool
<= Int
debugLevel) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceOrLogParse String
msg
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
sourcePosPairPretty (SourcePos String
fp Pos
l1 Pos
_, SourcePos String
_ Pos
l2 Pos
c2) =
String
fp forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
l1) forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l2'
where
l2' :: Int
l2' = if Pos -> Int
unPos Pos
c2 forall a. Eq a => a -> a -> Bool
== Int
1 then Pos -> Int
unPos Pos
l2 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' = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 = 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 = 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 = 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 = 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 = 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 = forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> String -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (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 = forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall t e a.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> a
parseerror 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 = forall a. String -> a
errorWithoutStackTrace forall a b. (a -> b) -> a -> b
$ 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 " forall a. [a] -> [a] -> [a]
++ 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 = forall r. PrintfType r => String -> r
printf String
"date parse error (%s)" (forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ String -> [String]
lines forall a b. (a -> b) -> a -> b
$ 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 = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Bool
not 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 = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isNonNewlineSpace
{-# INLINABLE spacenonewline #-}
restofline :: TextParser m String
restofline :: forall (m :: * -> *). TextParser m String
restofline = forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing Char -> 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing Char -> 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
{-# INLINABLE skipNonNewlineSpaces' #-}
eolof :: TextParser m ()
eolof :: forall (m :: * -> *). TextParser m ()
eolof = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof