{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module Hledger.Utils.Parse (
  SimpleStringParser,
  SimpleTextParser,
  TextParser,

  SourcePos(..),
  mkPos,
  unPos,
  initialPos,

  -- * SourcePos
  showSourcePosPair,
  showSourcePos,

  choice',
  choiceInState,
  surroundedBy,
  parsewith,
  runTextParser,
  rtp,
  parsewithString,
  parseWithState,
  parseWithState',
  fromparse,
  parseerror,
  showDateParseError,
  nonspace,
  isNewline,
  isNonNewlineSpace,
  restofline,
  eolof,

  spacenonewline,
  skipNonNewlineSpaces,
  skipNonNewlineSpaces1,
  skipNonNewlineSpaces',

  -- * re-exports
  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

-- | A parser of string to some type.
type SimpleStringParser a = Parsec CustomErr String a

-- | A parser of strict text to some type.
type SimpleTextParser = Parsec CustomErr Text  -- XXX an "a" argument breaks the CsvRulesParser declaration somehow

-- | A parser of text that runs in some monad.
type TextParser m a = ParsecT CustomErr Text m a

-- | Render source position in human-readable form.
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
")"

-- | Render a pair of source position in human-readable form.
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  -- might be at end of file withat last new-line

-- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail.
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

-- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail.
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
""

-- | Run a text parser in the identity monad. See also: parseWithState.
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
""

-- | Run a stateful parser with some initial state on a text.
-- See also: runTextParser, runJournalParser.
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  -- PARTIAL:

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

-- Skip many non-newline spaces.
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 #-}

-- Skip many non-newline spaces, failing if there are none.
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 #-}

-- Skip many non-newline spaces, returning True if any have been skipped.
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