module Language.Haskell.Interpreter.GHC.Base
where
import Control.Monad.Trans ( MonadIO(liftIO) )
import Control.Monad.Reader ( ReaderT, ask, runReaderT )
import Control.Monad.Error ( Error(..), MonadError(..), ErrorT, runErrorT )
import Control.Exception ( throwDyn )
import Control.Concurrent.MVar ( MVar, newMVar, withMVar )
import Data.IORef ( IORef, newIORef,
modifyIORef, atomicModifyIORef )
import Data.Typeable ( Typeable )
import qualified GHC
import qualified Outputable as GHC.O
import qualified SrcLoc as GHC.S
import qualified ErrUtils as GHC.E
import qualified Language.Haskell.Interpreter.GHC.Compat as Compat
import Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )
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
deriving (Show, Typeable)
instance Error InterpreterError where
noMsg = UnknownError ""
strMsg = UnknownError
newtype InterpreterSession =
InterpreterSession {sessionState :: MVar SessionState}
data SessionState = SessionState{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
type GhcErrLogger = GHC.Severity
-> GHC.S.SrcSpan
-> GHC.O.PprStyle
-> GHC.E.Message
-> IO ()
newSession :: IO InterpreterSession
newSession = newSessionUsing ghc_libdir
newSessionUsing :: FilePath -> IO InterpreterSession
newSessionUsing ghc_root =
do
ghc_session <- Compat.newSession ghc_root
ghc_err_list_ref <- newIORef []
let log_handler = mkLogHandler ghc_err_list_ref
let session_state = SessionState{ghcSession = ghc_session,
ghcErrListRef = ghc_err_list_ref,
ghcErrLogger = log_handler}
dflags <- GHC.getSessionDynFlags ghc_session
let myFlags = dflags{GHC.hscTarget = GHC.HscInterpreted,
GHC.log_action = log_handler}
GHC.setSessionDynFlags ghc_session myFlags
return . InterpreterSession =<< 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
fromSessionState :: (SessionState -> a) -> Interpreter a
fromSessionState f = Interpreter $ fmap f ask
modifySessionState :: Show a
=> (SessionState -> IORef a)
-> (a -> a)
-> Interpreter a
modifySessionState target f =
do
ref <- fromSessionState target
old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))
return old_val