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

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

  -- * SourcePos
  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',

  -- ** Trace the state of hledger parsers
  dbgparse,
  traceOrLogParse,

  -- * re-exports
  HledgerParseErrors,
  HledgerParseErrorData,
  customErrorBundlePretty,
)
where

import Control.Monad (when)
import qualified Data.Text as T
import Safe (tailErr)
import Text.Megaparsec
import Text.Printf
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.Char
import Text.Megaparsec.Custom
import Hledger.Utils.Debug (debugLevel, traceOrLog)

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

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

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

-- class (Stream s, MonadPlus m) => MonadParsec e s m 
-- dbgparse :: (MonadPlus m, MonadParsec e String m) => Int -> String -> m ()

-- | Trace to stderr or log to debug log the provided label (if non-null)
-- and current parser state (position and next input),
-- if the global debug level is at or above the specified level.
-- Uses unsafePerformIO.
dbgparse :: Int -> String -> TextParser m ()
dbgparse :: forall (m :: * -> *). Int -> String -> TextParser m ()
dbgparse Int
level String
msg = Bool
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
debugLevel) (ParsecT HledgerParseErrorData Text m ()
 -> ParsecT HledgerParseErrorData Text m ())
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). String -> TextParser m ()
traceOrLogParse String
msg

-- | Trace to stderr or log to debug log the provided label (if non-null)
-- and current parser state (position and next input).
-- See also: Hledger.Utils.Debug, megaparsec's dbg.
-- Uses unsafePerformIO.
-- XXX Can be hard to make this evaluate.
traceOrLogParse :: String -> TextParser m ()
traceOrLogParse :: forall (m :: * -> *). String -> TextParser m ()
traceOrLogParse String
msg = do
  SourcePos
pos <- ParsecT HledgerParseErrorData Text m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  Text
next <- (Int -> Text -> Text
T.take Int
peeklength) (Text -> Text)
-> ParsecT HledgerParseErrorData Text m Text
-> ParsecT HledgerParseErrorData Text m Text
forall a b.
(a -> b)
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecT HledgerParseErrorData Text m Text
forall e s (m :: * -> *). MonadParsec e s m => m s
getInput
  let (Pos
l,Pos
c) = (SourcePos -> Pos
sourceLine SourcePos
pos, SourcePos -> Pos
sourceColumn SourcePos
pos)
      s :: String
s  = String -> Int -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"at line %2d col %2d: %s" (Pos -> Int
unPos Pos
l) (Pos -> Int
unPos Pos
c) (Text -> String
forall a. Show a => a -> String
show Text
next) :: String
      s' :: String
s' = String -> String -> String
forall r. PrintfType r => String -> r
printf (String
"%-"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (Int
peeklengthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
30)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"s") String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  String -> TextParser m () -> TextParser m ()
forall a. String -> a -> a
traceOrLog String
s' (TextParser m () -> TextParser m ())
-> TextParser m () -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ () -> TextParser m ()
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    peeklength :: Int
peeklength = Int
30

-- | Render a pair of source positions in human-readable form, only displaying the range of lines.
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
sourcePosPairPretty :: (SourcePos, SourcePos) -> String
sourcePosPairPretty (SourcePos String
fp Pos
l1 Pos
_, SourcePos String
_ Pos
l2 Pos
c2) =
    String
fp 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 (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'
  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 with a final 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' :: forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice' = [ParsecT HledgerParseErrorData Text m a]
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT HledgerParseErrorData Text m a]
 -> ParsecT HledgerParseErrorData Text m a)
-> ([ParsecT HledgerParseErrorData Text m a]
    -> [ParsecT HledgerParseErrorData Text m a])
-> [ParsecT HledgerParseErrorData Text m a]
-> ParsecT HledgerParseErrorData Text m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsecT HledgerParseErrorData Text m a
 -> ParsecT HledgerParseErrorData Text m a)
-> [ParsecT HledgerParseErrorData Text m a]
-> [ParsecT HledgerParseErrorData Text m a]
forall a b. (a -> b) -> [a] -> [b]
map ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text 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 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 = [StateT s (ParsecT HledgerParseErrorData Text m) a]
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([StateT s (ParsecT HledgerParseErrorData Text m) a]
 -> StateT s (ParsecT HledgerParseErrorData Text m) a)
-> ([StateT s (ParsecT HledgerParseErrorData Text m) a]
    -> [StateT s (ParsecT HledgerParseErrorData Text m) a])
-> [StateT s (ParsecT HledgerParseErrorData Text m) a]
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT s (ParsecT HledgerParseErrorData Text m) a
 -> StateT s (ParsecT HledgerParseErrorData Text m) a)
-> [StateT s (ParsecT HledgerParseErrorData Text m) a]
-> [StateT s (ParsecT HledgerParseErrorData Text m) a]
forall a b. (a -> b) -> [a] -> [b]
map StateT s (ParsecT HledgerParseErrorData Text m) a
-> StateT s (ParsecT HledgerParseErrorData Text m) a
forall a.
StateT s (ParsecT HledgerParseErrorData Text m) a
-> StateT s (ParsecT HledgerParseErrorData 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
-> 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 HledgerParseErrors a
runTextParser :: forall a.
TextParser Identity a -> Text -> Either HledgerParseErrors a
runTextParser = Parsec HledgerParseErrorData Text a
-> Text -> Either HledgerParseErrors a
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 = TextParser Identity a -> Text -> Either HledgerParseErrors a
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 = 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 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 = ParsecT HledgerParseErrorData Text m a
-> String -> Text -> m (Either HledgerParseErrors 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 HledgerParseErrorData Text m) a
-> st -> ParsecT HledgerParseErrorData Text m a
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 = 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 :: 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 = 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 :: forall t e.
(Show t, Show (Token t), Show e) =>
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 :: forall t e.
(Show t, Show (Token t), Show e) =>
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. Partial => [a] -> [a]
tailErr ([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)  -- PARTIAL tailError won't be null because showing a parse error

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 HledgerParseErrorData 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 HledgerParseErrorData s m Char
spacenonewline :: forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT HledgerParseErrorData s m Char
spacenonewline = (Token s -> Bool) -> ParsecT HledgerParseErrorData 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 String
restofline = ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ParsecT HledgerParseErrorData Text m ()
forall (m :: * -> *). TextParser m ()
eolof

-- Skip many non-newline spaces.
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces = ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData s m (Tokens s)
 -> ParsecT HledgerParseErrorData s m ())
-> ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token s -> Bool)
-> ParsecT HledgerParseErrorData 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 HledgerParseErrorData s m ()
skipNonNewlineSpaces1 :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1 = ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT HledgerParseErrorData s m (Tokens s)
 -> ParsecT HledgerParseErrorData s m ())
-> ParsecT HledgerParseErrorData s m (Tokens s)
-> ParsecT HledgerParseErrorData s m ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token s -> Bool)
-> ParsecT HledgerParseErrorData 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 HledgerParseErrorData s m Bool
skipNonNewlineSpaces' :: forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m Bool
skipNonNewlineSpaces' = Bool
True Bool
-> ParsecT HledgerParseErrorData s m ()
-> ParsecT HledgerParseErrorData s m Bool
forall a b.
a
-> ParsecT HledgerParseErrorData s m b
-> ParsecT HledgerParseErrorData s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT HledgerParseErrorData s m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1 ParsecT HledgerParseErrorData s m Bool
-> ParsecT HledgerParseErrorData s m Bool
-> ParsecT HledgerParseErrorData s m Bool
forall a.
ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m a
-> ParsecT HledgerParseErrorData s m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> ParsecT HledgerParseErrorData s m Bool
forall a. a -> ParsecT HledgerParseErrorData s m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
{-# INLINABLE skipNonNewlineSpaces' #-}

eolof :: TextParser m ()
eolof :: forall (m :: * -> *). TextParser m ()
eolof = ParsecT HledgerParseErrorData Text m Char
-> ParsecT HledgerParseErrorData Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT HledgerParseErrorData Text m Char
ParsecT HledgerParseErrorData Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
-> ParsecT HledgerParseErrorData Text m ()
forall a.
ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT HledgerParseErrorData Text m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof