module Hint.Parsers where
import Prelude hiding (span)
import Hint.Base
import Control.Monad.IO.Class (liftIO)
import qualified Hint.GHC as GHC
data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message
parseExpr :: MonadInterpreter m => String -> m ParseResult
parseExpr :: forall (m :: * -> *). MonadInterpreter m => String -> m ParseResult
parseExpr = forall (m :: * -> *) a.
MonadInterpreter m =>
P a -> String -> m ParseResult
runParser P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
GHC.parseStmt
parseType :: MonadInterpreter m => String -> m ParseResult
parseType :: forall (m :: * -> *). MonadInterpreter m => String -> m ParseResult
parseType = forall (m :: * -> *) a.
MonadInterpreter m =>
P a -> String -> m ParseResult
runParser P (GenLocated SrcSpanAnnA (HsType GhcPs))
GHC.parseType
runParser :: MonadInterpreter m => GHC.P a -> String -> m ParseResult
runParser :: forall (m :: * -> *) a.
MonadInterpreter m =>
P a -> String -> m ParseResult
runParser P a
parser String
expr =
do DynFlags
dyn_fl <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
StringBuffer
buf <- (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringBuffer
GHC.stringToStringBuffer) String
expr
let srcLoc :: RealSrcLoc
srcLoc = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (String -> FastString
GHC.fsLit String
"<hint>") Int
1 Int
1
let parserOpts :: ParserOpts
parserOpts = DynFlags -> ParserOpts
GHC.mkParserOpts DynFlags
dyn_fl
let parse_res :: ParseResult a
parse_res = forall a. P a -> PState -> ParseResult a
GHC.unP P a
parser (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
GHC.initParserState ParserOpts
parserOpts StringBuffer
buf RealSrcLoc
srcLoc)
case ParseResult a
parse_res of
GHC.POk{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult
ParseOk
#if MIN_VERSION_ghc(8,10,0)
GHC.PFailed PState
pst -> let errMsgs :: ErrorMessages
errMsgs = PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dyn_fl
span :: SrcSpan
span = forall e. Bag (MsgEnvelope e) -> SrcSpan
GHC.errMsgSpan ErrorMessages
errMsgs
err :: SDoc
err = [SDoc] -> SDoc
GHC.vcat forall a b. (a -> b) -> a -> b
$ ErrorMessages -> [SDoc]
GHC.pprErrorMessages ErrorMessages
errMsgs
in forall (f :: * -> *) a. Applicative f => a -> f a
pure (SrcSpan -> SDoc -> ParseResult
ParseError SrcSpan
span SDoc
err)
#else
GHC.PFailed _ span err -> return (ParseError span err)
#endif
failOnParseError :: MonadInterpreter m
=> (String -> m ParseResult)
-> String
-> m ()
failOnParseError :: forall (m :: * -> *).
MonadInterpreter m =>
(String -> m ParseResult) -> String -> m ()
failOnParseError String -> m ParseResult
parser String
expr = forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail m (Maybe ())
go
where go :: m (Maybe ())
go = String -> m ParseResult
parser String
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
ParseResult
ParseOk -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ())
ParseError SrcSpan
span SDoc
err ->
do
Logger
logger <- forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession forall a. SessionData a -> Logger
ghcLogger
DynFlags
dflags <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let logger' :: WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
logger' = Logger
-> DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
GHC.putLogMsg Logger
logger DynFlags
dflags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
logger'
WarnReason
GHC.NoReason
Severity
GHC.SevError
SrcSpan
span
SDoc
err
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing