{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Text.Megaparsec.Custom (
HledgerParseErrorData,
HledgerParseErrors,
parseErrorAt,
parseErrorAtRegion,
SourceExcerpt,
getExcerptText,
excerpt_,
reparseExcerpt,
customErrorBundlePretty,
FinalParseError,
FinalParseError',
FinalParseErrorBundle,
FinalParseErrorBundle',
finalError,
finalFancyFailure,
finalFail,
finalCustomFailure,
finalErrorBundlePretty,
attachSource,
parseIncludeFile,
)
where
import Control.Monad.Except
import Control.Monad.State.Strict (StateT, evalStateT)
import qualified Data.List.NonEmpty as NE
import Data.Monoid (Alt(..))
import qualified Data.Set as S
import Data.Text (Text)
import Text.Megaparsec
data HledgerParseErrorData
= ErrorFailAt Int
Int
String
| ErrorReparsing
(NE.NonEmpty (ParseError Text HledgerParseErrorData))
deriving (Int -> HledgerParseErrorData -> ShowS
[HledgerParseErrorData] -> ShowS
HledgerParseErrorData -> String
(Int -> HledgerParseErrorData -> ShowS)
-> (HledgerParseErrorData -> String)
-> ([HledgerParseErrorData] -> ShowS)
-> Show HledgerParseErrorData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HledgerParseErrorData] -> ShowS
$cshowList :: [HledgerParseErrorData] -> ShowS
show :: HledgerParseErrorData -> String
$cshow :: HledgerParseErrorData -> String
showsPrec :: Int -> HledgerParseErrorData -> ShowS
$cshowsPrec :: Int -> HledgerParseErrorData -> ShowS
Show, HledgerParseErrorData -> HledgerParseErrorData -> Bool
(HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> (HledgerParseErrorData -> HledgerParseErrorData -> Bool)
-> Eq HledgerParseErrorData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$c/= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
== :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$c== :: 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
min :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
$cmin :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
max :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
$cmax :: HledgerParseErrorData
-> HledgerParseErrorData -> HledgerParseErrorData
>= :: HledgerParseErrorData -> HledgerParseErrorData -> Bool
$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
compare :: HledgerParseErrorData -> HledgerParseErrorData -> Ordering
$ccompare :: HledgerParseErrorData -> HledgerParseErrorData -> Ordering
$cp1Ord :: Eq HledgerParseErrorData
Ord)
type HledgerParseErrors = ParseErrorBundle Text HledgerParseErrorData
deriving instance Ord (ParseError Text HledgerParseErrorData)
instance ShowErrorComponent HledgerParseErrorData where
showErrorComponent :: HledgerParseErrorData -> String
showErrorComponent (ErrorFailAt Int
_ Int
_ String
errMsg) = String
errMsg
showErrorComponent (ErrorReparsing NonEmpty (ParseError Text HledgerParseErrorData)
_) = String
""
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
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)
parseErrorAtRegion
:: Int
-> Int
-> String
-> 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
data SourceExcerpt = SourceExcerpt Int
Text
getExcerptText :: SourceExcerpt -> Text
getExcerptText :: SourceExcerpt -> Text
getExcerptText (SourceExcerpt Int
_ Text
txt) = Text
txt
excerpt_ :: MonadParsec HledgerParseErrorData Text m => m a -> m SourceExcerpt
excerpt_ :: 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 (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
:: Monad m
=> SourceExcerpt
-> ParsecT HledgerParseErrorData Text m a
-> ParsecT HledgerParseErrorData Text m a
reparseExcerpt :: 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 (ParseErrorBundle Text HledgerParseErrorData) a
res) <- m (State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ParsecT
HledgerParseErrorData
Text
m
(State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ParsecT
HledgerParseErrorData
Text
m
(State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) a))
-> m (State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ParsecT
HledgerParseErrorData
Text
m
(State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) a)
forall a b. (a -> b) -> a -> b
$ ParsecT HledgerParseErrorData Text m a
-> State Text HledgerParseErrorData
-> m (State Text HledgerParseErrorData,
Either (ParseErrorBundle Text HledgerParseErrorData) 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 (ParseErrorBundle Text HledgerParseErrorData) a
res of
Right a
result -> a -> ParsecT HledgerParseErrorData Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
Left ParseErrorBundle Text HledgerParseErrorData
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
$ ParseErrorBundle Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors ParseErrorBundle Text HledgerParseErrorData
errBundle
where
offsetInitialState :: Int -> s ->
#if MIN_VERSION_megaparsec(8,0,0)
State s e
#else
State s
#endif
offsetInitialState :: Int -> s -> State s e
offsetInitialState Int
initialOffset s
s = State :: forall s e. s -> Int -> PosState s -> [ParseError s e] -> State s e
State
{ stateInput :: s
stateInput = s
s
, stateOffset :: Int
stateOffset = Int
initialOffset
, statePosState :: PosState s
statePosState = PosState :: forall s. s -> Int -> SourcePos -> Pos -> String -> PosState s
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
}
customErrorBundlePretty :: HledgerParseErrors -> String
customErrorBundlePretty :: ParseErrorBundle Text HledgerParseErrorData -> String
customErrorBundlePretty ParseErrorBundle Text HledgerParseErrorData
errBundle =
let errBundle' :: ParseErrorBundle Text HledgerParseErrorData
errBundle' = ParseErrorBundle Text HledgerParseErrorData
errBundle { bundleErrors :: NonEmpty (ParseError Text HledgerParseErrorData)
bundleErrors =
(ParseError Text HledgerParseErrorData -> Int)
-> NonEmpty (ParseError Text HledgerParseErrorData)
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NE.sortWith ParseError Text HledgerParseErrorData -> Int
forall s e. ParseError s e -> Int
errorOffset (NonEmpty (ParseError Text HledgerParseErrorData)
-> NonEmpty (ParseError Text HledgerParseErrorData))
-> NonEmpty (ParseError Text HledgerParseErrorData)
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall a b. (a -> b) -> a -> b
$
ParseErrorBundle Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors ParseErrorBundle Text HledgerParseErrorData
errBundle NonEmpty (ParseError Text HledgerParseErrorData)
-> (ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData))
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
finalizeCustomError }
in ParseErrorBundle Text HledgerParseErrorData -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text HledgerParseErrorData
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 (f :: * -> *) a. Applicative f => a -> f a
pure ParseError Text HledgerParseErrorData
err
Just errFailAt :: HledgerParseErrorData
errFailAt@(ErrorFailAt Int
startOffset Int
_ String
_) ->
ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
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) ->
NonEmpty (ParseError Text HledgerParseErrorData)
errs NonEmpty (ParseError Text HledgerParseErrorData)
-> (ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData))
-> NonEmpty (ParseError Text HledgerParseErrorData)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseError Text HledgerParseErrorData
-> NonEmpty (ParseError Text HledgerParseErrorData)
finalizeCustomError
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 :: (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 (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)
data FinalParseError' e
= FinalError (ParseError Text e)
| FinalBundle (ParseErrorBundle Text e)
| FinalBundleWithStack (FinalParseErrorBundle' e)
deriving (Int -> FinalParseError' e -> ShowS
[FinalParseError' e] -> ShowS
FinalParseError' e -> String
(Int -> FinalParseError' e -> ShowS)
-> (FinalParseError' e -> String)
-> ([FinalParseError' e] -> ShowS)
-> Show (FinalParseError' e)
forall e. Show e => Int -> FinalParseError' e -> ShowS
forall e. Show e => [FinalParseError' e] -> ShowS
forall e. Show e => FinalParseError' e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FinalParseError' e] -> ShowS
$cshowList :: forall e. Show e => [FinalParseError' e] -> ShowS
show :: FinalParseError' e -> String
$cshow :: forall e. Show e => FinalParseError' e -> String
showsPrec :: Int -> FinalParseError' e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> FinalParseError' e -> ShowS
Show)
type FinalParseError = FinalParseError' HledgerParseErrorData
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
(<>)
data FinalParseErrorBundle' e = FinalParseErrorBundle'
{ FinalParseErrorBundle' e -> ParseErrorBundle Text e
finalErrorBundle :: ParseErrorBundle Text e
, FinalParseErrorBundle' e -> [String]
includeFileStack :: [FilePath]
} deriving (Int -> FinalParseErrorBundle' e -> ShowS
[FinalParseErrorBundle' e] -> ShowS
FinalParseErrorBundle' e -> String
(Int -> FinalParseErrorBundle' e -> ShowS)
-> (FinalParseErrorBundle' e -> String)
-> ([FinalParseErrorBundle' e] -> ShowS)
-> Show (FinalParseErrorBundle' e)
forall e. Show e => Int -> FinalParseErrorBundle' e -> ShowS
forall e. Show e => [FinalParseErrorBundle' e] -> ShowS
forall e. Show e => FinalParseErrorBundle' e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FinalParseErrorBundle' e] -> ShowS
$cshowList :: forall e. Show e => [FinalParseErrorBundle' e] -> ShowS
show :: FinalParseErrorBundle' e -> String
$cshow :: forall e. Show e => FinalParseErrorBundle' e -> String
showsPrec :: Int -> FinalParseErrorBundle' e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> FinalParseErrorBundle' e -> ShowS
Show)
type FinalParseErrorBundle = FinalParseErrorBundle' HledgerParseErrorData
finalError :: ParseError Text e -> FinalParseError' e
finalError :: ParseError Text e -> FinalParseError' e
finalError = ParseError Text e -> FinalParseError' e
forall e. ParseError Text e -> FinalParseError' e
FinalError
finalFancyFailure
:: (MonadParsec e s m, MonadError (FinalParseError' e) m)
=> S.Set (ErrorFancy e) -> m a
finalFancyFailure :: 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 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
finalFail
:: (MonadParsec e s m, MonadError (FinalParseError' e) m) => String -> m a
finalFail :: 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
finalCustomFailure
:: (MonadParsec e s m, MonadError (FinalParseError' e) m) => e -> m a
finalCustomFailure :: 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
finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String
finalErrorBundlePretty :: FinalParseErrorBundle' HledgerParseErrorData -> String
finalErrorBundlePretty FinalParseErrorBundle' HledgerParseErrorData
bundle =
ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ShowS
showIncludeFilepath (FinalParseErrorBundle' HledgerParseErrorData -> [String]
forall e. FinalParseErrorBundle' e -> [String]
includeFileStack FinalParseErrorBundle' HledgerParseErrorData
bundle)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ParseErrorBundle Text HledgerParseErrorData -> String
customErrorBundlePretty (FinalParseErrorBundle' HledgerParseErrorData
-> ParseErrorBundle Text HledgerParseErrorData
forall e. FinalParseErrorBundle' e -> ParseErrorBundle Text e
finalErrorBundle FinalParseErrorBundle' HledgerParseErrorData
bundle)
where
showIncludeFilepath :: ShowS
showIncludeFilepath String
path = String
"in file included from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
",\n"
attachSource
:: FilePath -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource :: String -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource String
filePath Text
sourceText FinalParseError' e
finalParseError = case FinalParseError' e
finalParseError of
FinalError ParseError Text e
parseError ->
let bundle :: ParseErrorBundle Text e
bundle = ParseErrorBundle :: forall s e.
NonEmpty (ParseError s e) -> PosState s -> ParseErrorBundle s e
ParseErrorBundle
{ bundleErrors :: NonEmpty (ParseError Text e)
bundleErrors = ParseError Text e
parseError 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' :: forall e.
ParseErrorBundle Text e -> [String] -> FinalParseErrorBundle' e
FinalParseErrorBundle'
{ finalErrorBundle :: ParseErrorBundle Text e
finalErrorBundle = ParseErrorBundle Text e
bundle
, includeFileStack :: [String]
includeFileStack = [] }
FinalBundle ParseErrorBundle Text e
peBundle -> FinalParseErrorBundle' :: forall e.
ParseErrorBundle Text e -> [String] -> FinalParseErrorBundle' e
FinalParseErrorBundle'
{ finalErrorBundle :: ParseErrorBundle Text e
finalErrorBundle = ParseErrorBundle Text e
peBundle
, includeFileStack :: [String]
includeFileStack = [] }
FinalBundleWithStack FinalParseErrorBundle' e
fpeBundle -> FinalParseErrorBundle' e
fpeBundle
{ includeFileStack :: [String]
includeFileStack = String
filePath String -> [String] -> [String]
forall a. a -> [a] -> [a]
: FinalParseErrorBundle' e -> [String]
forall e. FinalParseErrorBundle' e -> [String]
includeFileStack FinalParseErrorBundle' e
fpeBundle }
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 :: 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 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
forall e (m :: * -> *) a.
MonadError (FinalParseError' e) m =>
FinalParseError' e -> m a
handler
where
parser' :: StateT
st
(ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
a
parser' = do
Either (ParseErrorBundle Text HledgerParseErrorData) a
eResult <- ParsecT
HledgerParseErrorData
Text
(ExceptT FinalParseError m)
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> StateT
st
(ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
HledgerParseErrorData
Text
(ExceptT FinalParseError m)
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> StateT
st
(ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
(Either (ParseErrorBundle Text HledgerParseErrorData) a))
-> ParsecT
HledgerParseErrorData
Text
(ExceptT FinalParseError m)
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> StateT
st
(ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
forall a b. (a -> b) -> a -> b
$ ExceptT
FinalParseError
m
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ParsecT
HledgerParseErrorData
Text
(ExceptT FinalParseError m)
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
FinalParseError
m
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ParsecT
HledgerParseErrorData
Text
(ExceptT FinalParseError m)
(Either (ParseErrorBundle Text HledgerParseErrorData) a))
-> ExceptT
FinalParseError
m
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
-> ParsecT
HledgerParseErrorData
Text
(ExceptT FinalParseError m)
(Either (ParseErrorBundle Text HledgerParseErrorData) a)
forall a b. (a -> b) -> a -> b
$
ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m) a
-> String
-> Text
-> ExceptT
FinalParseError
m
(Either (ParseErrorBundle Text HledgerParseErrorData) 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 (ParseErrorBundle Text HledgerParseErrorData) a
eResult of
Left ParseErrorBundle Text HledgerParseErrorData
parseErrorBundle -> 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
$ ParseErrorBundle Text HledgerParseErrorData -> FinalParseError
forall e. ParseErrorBundle Text e -> FinalParseError' e
FinalBundle ParseErrorBundle Text HledgerParseErrorData
parseErrorBundle
Right a
result -> a
-> StateT
st
(ParsecT HledgerParseErrorData Text (ExceptT FinalParseError m))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
handler :: FinalParseError' e -> m a
handler FinalParseError' e
e = 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
$ FinalParseErrorBundle' e -> FinalParseError' e
forall e. FinalParseErrorBundle' e -> FinalParseError' e
FinalBundleWithStack (FinalParseErrorBundle' e -> FinalParseError' e)
-> FinalParseErrorBundle' e -> FinalParseError' e
forall a b. (a -> b) -> a -> b
$ String -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
forall e.
String -> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource String
filepath Text
text FinalParseError' e
e
initialPosState :: FilePath -> Text -> PosState Text
initialPosState :: String -> Text -> PosState Text
initialPosState String
filePath Text
sourceText = PosState :: forall s. s -> Int -> SourcePos -> Pos -> String -> PosState s
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
"" }