{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Hledger.Utils.Parse (
SimpleStringParser,
SimpleTextParser,
TextParser,
SourcePos(..),
mkPos,
unPos,
initialPos,
showSourcePosPair,
showSourcePos,
choice',
choiceInState,
surroundedBy,
parsewith,
runTextParser,
rtp,
parsewithString,
parseWithState,
parseWithState',
fromparse,
parseerror,
showDateParseError,
nonspace,
isNewline,
isNonNewlineSpace,
restofline,
eolof,
spacenonewline,
skipNonNewlineSpaces,
skipNonNewlineSpaces1,
skipNonNewlineSpaces',
CustomErr
)
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 CustomErr String a
type SimpleTextParser = Parsec CustomErr Text
type TextParser m a = ParsecT CustomErr Text m a
showSourcePos :: SourcePos -> String
showSourcePos :: SourcePos -> String
showSourcePos (SourcePos String
fp Pos
l Pos
c) =
String -> String
forall a. Show a => a -> String
show String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
l) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", column " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showSourcePosPair :: (SourcePos, SourcePos) -> String
showSourcePosPair :: (SourcePos, SourcePos) -> String
showSourcePosPair (SourcePos String
fp Pos
l1 Pos
_, SourcePos String
_ Pos
l2 Pos
c2) =
String -> String
forall a. Show a => a -> String
show String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (lines " 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' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
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' :: [TextParser m a] -> TextParser m a
choice' = [TextParser m a] -> TextParser m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([TextParser m a] -> TextParser m a)
-> ([TextParser m a] -> [TextParser m a])
-> [TextParser m a]
-> TextParser m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextParser m a -> TextParser m a)
-> [TextParser m a] -> [TextParser m a]
forall a b. (a -> b) -> [a] -> [b]
map TextParser m a -> TextParser m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
choiceInState :: [StateT s (ParsecT CustomErr Text m) a] -> StateT s (ParsecT CustomErr Text m) a
choiceInState :: [StateT s (ParsecT CustomErr Text m) a]
-> StateT s (ParsecT CustomErr Text m) a
choiceInState = [StateT s (ParsecT CustomErr Text m) a]
-> StateT s (ParsecT CustomErr Text m) a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([StateT s (ParsecT CustomErr Text m) a]
-> StateT s (ParsecT CustomErr Text m) a)
-> ([StateT s (ParsecT CustomErr Text m) a]
-> [StateT s (ParsecT CustomErr Text m) a])
-> [StateT s (ParsecT CustomErr Text m) a]
-> StateT s (ParsecT CustomErr Text m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT s (ParsecT CustomErr Text m) a
-> StateT s (ParsecT CustomErr Text m) a)
-> [StateT s (ParsecT CustomErr Text m) a]
-> [StateT s (ParsecT CustomErr Text m) a]
forall a b. (a -> b) -> [a] -> [b]
map StateT s (ParsecT CustomErr Text m) a
-> StateT s (ParsecT CustomErr 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 :: 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 :: 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 (ParseErrorBundle Text CustomErr) a
runTextParser :: TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser = TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith
rtp :: TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
rtp = TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
forall a.
TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser
parsewithString
:: Parsec e String a -> String -> Either (ParseErrorBundle String e) a
parsewithString :: 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 CustomErr Text m) a
-> Text
-> m (Either (ParseErrorBundle Text CustomErr) a)
parseWithState :: st
-> StateT st (ParsecT CustomErr Text m) a
-> Text
-> m (Either (ParseErrorBundle Text CustomErr) a)
parseWithState st
ctx StateT st (ParsecT CustomErr Text m) a
p = ParsecT CustomErr Text m a
-> String -> Text -> m (Either (ParseErrorBundle Text CustomErr) 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 CustomErr Text m) a
-> st -> ParsecT CustomErr Text m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT st (ParsecT CustomErr 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' :: 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 :: 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 :: 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 :: 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 :: 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. [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 :: TextParser m Char
nonspace = (Token Text -> Bool) -> ParsecT CustomErr 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 CustomErr s m Char
spacenonewline :: ParsecT CustomErr s m Char
spacenonewline = (Token s -> Bool) -> ParsecT CustomErr 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 :: TextParser m String
restofline = ParsecT CustomErr Text m Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT CustomErr Text m Char
-> ParsecT CustomErr Text m () -> TextParser m String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
eolof
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m ()
skipNonNewlineSpaces :: ParsecT CustomErr s m ()
skipNonNewlineSpaces = () () -> ParsecT CustomErr s m (Tokens s) -> ParsecT CustomErr s m ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe String
-> (Token s -> Bool) -> ParsecT CustomErr 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 CustomErr s m ()
skipNonNewlineSpaces1 :: ParsecT CustomErr s m ()
skipNonNewlineSpaces1 = () () -> ParsecT CustomErr s m (Tokens s) -> ParsecT CustomErr s m ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe String
-> (Token s -> Bool) -> ParsecT CustomErr 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 CustomErr s m Bool
skipNonNewlineSpaces' :: ParsecT CustomErr s m Bool
skipNonNewlineSpaces' = Bool
True Bool -> ParsecT CustomErr s m () -> ParsecT CustomErr s m Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT CustomErr s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1 ParsecT CustomErr s m Bool
-> ParsecT CustomErr s m Bool -> ParsecT CustomErr s m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> ParsecT CustomErr s m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
{-# INLINABLE skipNonNewlineSpaces' #-}
eolof :: TextParser m ()
eolof :: TextParser m ()
eolof = ParsecT CustomErr Text m Char -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline TextParser m () -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextParser m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof