{-# 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',
HledgerParseErrors,
HledgerParseErrorData
)
where
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
import Text.Megaparsec.Char
import Text.Megaparsec.Custom
import Text.Printf
type SimpleStringParser a = Parsec HledgerParseErrorData String a
type SimpleTextParser = Parsec HledgerParseErrorData Text
type TextParser m a = ParsecT HledgerParseErrorData Text m a
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 b. Functor f => a -> f b -> f a
<$ 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 b. Functor f => a -> f b -> f a
<$ 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