{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Hledger.Utils.Parse (

  -- * Some basic hledger parser flavours
  SimpleStringParser,
  SimpleTextParser,
  TextParser,

  -- * SourcePos
  SourcePos(..),
  mkPos,
  unPos,
  initialPos,
  sourcePosPretty,
  sourcePosPairPretty,

  -- * Parsers and helpers
  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,

  -- * More helpers, previously in Text.Megaparsec.Custom

  -- ** Custom parse error types
  HledgerParseErrorData,
  HledgerParseErrors,

  -- ** Failing with an arbitrary source position
  parseErrorAt,
  parseErrorAtRegion,

  -- ** Re-parsing
  SourceExcerpt,
  getExcerptText,
  excerpt_,
  reparseExcerpt,

  -- ** Pretty-printing custom parse errors
  customErrorBundlePretty,

  -- ** "Final" parse errors
  FinalParseError,
  FinalParseError',
  FinalParseErrorBundle,
  FinalParseErrorBundle',

  -- *** Constructing "final" parse errors
  finalError,
  finalFancyFailure,
  finalFail,
  finalCustomFailure,

  -- *** Pretty-printing "final" parse errors
  finalErrorBundlePretty,
  attachSource,

  -- *** Handling parse errors from include files with "final" parse errors
  parseIncludeFile,

)
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.Debug (dbg)  -- from megaparsec 9.3+

import Control.Monad.Except (ExceptT, MonadError, catchError, throwError)
-- import Control.Monad.State.Strict (StateT, evalStateT)
import Control.Monad.Trans.Class (lift)
import qualified Data.List.NonEmpty as NE
import Data.Monoid (Alt(..))
import qualified Data.Set as S

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



-- A bunch of megaparsec helpers, eg for re-parsing (formerly in Text.Megaparsec.Custom).
-- I think these are generic apart from the HledgerParseError name.

--- * Custom parse error types

-- | Custom error data for hledger parsers. Specialised for a 'Text' parse stream.
-- ReparseableTextParseErrorData ?
data HledgerParseErrorData
  -- | Fail with a message at a specific source position interval. The
  -- interval must be contained within a single line.
  = ErrorFailAt Int -- Starting offset
                Int -- Ending offset
                String -- Error message
  -- | Re-throw parse errors obtained from the "re-parsing" of an excerpt
  -- of the source text.
  | ErrorReparsing
      (NE.NonEmpty (ParseError Text HledgerParseErrorData)) -- Source fragment parse errors
  deriving (Int -> HledgerParseErrorData -> String -> String
[HledgerParseErrorData] -> String -> String
HledgerParseErrorData -> String
(Int -> HledgerParseErrorData -> String -> String)
-> (HledgerParseErrorData -> String)
-> ([HledgerParseErrorData] -> String -> String)
-> Show HledgerParseErrorData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HledgerParseErrorData -> String -> String
showsPrec :: Int -> HledgerParseErrorData -> String -> String
$cshow :: HledgerParseErrorData -> String
show :: HledgerParseErrorData -> String
$cshowList :: [HledgerParseErrorData] -> String -> String
showList :: [HledgerParseErrorData] -> String -> String
Show, HledgerParseErrorData -> HledgerParseErrorData -> Bool
(HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> (HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> Eq HledgerParseErrorData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
== :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$c/= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
/= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
Eq, Eq HledgerParseErrorData
Eq HledgerParseErrorData =>
(HledgerParseErrorData -> HledgerParseErrorData -> Ordering)
-> (HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> (HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> (HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> (HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> (HledgerParseErrorData
    -> HledgerParseErrorData -> HledgerParseErrorData)
-> (HledgerParseErrorData
    -> HledgerParseErrorData -> HledgerParseErrorData)
-> Ord HledgerParseErrorData
HledgerParseErrorData -> HledgerParseErrorData -> Bool
HledgerParseErrorData -> HledgerParseErrorData -> Ordering
HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HledgerParseErrorData -> HledgerParseErrorData -> Ordering
compare :: HledgerParseErrorData -> HledgerParseErrorData -> Ordering
$c< :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
< :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$c<= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
<= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$c> :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
> :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$c>= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
>= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$cmax :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
max :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
$cmin :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
min :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
Ord)

-- | A specialised version of ParseErrorBundle: 
-- a non-empty collection of hledger parse errors, 
-- equipped with PosState to help pretty-print them.
-- Specialised for a 'Text' parse stream.
type HledgerParseErrors = ParseErrorBundle Text HledgerParseErrorData

-- We require an 'Ord' instance for 'CustomError' so that they may be
-- stored in a 'Set'. The actual instance is inconsequential, so we just
-- derive it, but the derived instance requires an (orphan) instance for
-- 'ParseError'. Hopefully this does not cause any trouble.

deriving instance Ord (ParseError Text HledgerParseErrorData)

-- Note: the pretty-printing of our 'HledgerParseErrorData' type is only partally
-- defined in its 'ShowErrorComponent' instance; we perform additional
-- adjustments in 'customErrorBundlePretty'.

instance ShowErrorComponent HledgerParseErrorData where
  showErrorComponent :: HledgerParseErrorData -> String
showErrorComponent (ErrorFailAt Int
_ Int
_ String
errMsg) = String
errMsg
  showErrorComponent (ErrorReparsing NonEmpty (ParseError Text HledgerParseErrorData)
_) = String
"" -- dummy value

  errorComponentLen :: HledgerParseErrorData -> Int
errorComponentLen (ErrorFailAt Int
startOffset Int
endOffset String
_) =
    Int
endOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startOffset
  errorComponentLen (ErrorReparsing NonEmpty (ParseError Text HledgerParseErrorData)
_) = Int
1 -- dummy value


--- * Failing with an arbitrary source position

-- | Fail at a specific source position, given by the raw offset from the
-- start of the input stream (the number of tokens processed at that
-- point).

parseErrorAt :: Int -> String -> HledgerParseErrorData
parseErrorAt :: Int -> String -> HledgerParseErrorData
parseErrorAt Int
offset = Int -> Int -> String -> HledgerParseErrorData
ErrorFailAt Int
offset (Int
offsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-- | Fail at a specific source interval, given by the raw offsets of its
-- endpoints from the start of the input stream (the numbers of tokens
-- processed at those points).
--
-- Note that care must be taken to ensure that the specified interval does
-- not span multiple lines of the input source. This will not be checked.

parseErrorAtRegion
  :: Int    -- ^ Start offset
  -> Int    -- ^ End end offset
  -> String -- ^ Error message
  -> HledgerParseErrorData
parseErrorAtRegion :: Int -> Int -> String -> HledgerParseErrorData
parseErrorAtRegion Int
startOffset Int
endOffset String
msg =
  if Int
startOffset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
endOffset
    then Int -> Int -> String -> HledgerParseErrorData
ErrorFailAt Int
startOffset Int
endOffset String
msg'
    else Int -> Int -> String -> HledgerParseErrorData
ErrorFailAt Int
startOffset (Int
startOffsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
msg'
  where
    msg' :: String
msg' = String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg


--- * Re-parsing

-- | A fragment of source suitable for "re-parsing". The purpose of this
-- data type is to preserve the content and source position of the excerpt
-- so that parse errors raised during "re-parsing" may properly reference
-- the original source.

data SourceExcerpt = SourceExcerpt Int  -- Offset of beginning of excerpt
                                   Text -- Fragment of source file

-- | Get the raw text of a source excerpt.

getExcerptText :: SourceExcerpt -> Text
getExcerptText :: SourceExcerpt -> Text
getExcerptText (SourceExcerpt Int
_ Text
txt) = Text
txt

-- | 'excerpt_ p' applies the given parser 'p' and extracts the portion of
-- the source consumed by 'p', along with the source position of this
-- portion. This is the only way to create a source excerpt suitable for
-- "re-parsing" by 'reparseExcerpt'.

-- This function could be extended to return the result of 'p', but we don't
-- currently need this.

excerpt_ :: MonadParsec HledgerParseErrorData Text m => m a -> m SourceExcerpt
excerpt_ :: forall (m :: * -> *) a.
MonadParsec HledgerParseErrorData Text m =>
m a -> m SourceExcerpt
excerpt_ m a
p = do
  Int
offset <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  (!Text
txt, a
_) <- m a -> m (Tokens Text, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match m a
p
  SourceExcerpt -> m SourceExcerpt
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceExcerpt -> m SourceExcerpt)
-> SourceExcerpt -> m SourceExcerpt
forall a b. (a -> b) -> a -> b
$ Int -> Text -> SourceExcerpt
SourceExcerpt Int
offset Text
txt

-- | 'reparseExcerpt s p' "re-parses" the source excerpt 's' using the
-- parser 'p'. Parse errors raised by 'p' will be re-thrown at the source
-- position of the source excerpt.
--
-- In order for the correct source file to be displayed when re-throwing
-- parse errors, we must ensure that the source file during the use of
-- 'reparseExcerpt s p' is the same as that during the use of 'excerpt_'
-- that generated the source excerpt 's'. However, we can usually expect
-- this condition to be satisfied because, at the time of writing, the
-- only changes of source file in the codebase take place through include
-- files, and the parser for include files neither accepts nor returns
-- 'SourceExcerpt's.

reparseExcerpt
  :: Monad m
  => SourceExcerpt
  -> ParsecT HledgerParseErrorData Text m a
  -> ParsecT HledgerParseErrorData Text m a
reparseExcerpt :: forall (m :: * -> *) a.
Monad m =>
SourceExcerpt
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
reparseExcerpt (SourceExcerpt Int
offset Text
txt) ParsecT HledgerParseErrorData Text m a
p = do
  (State Text HledgerParseErrorData
_, Either HledgerParseErrors a
res) <- m (State Text HledgerParseErrorData, Either HledgerParseErrors a)
-> ParsecT
     HledgerParseErrorData
     Text
     m
     (State Text HledgerParseErrorData, Either HledgerParseErrors a)
forall (m :: * -> *) a.
Monad m =>
m a -> ParsecT HledgerParseErrorData Text m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (State Text HledgerParseErrorData, Either HledgerParseErrors a)
 -> ParsecT
      HledgerParseErrorData
      Text
      m
      (State Text HledgerParseErrorData, Either HledgerParseErrors a))
-> m (State Text HledgerParseErrorData,
      Either HledgerParseErrors a)
-> ParsecT
     HledgerParseErrorData
     Text
     m
     (State Text HledgerParseErrorData, Either HledgerParseErrors a)
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m a
-> State Text HledgerParseErrorData
-> m (State Text HledgerParseErrorData,
      Either HledgerParseErrors a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> State s e -> m (State s e, Either (ParseErrorBundle s e) a)
runParserT' ParsecT HledgerParseErrorData Text m a
p (Int -> Text -> State Text HledgerParseErrorData
forall s e. Int -> s -> State s e
offsetInitialState Int
offset Text
txt)
  case Either HledgerParseErrors a
res of
    Right a
result -> a -> ParsecT HledgerParseErrorData Text m a
forall a. a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
    Left HledgerParseErrors
errBundle -> HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m a
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m a)
-> HledgerParseErrorData -> ParsecT HledgerParseErrorData Text m a
forall a b. (a -> b) -> a -> b
$ NonEmpty (ParseError Text HledgerParseErrorData)
-> HledgerParseErrorData
ErrorReparsing (NonEmpty (ParseError Text HledgerParseErrorData)
 -> HledgerParseErrorData)
-> NonEmpty (ParseError Text HledgerParseErrorData)
-> HledgerParseErrorData
forall a b. (a -> b) -> a -> b
$ HledgerParseErrors
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors HledgerParseErrors
errBundle

  where
    offsetInitialState :: Int -> s ->
#if MIN_VERSION_megaparsec(8,0,0)
      State s e
#else
      State s
#endif
    offsetInitialState :: forall s e. Int -> s -> State s e
offsetInitialState Int
initialOffset s
s = State
      { stateInput :: s
stateInput  = s
s
      , stateOffset :: Int
stateOffset = Int
initialOffset
      , statePosState :: PosState s
statePosState = PosState
        { pstateInput :: s
pstateInput = s
s
        , pstateOffset :: Int
pstateOffset = Int
initialOffset
        , pstateSourcePos :: SourcePos
pstateSourcePos = String -> SourcePos
initialPos String
""
        , pstateTabWidth :: Pos
pstateTabWidth = Pos
defaultTabWidth
        , pstateLinePrefix :: String
pstateLinePrefix = String
""
        }
#if MIN_VERSION_megaparsec(8,0,0)
      , stateParseErrors :: [ParseError s e]
stateParseErrors = []
#endif
      }

--- * Pretty-printing custom parse errors

-- | Pretty-print our custom parse errors. It is necessary to use this
-- instead of 'errorBundlePretty' when custom parse errors are thrown.
--
-- This function intercepts our custom parse errors and applies final
-- adjustments ('finalizeCustomError') before passing them to
-- 'errorBundlePretty'. These adjustments are part of the implementation
-- of the behaviour of our custom parse errors.
--
-- Note: We must ensure that the offset of the 'PosState' of the provided
-- 'ParseErrorBundle' is no larger than the offset specified by a
-- 'ErrorFailAt' constructor. This is guaranteed if this offset is set to
-- 0 (that is, the beginning of the source file), which is the
-- case for 'ParseErrorBundle's returned from 'runParserT'.

customErrorBundlePretty :: HledgerParseErrors -> String
customErrorBundlePretty :: HledgerParseErrors -> String
customErrorBundlePretty HledgerParseErrors
errBundle =
  let errBundle' :: HledgerParseErrors
errBundle' = HledgerParseErrors
errBundle { bundleErrors =
        NE.sortWith errorOffset $ -- megaparsec requires that the list of errors be sorted by their offsets
        bundleErrors errBundle >>= finalizeCustomError }
  in  HledgerParseErrors -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty HledgerParseErrors
errBundle'

  where
    finalizeCustomError
      :: ParseError Text HledgerParseErrorData -> NE.NonEmpty (ParseError Text HledgerParseErrorData)
    finalizeCustomError :: ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
finalizeCustomError ParseError Text HledgerParseErrorData
err = case ParseError Text HledgerParseErrorData
-> Maybe HledgerParseErrorData
findCustomError ParseError Text HledgerParseErrorData
err of
      Maybe HledgerParseErrorData
Nothing -> ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseError Text HledgerParseErrorData
err

      Just errFailAt :: HledgerParseErrorData
errFailAt@(ErrorFailAt Int
startOffset Int
_ String
_) ->
        -- Adjust the offset
        ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseError Text HledgerParseErrorData
 -> NonEmpty (ParseError Text HledgerParseErrorData))
-> ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall a b. (a -> b) -> a -> b
$ Int
-> Set (ErrorFancy HledgerParseErrorData)
-> ParseError Text HledgerParseErrorData
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
startOffset (Set (ErrorFancy HledgerParseErrorData)
 -> ParseError Text HledgerParseErrorData)
-> Set (ErrorFancy HledgerParseErrorData)
-> ParseError Text HledgerParseErrorData
forall a b. (a -> b) -> a -> b
$ ErrorFancy HledgerParseErrorData
-> Set (ErrorFancy HledgerParseErrorData)
forall a. a -> Set a
S.singleton (ErrorFancy HledgerParseErrorData
 -> Set (ErrorFancy HledgerParseErrorData))
-> ErrorFancy HledgerParseErrorData
-> Set (ErrorFancy HledgerParseErrorData)
forall a b. (a -> b) -> a -> b
$ HledgerParseErrorData -> ErrorFancy HledgerParseErrorData
forall e. e -> ErrorFancy e
ErrorCustom HledgerParseErrorData
errFailAt

      Just (ErrorReparsing NonEmpty (ParseError Text HledgerParseErrorData)
errs) ->
        -- Extract and finalize the inner errors
        NonEmpty (ParseError Text HledgerParseErrorData)
errs NonEmpty (ParseError Text HledgerParseErrorData)
-> (ParseError Text HledgerParseErrorData
    -> NonEmpty (ParseError Text HledgerParseErrorData))
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall a b. NonEmpty a -> (a -> NonEmpty b) -> NonEmpty b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
finalizeCustomError

    -- If any custom errors are present, arbitrarily take the first one
    -- (since only one custom error should be used at a time).
    findCustomError :: ParseError Text HledgerParseErrorData -> Maybe HledgerParseErrorData
    findCustomError :: ParseError Text HledgerParseErrorData
-> Maybe HledgerParseErrorData
findCustomError ParseError Text HledgerParseErrorData
err = case ParseError Text HledgerParseErrorData
err of
      FancyError Int
_ Set (ErrorFancy HledgerParseErrorData)
errSet ->
        (ErrorFancy HledgerParseErrorData -> Maybe HledgerParseErrorData)
-> Set (ErrorFancy HledgerParseErrorData)
-> Maybe HledgerParseErrorData
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
finds (\case {ErrorCustom HledgerParseErrorData
e -> HledgerParseErrorData -> Maybe HledgerParseErrorData
forall a. a -> Maybe a
Just HledgerParseErrorData
e; ErrorFancy HledgerParseErrorData
_ -> Maybe HledgerParseErrorData
forall a. Maybe a
Nothing}) Set (ErrorFancy HledgerParseErrorData)
errSet
      ParseError Text HledgerParseErrorData
_ -> Maybe HledgerParseErrorData
forall a. Maybe a
Nothing

    finds :: (Foldable t) => (a -> Maybe b) -> t a -> Maybe b
    finds :: forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
finds a -> Maybe b
f = Alt Maybe b -> Maybe b
forall {k} (f :: k -> *) (a :: k). Alt f a -> f a
getAlt (Alt Maybe b -> Maybe b) -> (t a -> Alt Maybe b) -> t a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Alt Maybe b) -> t a -> Alt Maybe b
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe b -> Alt Maybe b
forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt (Maybe b -> Alt Maybe b) -> (a -> Maybe b) -> a -> Alt Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f)


--- * "Final" parse errors
--
-- | A type representing "final" parse errors that cannot be backtracked
-- from and are guaranteed to halt parsing. The anti-backtracking
-- behaviour is implemented by an 'ExceptT' layer in the parser's monad
-- stack, using this type as the 'ExceptT' error type.
--
-- We have three goals for this type:
-- (1) it should be possible to convert any parse error into a "final"
-- parse error,
-- (2) it should be possible to take a parse error thrown from an include
-- file and re-throw it in the parent file, and
-- (3) the pretty-printing of "final" parse errors should be consistent
-- with that of ordinary parse errors, but should also report a stack of
-- files for errors thrown from include files.
--
-- In order to pretty-print a "final" parse error (goal 3), it must be
-- bundled with include filepaths and its full source text. When a "final"
-- parse error is thrown from within a parser, we do not have access to
-- the full source, so we must hold the parse error until it can be joined
-- with its source (and include filepaths, if it was thrown from an
-- include file) by the parser's caller.
--
-- A parse error with include filepaths and its full source text is
-- represented by the 'FinalParseErrorBundle' type, while a parse error in
-- need of either include filepaths, full source text, or both is
-- represented by the 'FinalParseError' type.

data FinalParseError' e
  -- a parse error thrown as a "final" parse error
  = FinalError           (ParseError Text e)
  -- a parse error obtained from running a parser, e.g. using 'runParserT'
  | FinalBundle          (ParseErrorBundle Text e)
  -- a parse error thrown from an include file
  | FinalBundleWithStack (FinalParseErrorBundle' e)
  deriving (Int -> FinalParseError' e -> String -> String
[FinalParseError' e] -> String -> String
FinalParseError' e -> String
(Int -> FinalParseError' e -> String -> String)
-> (FinalParseError' e -> String)
-> ([FinalParseError' e] -> String -> String)
-> Show (FinalParseError' e)
forall e. Show e => Int -> FinalParseError' e -> String -> String
forall e. Show e => [FinalParseError' e] -> String -> String
forall e. Show e => FinalParseError' e -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall e. Show e => Int -> FinalParseError' e -> String -> String
showsPrec :: Int -> FinalParseError' e -> String -> String
$cshow :: forall e. Show e => FinalParseError' e -> String
show :: FinalParseError' e -> String
$cshowList :: forall e. Show e => [FinalParseError' e] -> String -> String
showList :: [FinalParseError' e] -> String -> String
Show)

type FinalParseError = FinalParseError' HledgerParseErrorData

-- We need a 'Monoid' instance for 'FinalParseError' so that 'ExceptT
-- FinalParseError m' is an instance of Alternative and MonadPlus, which
-- is needed to use some parser combinators, e.g. 'many'.
--
-- This monoid instance simply takes the first (left-most) error.

instance Semigroup (FinalParseError' e) where
  FinalParseError' e
e <> :: FinalParseError' e -> FinalParseError' e -> FinalParseError' e
<> FinalParseError' e
_ = FinalParseError' e
e

instance Monoid (FinalParseError' e) where
  mempty :: FinalParseError' e
mempty = ParseError Text e -> FinalParseError' e
forall e. ParseError Text e -> FinalParseError' e
FinalError (ParseError Text e -> FinalParseError' e)
-> ParseError Text e -> FinalParseError' e
forall a b. (a -> b) -> a -> b
$ Int -> Set (ErrorFancy e) -> ParseError Text e
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
0 (Set (ErrorFancy e) -> ParseError Text e)
-> Set (ErrorFancy e) -> ParseError Text e
forall a b. (a -> b) -> a -> b
$
            ErrorFancy e -> Set (ErrorFancy e)
forall a. a -> Set a
S.singleton (String -> ErrorFancy e
forall e. String -> ErrorFancy e
ErrorFail String
"default parse error")
  mappend :: FinalParseError' e -> FinalParseError' e -> FinalParseError' e
mappend = FinalParseError' e -> FinalParseError' e -> FinalParseError' e
forall a. Semigroup a => a -> a -> a
(<>)

-- | A type bundling a 'ParseError' with its full source text, filepath,
-- and stack of include files. Suitable for pretty-printing.
--
-- Megaparsec's 'ParseErrorBundle' type already bundles a parse error with
-- its full source text and filepath, so we just add a stack of include
-- files.

data FinalParseErrorBundle' e = FinalParseErrorBundle'
  { forall e. FinalParseErrorBundle' e -> ParseErrorBundle Text e
finalErrorBundle :: ParseErrorBundle Text e
  , forall e. FinalParseErrorBundle' e -> [String]
includeFileStack :: [FilePath]
  } deriving (Int -> FinalParseErrorBundle' e -> String -> String
[FinalParseErrorBundle' e] -> String -> String
FinalParseErrorBundle' e -> String
(Int -> FinalParseErrorBundle' e -> String -> String)
-> (FinalParseErrorBundle' e -> String)
-> ([FinalParseErrorBundle' e] -> String -> String)
-> Show (FinalParseErrorBundle' e)
forall e.
Show e =>
Int -> FinalParseErrorBundle' e -> String -> String
forall e. Show e => [FinalParseErrorBundle' e] -> String -> String
forall e. Show e => FinalParseErrorBundle' e -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall e.
Show e =>
Int -> FinalParseErrorBundle' e -> String -> String
showsPrec :: Int -> FinalParseErrorBundle' e -> String -> String
$cshow :: forall e. Show e => FinalParseErrorBundle' e -> String
show :: FinalParseErrorBundle' e -> String
$cshowList :: forall e. Show e => [FinalParseErrorBundle' e] -> String -> String
showList :: [FinalParseErrorBundle' e] -> String -> String
Show)

type FinalParseErrorBundle = FinalParseErrorBundle' HledgerParseErrorData


--- * Constructing and throwing final parse errors

-- | Convert a "regular" parse error into a "final" parse error.

finalError :: ParseError Text e -> FinalParseError' e
finalError :: forall e. ParseError Text e -> FinalParseError' e
finalError = ParseError Text e -> FinalParseError' e
forall e. ParseError Text e -> FinalParseError' e
FinalError

-- | Like megaparsec's 'fancyFailure', but as a "final" parse error.

finalFancyFailure
  :: (MonadParsec e s m, MonadError (FinalParseError' e) m)
  => S.Set (ErrorFancy e) -> m a
finalFancyFailure :: forall e s (m :: * -> *) a.
(MonadParsec e s m, MonadError (FinalParseError' e) m) =>
Set (ErrorFancy e) -> m a
finalFancyFailure Set (ErrorFancy e)
errSet = do
  Int
offset <- m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  FinalParseError' e -> m a
forall a. FinalParseError' e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FinalParseError' e -> m a) -> FinalParseError' e -> m a
forall a b. (a -> b) -> a -> b
$ ParseError Text e -> FinalParseError' e
forall e. ParseError Text e -> FinalParseError' e
FinalError (ParseError Text e -> FinalParseError' e)
-> ParseError Text e -> FinalParseError' e
forall a b. (a -> b) -> a -> b
$ Int -> Set (ErrorFancy e) -> ParseError Text e
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
offset Set (ErrorFancy e)
errSet

-- | Like 'fail', but as a "final" parse error.

finalFail
  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a
finalFail :: forall e s (m :: * -> *) a.
(MonadParsec e s m, MonadError (FinalParseError' e) m) =>
String -> m a
finalFail = Set (ErrorFancy e) -> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, MonadError (FinalParseError' e) m) =>
Set (ErrorFancy e) -> m a
finalFancyFailure (Set (ErrorFancy e) -> m a)
-> (String -> Set (ErrorFancy e)) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy e -> Set (ErrorFancy e)
forall a. a -> Set a
S.singleton (ErrorFancy e -> Set (ErrorFancy e))
-> (String -> ErrorFancy e) -> String -> Set (ErrorFancy e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorFancy e
forall e. String -> ErrorFancy e
ErrorFail

-- | Like megaparsec's 'customFailure', but as a "final" parse error.

finalCustomFailure
  :: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a
finalCustomFailure :: forall e s (m :: * -> *) a.
(MonadParsec e s m, MonadError (FinalParseError' e) m) =>
e -> m a
finalCustomFailure = Set (ErrorFancy e) -> m a
forall e s (m :: * -> *) a.
(MonadParsec e s m, MonadError (FinalParseError' e) m) =>
Set (ErrorFancy e) -> m a
finalFancyFailure (Set (ErrorFancy e) -> m a)
-> (e -> Set (ErrorFancy e)) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy e -> Set (ErrorFancy e)
forall a. a -> Set a
S.singleton (ErrorFancy e -> Set (ErrorFancy e))
-> (e -> ErrorFancy e) -> e -> Set (ErrorFancy e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ErrorFancy e
forall e. e -> ErrorFancy e
ErrorCustom


--- * Pretty-printing "final" parse errors

-- | Pretty-print a "final" parse error: print the stack of include files,
-- then apply the pretty-printer for parse error bundles. Note that
-- 'attachSource' must be used on a "final" parse error before it can be
-- pretty-printed.

finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String
finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String
finalErrorBundlePretty FinalParseErrorBundle' HledgerParseErrorData
bundle =
     (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
showIncludeFilepath (FinalParseErrorBundle' HledgerParseErrorData -> [String]
forall e. FinalParseErrorBundle' e -> [String]
includeFileStack FinalParseErrorBundle' HledgerParseErrorData
bundle)
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HledgerParseErrors -> String
customErrorBundlePretty (FinalParseErrorBundle' HledgerParseErrorData -> HledgerParseErrors
forall e. FinalParseErrorBundle' e -> ParseErrorBundle Text e
finalErrorBundle FinalParseErrorBundle' HledgerParseErrorData
bundle)
  where
    showIncludeFilepath :: String -> String
showIncludeFilepath String
path = String
"in file included from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
",\n"

-- | Supply a filepath and source text to a "final" parse error so that it
-- can be pretty-printed. You must ensure that you provide the appropriate
-- source text and filepath.

attachSource
  :: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource :: forall e.
String -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource String
filePath Text
sourceText FinalParseError' e
finalParseError = case FinalParseError' e
finalParseError of

  -- A parse error thrown directly with the 'FinalError' constructor
  -- requires both source and filepath.
  FinalError ParseError Text e
err ->
    let bundle :: ParseErrorBundle Text e
bundle = ParseErrorBundle
          { bundleErrors :: NonEmpty (ParseError Text e)
bundleErrors = ParseError Text e
err ParseError Text e
-> [ParseError Text e] -> NonEmpty (ParseError Text e)
forall a. a -> [a] -> NonEmpty a
NE.:| []
          , bundlePosState :: PosState Text
bundlePosState = String -> Text -> PosState Text
initialPosState String
filePath Text
sourceText }
    in  FinalParseErrorBundle'
          { finalErrorBundle :: ParseErrorBundle Text e
finalErrorBundle = ParseErrorBundle Text e
bundle
          , includeFileStack :: [String]
includeFileStack  = [] }

  -- A 'ParseErrorBundle' already has the appropriate source and filepath
  -- and so needs neither.
  FinalBundle ParseErrorBundle Text e
peBundle -> FinalParseErrorBundle'
    { finalErrorBundle :: ParseErrorBundle Text e
finalErrorBundle = ParseErrorBundle Text e
peBundle
    , includeFileStack :: [String]
includeFileStack = [] }

  -- A parse error from a 'FinalParseErrorBundle' was thrown from an
  -- include file, so we add the filepath to the stack.
  FinalBundleWithStack FinalParseErrorBundle' e
fpeBundle -> FinalParseErrorBundle' e
fpeBundle
    { includeFileStack = filePath : includeFileStack fpeBundle }


--- * Handling parse errors from include files with "final" parse errors

-- | Parse a file with the given parser and initial state, discarding the
-- final state and re-throwing any parse errors as "final" parse errors.

parseIncludeFile
  :: Monad m
  => StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a
  -> st
  -> FilePath
  -> Text
  -> StateT st (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m)) a
parseIncludeFile :: forall (m :: * -> *) st a.
Monad m =>
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
-> st
-> String
-> Text
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
parseIncludeFile StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
parser st
initialState String
filepath Text
text =
  StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
-> (FinalParseError
    -> StateT
         st
         (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
         a)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall a.
StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
-> (FinalParseError
    -> StateT
         st
         (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
         a)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
parser' FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
handler
  where
    parser' :: StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
parser' = do
      Either HledgerParseErrors a
eResult <- ParsecT
  HledgerParseErrorData
  Text
  (ExceptT FinalParseError m)
  (Either HledgerParseErrors a)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     (Either HledgerParseErrors a)
forall (m :: * -> *) a. Monad m => m a -> StateT st m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
   HledgerParseErrorData
   Text
   (ExceptT FinalParseError m)
   (Either HledgerParseErrors a)
 -> StateT
      st
      (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
      (Either HledgerParseErrors a))
-> ParsecT
     HledgerParseErrorData
     Text
     (ExceptT FinalParseError m)
     (Either HledgerParseErrors a)
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     (Either HledgerParseErrors a)
forall a b. (a -> b) -> a -> b
$ ExceptT FinalParseError m (Either HledgerParseErrors a)
-> ParsecT
     HledgerParseErrorData
     Text
     (ExceptT FinalParseError m)
     (Either HledgerParseErrors a)
forall (m :: * -> *) a.
Monad m =>
m a -> ParsecT HledgerParseErrorData Text m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT FinalParseError m (Either HledgerParseErrors a)
 -> ParsecT
      HledgerParseErrorData
      Text
      (ExceptT FinalParseError m)
      (Either HledgerParseErrors a))
-> ExceptT FinalParseError m (Either HledgerParseErrors a)
-> ParsecT
     HledgerParseErrorData
     Text
     (ExceptT FinalParseError m)
     (Either HledgerParseErrors a)
forall a b. (a -> b) -> a -> b
$
                  ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m) a
-> String
-> Text
-> ExceptT FinalParseError 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 (ExceptT FinalParseError m))
  a
-> st
-> ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m) a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  st
  (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
  a
parser st
initialState) String
filepath Text
text
      case Either HledgerParseErrors a
eResult of
        Left HledgerParseErrors
parseErrorBundle -> FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall a.
FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FinalParseError
 -> StateT
      st
      (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
      a)
-> FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall a b. (a -> b) -> a -> b
$ HledgerParseErrors -> FinalParseError
forall e. ParseErrorBundle Text e -> FinalParseError' e
FinalBundle HledgerParseErrors
parseErrorBundle
        Right a
result -> a
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall a.
a
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

    -- Attach source and filepath of the include file to its parse errors
    handler :: FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
handler FinalParseError
e = FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall a.
FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FinalParseError
 -> StateT
      st
      (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
      a)
-> FinalParseError
-> StateT
     st
     (ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
     a
forall a b. (a -> b) -> a -> b
$ FinalParseErrorBundle' HledgerParseErrorData -> FinalParseError
forall e. FinalParseErrorBundle' e -> FinalParseError' e
FinalBundleWithStack (FinalParseErrorBundle' HledgerParseErrorData -> FinalParseError)
-> FinalParseErrorBundle' HledgerParseErrorData -> FinalParseError
forall a b. (a -> b) -> a -> b
$ String
-> Text
-> FinalParseError
-> FinalParseErrorBundle' HledgerParseErrorData
forall e.
String -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource String
filepath Text
text FinalParseError
e


--- * Helpers

-- Like megaparsec's 'initialState', but instead for 'PosState'. Used when
-- constructing 'ParseErrorBundle's. The values for "tab width" and "line
-- prefix" are taken from 'initialState'.

initialPosState :: FilePath -> Text -> PosState Text
initialPosState :: String -> Text -> PosState Text
initialPosState String
filePath Text
sourceText = PosState
  { pstateInput :: Text
pstateInput      = Text
sourceText
  , pstateOffset :: Int
pstateOffset     = Int
0
  , pstateSourcePos :: SourcePos
pstateSourcePos  = String -> SourcePos
initialPos String
filePath
  , pstateTabWidth :: Pos
pstateTabWidth   = Pos
defaultTabWidth
  , pstateLinePrefix :: String
pstateLinePrefix = String
"" }