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

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

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

  spacenonewline,
  skipNonNewlineSpaces,
  skipNonNewlineSpaces1,
  skipNonNewlineSpaces',

  -- * re-exports
  CustomErr
)
where

import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Char
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

import Hledger.Data.Types
import Hledger.Utils.UTF8IOCompat (error')

-- | 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

-- | A parser of text that runs in some monad, keeping a Journal as state.
type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a

-- | A parser of text that runs in some monad, keeping a Journal as
-- state, that can throw an exception to end parsing, preventing
-- further parser backtracking.
type ErroringJournalParser m a =
  StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a

-- | 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
""

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 Text
s = 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
"" Text
s

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 s
s = 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
"" s
s

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
error' (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)

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 = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char -> Bool
isSpace Char
c
-- XXX support \r\n ?
-- isNonNewlineSpace c = c /= '\n' && c /= '\r' && isSpace 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
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT CustomErr Text m Char -> TextParser m () -> TextParser m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> TextParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) 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