module Hint.InterpreterT (
InterpreterT, Interpreter, runInterpreter, runInterpreterWithArgs,
MultipleInstancesNotAllowed(..)
)
where
import Prelude
import Hint.Base
import Hint.Context
import Hint.Configuration
import Hint.Extension
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Catch as MC
import Data.Typeable ( Typeable )
import Control.Concurrent.MVar
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
import Data.List
import Data.Maybe
#if __GLASGOW_HASKELL__ < 610
import Data.Dynamic
#endif
import qualified GHC.Paths
import qualified Hint.GHC as GHC
import qualified Hint.Compat as Compat
type Interpreter = InterpreterT IO
#if __GLASGOW_HASKELL__ < 610
newtype InterpreterT m a = InterpreterT{
unInterpreterT :: ReaderT InterpreterSession
(ErrorT InterpreterError m) a}
deriving (Functor, Monad, MonadIO, MonadThrow,MonadCatch,MonadMask)
execute :: (MonadIO m, MonadMask m, Functor m)
=> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute s = runErrorT . flip runReaderT s . unInterpreterT
instance MonadTrans InterpreterT where
lift = InterpreterT . lift . lift
runGhc_impl :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a
runGhc_impl f = do s <- fromSession versionSpecific
r <- liftIO $ f' s
either throwError return r
where f' = tryJust (fmap (GhcException . showGhcEx) . ghcExceptions) . f
ghcExceptions (DynException e) = fromDynamic e
ghcExceptions _ = Nothing
#else
newtype InterpreterT m a = InterpreterT{
unInterpreterT :: ReaderT InterpreterSession
(GHC.GhcT m) a}
deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
execute :: (MonadIO m, MonadMask m, Functor m)
=> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute s = try
. GHC.runGhcT (Just GHC.Paths.libdir)
. flip runReaderT s
. unInterpreterT
instance MonadTrans InterpreterT where
lift = InterpreterT . lift . lift
runGhc_impl :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a
runGhc_impl a =
InterpreterT (lift a)
`catches`
[Handler (\(e :: GHC.SourceError) -> throwM $ compilationError e)
,Handler (\(e :: GHC.GhcApiError) -> throwM $ GhcException $ show e)
,Handler (\(e :: GHC.GhcException) -> throwM $ GhcException $ showGhcEx e)
]
where
compilationError
= WontCompile
. map (GhcError . show)
. GHC.bagToList
. GHC.srcErrorMessages
#endif
showGhcEx :: GHC.GhcException -> String
showGhcEx = flip GHC.showGhcException ""
initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m)
=> [String]
-> InterpreterT m ()
initialize args =
do log_handler <- fromSession ghcErrLogger
df0 <- runGhc GHC.getSessionDynFlags
let df1 = Compat.configureDynFlags df0
(df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args
when (not . null $ extra) $
throwM $ UnknownError (concat [ "flags: '"
, intercalate " " extra
, "' not recognized"])
_ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler}
#if __GLASGOW_HASKELL__ >= 700
#if __GLASGOW_HASKELL__ >= 702
#if __GLASGOW_HASKELL__ >= 704
let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags
#else
let extMap = map (\(a,_,b,_) -> (a,b)) GHC.xFlags
#endif
#else
let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags
#endif
let toOpt e = let err = error ("init error: unknown ext:" ++ show e)
in fromMaybe err (lookup e extMap)
let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2)
let defExts = map getOptVal Compat.supportedExtensions
#else
let defExts = zip availableExtensions (repeat False)
#endif
onState (\s -> s{defaultExts = defExts})
reset
runInterpreter :: (MonadIO m, MonadMask m, Functor m)
=> InterpreterT m a
-> m (Either InterpreterError a)
runInterpreter = runInterpreterWithArgs []
runInterpreterWithArgs :: (MonadIO m, MonadMask m, Functor m)
=> [String]
-> InterpreterT m a
-> m (Either InterpreterError a)
runInterpreterWithArgs args action =
ifInterpreterNotRunning $
do s <- newInterpreterSession `MC.catch` rethrowGhcException
execute s (initialize args >> action `finally` cleanSession)
where rethrowGhcException = throwM . GhcException . showGhcEx
#if __GLASGOW_HASKELL__ < 610
newInterpreterSession = do s <- liftIO $
Compat.newSession GHC.Paths.libdir
newSessionData s
cleanSession = cleanPhantomModules
#else
newInterpreterSession = newSessionData ()
cleanSession =
do cleanPhantomModules
runGhc $ do dflags <- GHC.getSessionDynFlags
GHC.defaultCleanupHandler dflags (return ())
#endif
uniqueToken :: MVar ()
uniqueToken = unsafePerformIO $ newMVar ()
ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a
ifInterpreterNotRunning action =
do maybe_token <- liftIO $ tryTakeMVar uniqueToken
case maybe_token of
Nothing -> throwM MultipleInstancesNotAllowed
Just x -> action `finally` (liftIO $ putMVar uniqueToken x)
data MultipleInstancesNotAllowed = MultipleInstancesNotAllowed deriving Typeable
instance Exception MultipleInstancesNotAllowed
instance Show MultipleInstancesNotAllowed where
show _ = "This version of GHC is not thread-safe," ++
"can't safely run two instances of the interpreter simultaneously"
initialState :: InterpreterState
initialState = St {active_phantoms = [],
zombie_phantoms = [],
hint_support_module = error "No support module loaded!",
import_qual_hack_mod = Nothing,
qual_imports = [],
defaultExts = error "defaultExts missing!",
configuration = defaultConf}
newSessionData :: MonadIO m => a -> m (SessionData a)
newSessionData a =
do initial_state <- liftIO $ newIORef initialState
ghc_err_list_ref <- liftIO $ newIORef []
return SessionData{
internalState = initial_state,
versionSpecific = a,
ghcErrListRef = ghc_err_list_ref,
ghcErrLogger = mkLogHandler ghc_err_list_ref
}
mkLogHandler :: IORef [GhcError] -> GhcErrLogger
mkLogHandler r =
#if __GLASGOW_HASKELL__ < 706
\_ src style msg ->
let renderErrMsg = Compat.showSDoc ()
#else
\df _ src style msg ->
let renderErrMsg = Compat.showSDoc df
#endif
errorEntry = mkGhcError renderErrMsg src style msg
in modifyIORef r (errorEntry :)
mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError
mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg}
where niceErrMsg = render . GHC.withPprStyle style $
Compat.mkLocMessage src_span msg
instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where
fromSession f = InterpreterT $ fmap f ask
modifySessionRef target f =
do ref <- fromSession target
old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))
return old_val
runGhc a = runGhc_impl a
instance (Monad m, Applicative m) => Applicative (InterpreterT m) where
pure = return
(<*>) = ap