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 = P (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -> String -> m ParseResult
forall (m :: * -> *) a.
MonadInterpreter m =>
P a -> String -> m ParseResult
runParser P (Maybe (LStmt GhcPs (LHsExpr GhcPs)))
GHC.parseStmt

parseType :: MonadInterpreter m => String -> m ParseResult
parseType :: forall (m :: * -> *). MonadInterpreter m => String -> m ParseResult
parseType = P (LHsType GhcPs) -> String -> m ParseResult
forall (m :: * -> *) a.
MonadInterpreter m =>
P a -> String -> m ParseResult
runParser P (LHsType 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 <- RunGhc m DynFlags
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall {n :: * -> *}. (MonadIO n, MonadMask n) => GhcT n DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
       --
       StringBuffer
buf <- (StringBuffer -> m StringBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer -> m StringBuffer)
-> (String -> StringBuffer) -> String -> m StringBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StringBuffer
GHC.stringToStringBuffer) String
expr
       --
       -- ghc >= 7 panics if noSrcLoc is given
       let srcLoc :: RealSrcLoc
srcLoc = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (String -> FastString
GHC.fsLit String
"<hint>") Int
1 Int
1
       let parse_res :: ParseResult a
parse_res = P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
GHC.unP P a
parser (DynFlags -> StringBuffer -> RealSrcLoc -> PState
GHC.mkPState DynFlags
dyn_fl StringBuffer
buf RealSrcLoc
srcLoc)
       --
       case ParseResult a
parse_res of
           GHC.POk{}            -> ParseResult -> m ParseResult
forall (m :: * -> *) a. Monad m => a -> m a
return ParseResult
ParseOk
           --
#if __GLASGOW_HASKELL__ >= 810
           GHC.PFailed PState
pst      -> let errMsgs :: ErrorMessages
errMsgs = PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dyn_fl
                                       span :: SrcSpan
span = (ErrMsg -> SrcSpan -> SrcSpan)
-> SrcSpan -> ErrorMessages -> SrcSpan
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SrcSpan -> SrcSpan -> SrcSpan
GHC.combineSrcSpans (SrcSpan -> SrcSpan -> SrcSpan)
-> (ErrMsg -> SrcSpan) -> ErrMsg -> SrcSpan -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrMsg -> SrcSpan
GHC.errMsgSpan) SrcSpan
GHC.noSrcSpan ErrorMessages
errMsgs
                                       err :: SDoc
err = [SDoc] -> SDoc
GHC.vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> [SDoc]
GHC.pprErrMsgBagWithLoc ErrorMessages
errMsgs
                                   in ParseResult -> m ParseResult
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 = m (Maybe ()) -> m ()
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 m ParseResult -> (ParseResult -> m (Maybe ())) -> m (Maybe ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
                      ParseResult
ParseOk             -> Maybe () -> m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just ())
                      -- If there was a parsing error,
                      -- do the "standard" error reporting
                      ParseError SrcSpan
span SDoc
err ->
                          do -- parsing failed, so we report it just as all
                             -- other errors get reported....
                             GhcErrLogger
logger <- FromSession m GhcErrLogger
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession SessionData () -> GhcErrLogger
forall a. SessionData a -> GhcErrLogger
ghcErrLogger
                             DynFlags
dflags <- RunGhc m DynFlags
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall {n :: * -> *}. (MonadIO n, MonadMask n) => GhcT n DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
                             let logger' :: WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
logger'  = GhcErrLogger
logger DynFlags
dflags
#if !MIN_VERSION_ghc(9,0,0)
                                 errStyle = GHC.defaultErrStyle dflags
#endif
                             IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()
logger'
                                              WarnReason
GHC.NoReason
                                              Severity
GHC.SevError
                                              SrcSpan
span
#if !MIN_VERSION_ghc(9,0,0)
                                              errStyle
#endif
                                              SDoc
err
                             --
                             -- behave like the rest of the GHC API functions
                             -- do on error...
                             Maybe () -> m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing