{-# LANGUAGE CPP, ConstraintKinds, FlexibleContexts, MultiParamTypeClasses #-}
module Idris.Parser.Stack
(
Parser(..)
, Parsing(..)
, runparser
, ParseError
, prettyError
, Mark
, mark
, restore
, getFC
, addExtent
, trackExtent
, extent
, withExtent
, appExtent
)
where
import Idris.Core.TT (FC(..))
import Idris.Output (Message(..))
import Control.Arrow (app)
import qualified Control.Monad.Fail as Fail
import Control.Monad.State.Strict (StateT(..), evalStateT)
import Control.Monad.Writer.Strict (MonadWriter(..), WriterT(..), listen,
runWriterT, tell)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Void (Void(..))
import System.FilePath (addTrailingPathSeparator, splitFileName)
import qualified Text.Megaparsec as P
import qualified Util.Pretty as PP
type Parser s = StateT s (WriterT FC (P.Parsec Void String))
type Parsing m = (Fail.MonadFail m, P.MonadParsec Void String m, MonadWriter FC m)
runparser :: Parser st res -> st -> String -> String -> Either ParseError res
runparser :: forall st res.
Parser st res -> st -> String -> String -> Either ParseError res
runparser Parser st res
p st
i String
inputname String
s =
case Parsec Void String (res, FC)
-> String
-> String
-> Either (ParseErrorBundle String Void) (res, FC)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse (WriterT FC (ParsecT Void String Identity) res
-> Parsec Void String (res, FC)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (Parser st res
-> st -> WriterT FC (ParsecT Void String Identity) res
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Parser st res
p st
i)) String
inputname String
s of
Left ParseErrorBundle String Void
err -> ParseError -> Either ParseError res
forall a b. a -> Either a b
Left (ParseError -> Either ParseError res)
-> ParseError -> Either ParseError res
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void -> ParseError
ParseError ParseErrorBundle String Void
err
Right (res, FC)
v -> res -> Either ParseError res
forall a b. b -> Either a b
Right (res -> Either ParseError res) -> res -> Either ParseError res
forall a b. (a -> b) -> a -> b
$ (res, FC) -> res
forall a b. (a, b) -> a
fst (res, FC)
v
newtype ParseError = ParseError { ParseError -> ParseErrorBundle String Void
unParseError :: P.ParseErrorBundle String Void }
parseError :: ParseError -> P.ParseError String Void
parseError :: ParseError -> ParseError String Void
parseError = NonEmpty (ParseError String Void) -> ParseError String Void
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (ParseError String Void) -> ParseError String Void)
-> (ParseError -> NonEmpty (ParseError String Void))
-> ParseError
-> ParseError String Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> NonEmpty (ParseError String Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
P.bundleErrors (ParseErrorBundle String Void -> NonEmpty (ParseError String Void))
-> (ParseError -> ParseErrorBundle String Void)
-> ParseError
-> NonEmpty (ParseError String Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseErrorBundle String Void
unParseError
parseErrorPosState :: ParseError -> P.PosState String
parseErrorPosState :: ParseError -> PosState String
parseErrorPosState = ParseErrorBundle String Void -> PosState String
forall s e. ParseErrorBundle s e -> PosState s
P.bundlePosState (ParseErrorBundle String Void -> PosState String)
-> (ParseError -> ParseErrorBundle String Void)
-> ParseError
-> PosState String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseErrorBundle String Void
unParseError
parseErrorOffset :: ParseError -> Int
parseErrorOffset :: ParseError -> Int
parseErrorOffset = ParseError String Void -> Int
forall s e. ParseError s e -> Int
P.errorOffset (ParseError String Void -> Int)
-> (ParseError -> ParseError String Void) -> ParseError -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseError String Void
parseError
instance Message ParseError where
messageExtent :: ParseError -> FC
messageExtent ParseError
err = SourcePos -> FC
sourcePositionFC SourcePos
pos
where
#if MIN_VERSION_megaparsec(8,0,0)
P.PosState {pstateSourcePos :: forall s. PosState s -> SourcePos
P.pstateSourcePos = SourcePos
pos} =
Int -> PosState String -> PosState String
forall s. TraversableStream s => Int -> PosState s -> PosState s
P.reachOffsetNoLine (ParseError -> Int
parseErrorOffset ParseError
err) (ParseError -> PosState String
parseErrorPosState ParseError
err)
#else
(pos, _) = P.reachOffsetNoLine (parseErrorOffset err) (parseErrorPosState err)
#endif
messageText :: ParseError -> OutputDoc
messageText = String -> OutputDoc
forall a. String -> Doc a
PP.text (String -> OutputDoc)
-> (ParseError -> String) -> ParseError -> OutputDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String)
-> (ParseError -> String) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError String Void -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
P.parseErrorTextPretty (ParseError String Void -> String)
-> (ParseError -> ParseError String Void) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseError String Void
parseError
#if MIN_VERSION_megaparsec(9,0,0)
messageSource :: ParseError -> Maybe String
messageSource ParseError
err = Maybe String
sline
#else
messageSource err = Just sline
#endif
where
#if MIN_VERSION_megaparsec(8,0,0)
(Maybe String
sline, PosState String
_) = Int -> PosState String -> (Maybe String, PosState String)
forall s.
TraversableStream s =>
Int -> PosState s -> (Maybe String, PosState s)
P.reachOffset (ParseError -> Int
parseErrorOffset ParseError
err) (ParseError -> PosState String
parseErrorPosState ParseError
err)
#else
(_, sline, _) = P.reachOffset (parseErrorOffset err) (parseErrorPosState err)
#endif
prettyError :: ParseError -> String
prettyError :: ParseError -> String
prettyError = ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
P.errorBundlePretty (ParseErrorBundle String Void -> String)
-> (ParseError -> ParseErrorBundle String Void)
-> ParseError
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseErrorBundle String Void
unParseError
#if MIN_VERSION_megaparsec(8,0,0)
type Mark = P.State String Void
#else
type Mark = P.State String
#endif
mark :: Parsing m => m Mark
mark :: forall (m :: * -> *). Parsing m => m Mark
mark = m Mark
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
P.getParserState
restore :: Parsing m => Mark -> m ()
restore :: forall (m :: * -> *). Parsing m => Mark -> m ()
restore = Mark -> m ()
forall e s (m :: * -> *). MonadParsec e s m => State s e -> m ()
P.setParserState
sourcePositionFC :: P.SourcePos -> FC
sourcePositionFC :: SourcePos -> FC
sourcePositionFC (P.SourcePos String
name Pos
line Pos
column) =
String -> (Int, Int) -> (Int, Int) -> FC
FC String
f (Int
lineNumber, Int
columnNumber) (Int
lineNumber, Int
columnNumber)
where
lineNumber :: Int
lineNumber = Pos -> Int
P.unPos Pos
line
columnNumber :: Int
columnNumber = Pos -> Int
P.unPos Pos
column
(String
dir, String
file) = String -> (String, String)
splitFileName String
name
f :: String
f = if String
dir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
addTrailingPathSeparator String
"."
then String
file
else String
name
getFC :: Parsing m => m FC
getFC :: forall (m :: * -> *). Parsing m => m FC
getFC = SourcePos -> FC
sourcePositionFC (SourcePos -> FC) -> m SourcePos -> m FC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
P.getSourcePos
addExtent :: MonadWriter FC m => FC -> m ()
addExtent :: forall (m :: * -> *). MonadWriter FC m => FC -> m ()
addExtent = FC -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
trackExtent :: Parsing m => m a -> m a
trackExtent :: forall (m :: * -> *) a. Parsing m => m a -> m a
trackExtent m a
p = do ~(FC String
f (Int
sr, Int
sc) (Int, Int)
_) <- m FC
forall (m :: * -> *). Parsing m => m FC
getFC
a
result <- m a
p
~(FC String
f (Int, Int)
_ (Int
er, Int
ec)) <- m FC
forall (m :: * -> *). Parsing m => m FC
getFC
FC -> m ()
forall (m :: * -> *). MonadWriter FC m => FC -> m ()
addExtent (String -> (Int, Int) -> (Int, Int) -> FC
FC String
f (Int
sr, Int
sc) (Int
er, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
ec Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
extent :: MonadWriter FC m => m a -> m FC
extent :: forall (m :: * -> *) a. MonadWriter FC m => m a -> m FC
extent = ((a, FC) -> FC) -> m (a, FC) -> m FC
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, FC) -> FC
forall a b. (a, b) -> b
snd (m (a, FC) -> m FC) -> (m a -> m (a, FC)) -> m a -> m FC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (a, FC)
forall (m :: * -> *) a. MonadWriter FC m => m a -> m (a, FC)
withExtent
withExtent :: MonadWriter FC m => m a -> m (a, FC)
withExtent :: forall (m :: * -> *) a. MonadWriter FC m => m a -> m (a, FC)
withExtent = m a -> m (a, FC)
forall a. m a -> m (a, FC)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
appExtent :: MonadWriter FC m => m (FC -> a) -> m a
appExtent :: forall (m :: * -> *) a. MonadWriter FC m => m (FC -> a) -> m a
appExtent = ((FC -> a, FC) -> a) -> m (FC -> a, FC) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FC -> a, FC) -> a
forall b c. (b -> c, b) -> c
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app (m (FC -> a, FC) -> m a)
-> (m (FC -> a) -> m (FC -> a, FC)) -> m (FC -> a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (FC -> a) -> m (FC -> a, FC)
forall (m :: * -> *) a. MonadWriter FC m => m a -> m (a, FC)
withExtent