{-# 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 -> FilePath
showSourcePos (SourcePos FilePath
fp Pos
l Pos
c) =
FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (line " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Pos -> Int
unPos Pos
l) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", column " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Pos -> Int
unPos Pos
c) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
showSourcePosPair :: (SourcePos, SourcePos) -> String
showSourcePosPair :: (SourcePos, SourcePos) -> FilePath
showSourcePosPair (SourcePos FilePath
fp Pos
l1 Pos
_, SourcePos FilePath
_ Pos
l2 Pos
c2) =
FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (lines " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Pos -> Int
unPos Pos
l1) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
l2' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
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 CustomErr Text m a] -> ParsecT CustomErr Text m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT CustomErr Text m a] -> ParsecT CustomErr Text m a)
-> ([ParsecT CustomErr Text m a] -> [ParsecT CustomErr Text m a])
-> [ParsecT CustomErr Text m a]
-> ParsecT CustomErr Text m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsecT CustomErr Text m a -> ParsecT CustomErr Text m a)
-> [ParsecT CustomErr Text m a] -> [ParsecT CustomErr Text m a]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT CustomErr Text m a -> ParsecT CustomErr Text 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 :: forall s (m :: * -> *) a.
[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 :: 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
-> FilePath -> Text -> Either (ParseErrorBundle Text e) a
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser Parsec e Text a
p FilePath
""
runTextParser, rtp
:: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser :: forall a.
TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser = Parsec CustomErr Text a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
forall e a.
Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
parsewith
rtp :: forall a.
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 :: forall e a.
Parsec e FilePath a
-> FilePath -> Either (ParseErrorBundle FilePath e) a
parsewithString Parsec e FilePath a
p = Parsec e FilePath a
-> FilePath -> FilePath -> Either (ParseErrorBundle FilePath e) a
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
runParser Parsec e FilePath a
p FilePath
""
parseWithState
:: Monad m
=> st
-> StateT st (ParsecT CustomErr Text m) a
-> Text
-> m (Either (ParseErrorBundle Text CustomErr) a)
parseWithState :: forall (m :: * -> *) st a.
Monad m =>
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
-> FilePath
-> Text
-> m (Either (ParseErrorBundle Text CustomErr) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> FilePath -> 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) FilePath
""
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 -> FilePath -> s -> Either (ParseErrorBundle s e) a
forall e s a.
Parsec e s a -> FilePath -> 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) FilePath
""
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 = FilePath -> a
forall a. FilePath -> a
errorWithoutStackTrace (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle t e -> FilePath
forall t e.
(Show t, Show (Token t), Show e) =>
ParseErrorBundle t e -> FilePath
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 -> FilePath
showParseError ParseErrorBundle t e
e = FilePath
"parse error at " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ParseErrorBundle t e -> FilePath
forall a. Show a => a -> FilePath
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 -> FilePath
showDateParseError ParseErrorBundle t e
e = FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"date parse error (%s)" (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. [a] -> [a]
tail ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle t e -> FilePath
forall a. Show a => a -> FilePath
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 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 :: forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
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 :: forall (m :: * -> *). TextParser m FilePath
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 () -> ParsecT CustomErr Text m FilePath
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 :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
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 FilePath
-> (Token s -> Bool) -> ParsecT CustomErr s m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe FilePath
forall a. Maybe a
Nothing Char -> Bool
Token s -> Bool
isNonNewlineSpace
{-# INLINABLE skipNonNewlineSpaces #-}
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m ()
skipNonNewlineSpaces1 :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
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 FilePath
-> (Token s -> Bool) -> ParsecT CustomErr s m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe FilePath
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' :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
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 :: forall (m :: * -> *). TextParser m ()
eolof = ParsecT CustomErr Text m Char -> ParsecT CustomErr Text 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 ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomErr Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof