module Hint.Base
where
import Prelude hiding ( span )
import Control.Monad.Reader
import Control.Monad.Error
import Control.Exception
import Data.IORef
import Control.Concurrent.MVar
import Data.Dynamic
import qualified GHC
import qualified GHC.Paths
import qualified Outputable as GHC.O
import qualified SrcLoc as GHC.S
import qualified ErrUtils as GHC.E
import qualified Hint.Compat as Compat
import Hint.Parsers
newtype Interpreter a =
Interpreter{unInterpreter :: ReaderT SessionState
(ErrorT InterpreterError
IO) a}
deriving (Typeable, Functor, Monad, MonadIO)
instance MonadError InterpreterError Interpreter where
throwError = Interpreter . throwError
catchError (Interpreter m) catchE = Interpreter $ m `catchError` (\e ->
unInterpreter $ catchE e)
data InterpreterError = UnknownError String
| WontCompile [GhcError]
| NotAllowed String
| GhcException GHC.GhcException
deriving (Show, Typeable)
instance Error InterpreterError where
noMsg = UnknownError ""
strMsg = UnknownError
data InterpreterConf = Conf{all_mods_in_scope :: Bool}
defaultConf :: InterpreterConf
defaultConf = Conf {all_mods_in_scope = True}
newtype InterpreterSession =
InterpreterSession {sessionState :: MVar SessionState}
data SessionState = SessionState{configuration :: IORef InterpreterConf,
ghcSession :: GHC.Session,
ghcErrListRef :: IORef [GhcError],
ghcErrLogger :: GhcErrLogger}
data GhcError = GhcError{errMsg :: String} deriving Show
mkGhcError :: GHC.S.SrcSpan -> GHC.O.PprStyle -> GHC.E.Message -> GhcError
mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg}
where niceErrMsg = GHC.O.showSDoc . GHC.O.withPprStyle style $
GHC.E.mkLocMessage src_span msg
mapGhcExceptions :: (String -> InterpreterError) -> IO a -> Interpreter a
mapGhcExceptions buildEx action =
do r <- liftIO $ tryJust ghcExceptions action
either (throwError . buildEx . flip GHC.showGhcException []) return r
ghcExceptions :: Exception -> Maybe GHC.GhcException
ghcExceptions (DynException a) = fromDynamic a
ghcExceptions _ = Nothing
type GhcErrLogger = GHC.Severity
-> GHC.S.SrcSpan
-> GHC.O.PprStyle
-> GHC.E.Message
-> IO ()
type ModuleName = String
newSession :: IO InterpreterSession
newSession = newSessionUsing GHC.Paths.libdir
newSessionUsing :: FilePath -> IO InterpreterSession
newSessionUsing ghc_root =
do
ghc_session <- Compat.newSession ghc_root
default_conf <- newIORef defaultConf
ghc_err_list_ref <- newIORef []
let log_handler = mkLogHandler ghc_err_list_ref
let session_state = SessionState{configuration = default_conf,
ghcSession = ghc_session,
ghcErrListRef = ghc_err_list_ref,
ghcErrLogger = log_handler}
dflags <- GHC.getSessionDynFlags ghc_session
GHC.setSessionDynFlags ghc_session dflags{GHC.log_action = log_handler}
InterpreterSession `liftM` newMVar session_state
mkLogHandler :: IORef [GhcError] -> GhcErrLogger
mkLogHandler r _ src style msg = modifyIORef r (errorEntry :)
where errorEntry = mkGhcError src style msg
withSession :: InterpreterSession -> Interpreter a -> IO a
withSession s i = withMVar (sessionState s) $ \ss ->
do err_or_res <- runErrorT . flip runReaderT ss $ unInterpreter i
either throwDyn return err_or_res
`catchDyn` rethrowGhcException
rethrowGhcException :: GHC.GhcException -> IO a
rethrowGhcException = throwDyn . GhcException
fromSessionState :: (SessionState -> a) -> Interpreter a
fromSessionState f = Interpreter $ fmap f ask
modifySessionStateRef :: (SessionState -> IORef a) -> (a -> a) -> Interpreter a
modifySessionStateRef target f =
do ref <- fromSessionState target
old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))
return old_val
fromConf :: (InterpreterConf -> a) -> Interpreter a
fromConf f = do ref_conf <- fromSessionState configuration
liftIO $ f `fmap` readIORef ref_conf
onConf :: (InterpreterConf -> InterpreterConf) -> Interpreter ()
onConf f = modifySessionStateRef configuration f >> return ()
mayFail :: IO (Maybe a) -> Interpreter a
mayFail ghc_action =
do
maybe_res <- liftIO ghc_action
es <- modifySessionStateRef ghcErrListRef (const [])
case maybe_res of
Nothing -> if null es
then throwError $ UnknownError "Got no error message"
else throwError $ WontCompile (reverse es)
Just a -> if null es
then return a
else fail "GHC reported errors and also gave a result!"
finally :: Interpreter a -> Interpreter () -> Interpreter a
finally action clean_up = do r <- protected_action
clean_up
return r
where protected_action = action
`catchError`
(\e -> do clean_up `catchError` (\_ -> return ())
throwError e)
findModule :: ModuleName -> Interpreter GHC.Module
findModule mn =
do
ghc_session <- fromSessionState ghcSession
let mod_name = GHC.mkModuleName mn
mapGhcExceptions NotAllowed $ GHC.findModule ghc_session
mod_name
Nothing
failOnParseError :: (GHC.Session -> String -> IO ParseResult)
-> String
-> Interpreter ()
failOnParseError parser expr =
do
ghc_session <- fromSessionState ghcSession
parsed <- liftIO $ parser ghc_session expr
res <- case parsed of
ParseOk -> return (Just ())
ParseError span err ->
do
logger <- fromSessionState ghcErrLogger
liftIO $ logger GHC.SevError
span
GHC.O.defaultErrStyle
err
return Nothing
mayFail (return res)