module Hint.InterpreterT (
    InterpreterT, Interpreter,
    runInterpreter, runInterpreterWithArgs, runInterpreterWithArgsLibdir,
    MultipleInstancesNotAllowed(..)
) where

import Control.Applicative
import Prelude

import Hint.Base
import Hint.Context
import Hint.Configuration
import Hint.Extension

import Control.Monad (ap, unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.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.Maybe

import qualified GHC.Paths

import qualified Hint.GHC as GHC

type Interpreter = InterpreterT IO

newtype InterpreterT m a = InterpreterT {
                             forall (m :: * -> *) a.
InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a
unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a
                           }
    deriving ((forall a b. (a -> b) -> InterpreterT m a -> InterpreterT m b)
-> (forall a b. a -> InterpreterT m b -> InterpreterT m a)
-> Functor (InterpreterT m)
forall a b. a -> InterpreterT m b -> InterpreterT m a
forall a b. (a -> b) -> InterpreterT m a -> InterpreterT m b
forall (m :: * -> *) a b.
Functor m =>
a -> InterpreterT m b -> InterpreterT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpreterT m a -> InterpreterT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpreterT m a -> InterpreterT m b
fmap :: forall a b. (a -> b) -> InterpreterT m a -> InterpreterT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> InterpreterT m b -> InterpreterT m a
<$ :: forall a b. a -> InterpreterT m b -> InterpreterT m a
Functor, Applicative (InterpreterT m)
Applicative (InterpreterT m) =>
(forall a b.
 InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b)
-> (forall a b.
    InterpreterT m a -> InterpreterT m b -> InterpreterT m b)
-> (forall a. a -> InterpreterT m a)
-> Monad (InterpreterT m)
forall a. a -> InterpreterT m a
forall a b.
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
forall a b.
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
forall (m :: * -> *). Monad m => Applicative (InterpreterT m)
forall (m :: * -> *) a. Monad m => a -> InterpreterT m a
forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
>>= :: forall a b.
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
>> :: forall a b.
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> InterpreterT m a
return :: forall a. a -> InterpreterT m a
Monad, Monad (InterpreterT m)
Monad (InterpreterT m) =>
(forall a. IO a -> InterpreterT m a) -> MonadIO (InterpreterT m)
forall a. IO a -> InterpreterT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (InterpreterT m)
forall (m :: * -> *) a. MonadIO m => IO a -> InterpreterT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> InterpreterT m a
liftIO :: forall a. IO a -> InterpreterT m a
MonadIO, Monad (InterpreterT m)
Monad (InterpreterT m) =>
(forall e a. (HasCallStack, Exception e) => e -> InterpreterT m a)
-> MonadThrow (InterpreterT m)
forall e a. (HasCallStack, Exception e) => e -> InterpreterT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadCatch m => Monad (InterpreterT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
e -> InterpreterT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
e -> InterpreterT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> InterpreterT m a
MonadThrow, MonadThrow (InterpreterT m)
MonadThrow (InterpreterT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a)
-> MonadCatch (InterpreterT m)
forall e a.
(HasCallStack, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
MonadThrow (InterpreterT m)
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, HasCallStack, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, HasCallStack, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
MonadCatch, MonadCatch (InterpreterT m)
MonadCatch (InterpreterT m) =>
(forall b.
 HasCallStack =>
 ((forall a. InterpreterT m a -> InterpreterT m a)
  -> InterpreterT m b)
 -> InterpreterT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. InterpreterT m a -> InterpreterT m a)
     -> InterpreterT m b)
    -> InterpreterT m b)
-> (forall a b c.
    HasCallStack =>
    InterpreterT m a
    -> (a -> ExitCase b -> InterpreterT m c)
    -> (a -> InterpreterT m b)
    -> InterpreterT m (b, c))
-> MonadMask (InterpreterT m)
forall b.
HasCallStack =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
forall a b c.
HasCallStack =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
MonadCatch (InterpreterT m)
forall (m :: * -> *) b.
(MonadIO m, MonadMask m, HasCallStack) =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m, HasCallStack) =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m, HasCallStack) =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
mask :: forall b.
HasCallStack =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m, HasCallStack) =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m, HasCallStack) =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
MonadMask)

execute :: (MonadIO m, MonadMask m)
        => String
        -> InterpreterSession
        -> InterpreterT m a
        -> m (Either InterpreterError a)
execute :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String
-> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute String
libdir InterpreterSession
s = m a -> m (Either InterpreterError a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try
                 (m a -> m (Either InterpreterError a))
-> (InterpreterT m a -> m a)
-> InterpreterT m a
-> m (Either InterpreterError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> GhcT m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Maybe String -> GhcT m a -> m a
GHC.runGhcT (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir)
                 (GhcT m a -> m a)
-> (InterpreterT m a -> GhcT m a) -> InterpreterT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT InterpreterSession (GhcT m) a
 -> InterpreterSession -> GhcT m a)
-> InterpreterSession
-> ReaderT InterpreterSession (GhcT m) a
-> GhcT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT InterpreterSession (GhcT m) a
-> InterpreterSession -> GhcT m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT InterpreterSession
s
                 (ReaderT InterpreterSession (GhcT m) a -> GhcT m a)
-> (InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a)
-> InterpreterT m a
-> GhcT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a
forall (m :: * -> *) a.
InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a
unInterpreterT

instance MonadTrans InterpreterT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> InterpreterT m a
lift = ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
forall (m :: * -> *) a.
ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
InterpreterT (ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a)
-> (m a -> ReaderT InterpreterSession (GhcT m) a)
-> m a
-> InterpreterT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcT m a -> ReaderT InterpreterSession (GhcT m) a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT InterpreterSession m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GhcT m a -> ReaderT InterpreterSession (GhcT m) a)
-> (m a -> GhcT m a)
-> m a
-> ReaderT InterpreterSession (GhcT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> GhcT m a
forall (m :: * -> *) a. Monad m => m a -> GhcT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runGhcImpl :: (MonadIO m, MonadMask m)
           => RunGhc (InterpreterT m) a
runGhcImpl :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RunGhc (InterpreterT m) a
runGhcImpl forall (n :: * -> *). (MonadIO n, MonadMask n) => GhcT n a
a =
  ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
forall (m :: * -> *) a.
ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
InterpreterT (GhcT m a -> ReaderT InterpreterSession (GhcT m) a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT InterpreterSession m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift GhcT m a
forall (n :: * -> *). (MonadIO n, MonadMask n) => GhcT n a
a)
   InterpreterT m a
-> [Handler (InterpreterT m) a] -> InterpreterT m a
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches`
   [(SourceError -> InterpreterT m a) -> Handler (InterpreterT m) a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(SourceError
e :: GHC.SourceError)  -> do
     dynFlags <- RunGhc (InterpreterT m) DynFlags
forall a. RunGhc (InterpreterT m) a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc GhcT n DynFlags
forall {n :: * -> *}. (MonadIO n, MonadMask n) => GhcT n DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
     throwM $ compilationError dynFlags e)
   ,(GhcApiError -> InterpreterT m a) -> Handler (InterpreterT m) a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(GhcApiError
e :: GHC.GhcApiError)  -> InterpreterError -> InterpreterT m a
forall e a. (HasCallStack, Exception e) => e -> InterpreterT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (InterpreterError -> InterpreterT m a)
-> InterpreterError -> InterpreterT m a
forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
GhcException (String -> InterpreterError) -> String -> InterpreterError
forall a b. (a -> b) -> a -> b
$ GhcApiError -> String
forall a. Show a => a -> String
show GhcApiError
e)
   ,(GhcException -> InterpreterT m a) -> Handler (InterpreterT m) a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(GhcException
e :: GHC.GhcException) -> InterpreterError -> InterpreterT m a
forall e a. (HasCallStack, Exception e) => e -> InterpreterT m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (InterpreterError -> InterpreterT m a)
-> InterpreterError -> InterpreterT m a
forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
GhcException (String -> InterpreterError) -> String -> InterpreterError
forall a b. (a -> b) -> a -> b
$ GhcException -> String
showGhcEx GhcException
e)
   ]
  where
    compilationError :: DynFlags -> SourceError -> InterpreterError
compilationError DynFlags
dynFlags
      = [GhcError] -> InterpreterError
WontCompile
      ([GhcError] -> InterpreterError)
-> (SourceError -> [GhcError]) -> SourceError -> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SDoc -> GhcError) -> [SDoc] -> [GhcError]
forall a b. (a -> b) -> [a] -> [b]
map (String -> GhcError
GhcError (String -> GhcError) -> (SDoc -> String) -> SDoc -> GhcError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
dynFlags)
      ([SDoc] -> [GhcError])
-> (SourceError -> [SDoc]) -> SourceError -> [GhcError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> [SDoc]
GHC.pprErrorMessages
      (ErrorMessages -> [SDoc])
-> (SourceError -> ErrorMessages) -> SourceError -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> ErrorMessages
GHC.srcErrorMessages

showGhcEx :: GHC.GhcException -> String
showGhcEx :: GhcException -> String
showGhcEx = (GhcException -> String -> String)
-> String -> GhcException -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SDocContext -> GhcException -> String -> String
GHC.showGhcException SDocContext
GHC.defaultSDocContext) String
""

-- ================= Executing the interpreter ==================

initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m)
           => [String]
           -> InterpreterT m ()
initialize :: forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadMask m, Functor m) =>
[String] -> InterpreterT m ()
initialize [String]
args =
    do logger <- FromSession (InterpreterT m) Logger
forall a. FromSession (InterpreterT m) a
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession InterpreterSession -> Logger
forall a. SessionData a -> Logger
ghcLogger
       -- Set a custom log handler, to intercept error messages :S
       df0 <- runGhc GHC.getSessionDynFlags

       let df1 = DynFlags -> DynFlags
configureDynFlags DynFlags
df0
       (df2, extra) <- runGhc $ parseDynamicFlags logger df1 args
       unless (null extra) $
            throwM $ UnknownError (concat [ "flags: '"
                                          , unwords extra
                                          , "' not recognized"])

       -- Observe that, setSessionDynFlags loads info on packages
       -- available; calling this function once is mandatory!
       runGhc $ GHC.modifyLogger (const logger)
       _ <- runGhc $ GHC.setSessionDynFlags df2

       let extMap      = [ (FlagSpec Extension -> String
forall flag. FlagSpec flag -> String
GHC.flagSpecName FlagSpec Extension
flagSpec, FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
GHC.flagSpecFlag FlagSpec Extension
flagSpec)
                         | FlagSpec Extension
flagSpec <- [FlagSpec Extension]
GHC.xFlags
                         ]
       let toOpt String
e     = let err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String
"init error: unknown ext:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
e)
                         in Extension -> Maybe Extension -> Extension
forall a. a -> Maybe a -> a
fromMaybe Extension
forall {a}. a
err (String -> [(String, Extension)] -> Maybe Extension
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
e [(String, Extension)]
extMap)
       let getOptVal String
e = (String -> Extension
asExtension String
e, Extension -> DynFlags -> Bool
GHC.xopt (String -> Extension
toOpt String
e) DynFlags
df2)
       let defExts = (String -> (Extension, Bool)) -> [String] -> [(Extension, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map  String -> (Extension, Bool)
getOptVal [String]
supportedExtensions

       onState (\InterpreterState
s -> InterpreterState
s{defaultExts = defExts})

       reset

-- | Executes the interpreter. Returns @Left InterpreterError@ in case of error.
--
-- NB. In hint-0.7.0 and earlier, the underlying ghc was accidentally
-- overwriting certain signal handlers (SIGINT, SIGHUP, SIGTERM, SIGQUIT on
-- Posix systems, Ctrl-C handler on Windows).
runInterpreter :: (MonadIO m, MonadMask m)
               => InterpreterT m a
               -> m (Either InterpreterError a)
runInterpreter :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InterpreterT m a -> m (Either InterpreterError a)
runInterpreter = [String] -> InterpreterT m a -> m (Either InterpreterError a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String] -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgs []

-- | Executes the interpreter, setting args passed in as though they
-- were command-line args. Returns @Left InterpreterError@ in case of
-- error.
runInterpreterWithArgs :: (MonadIO m, MonadMask m)
                       => [String]
                       -> InterpreterT m a
                       -> m (Either InterpreterError a)
runInterpreterWithArgs :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String] -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgs [String]
args = [String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir [String]
args String
GHC.Paths.libdir

runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m)
                             => [String]
                             -> String
                             -> InterpreterT m a
                             -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir [String]
args String
libdir InterpreterT m a
action =
#ifndef THREAD_SAFE_LINKER
  ifInterpreterNotRunning $
#endif
    do s <- m InterpreterSession
newInterpreterSession m InterpreterSession
-> (GhcException -> m InterpreterSession) -> m InterpreterSession
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`MC.catch` GhcException -> m InterpreterSession
forall {a}. GhcException -> m a
rethrowGhcException
       execute libdir s (initialize args >> action `finally` cleanSession)
    where rethrowGhcException :: GhcException -> m a
rethrowGhcException   = InterpreterError -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (InterpreterError -> m a)
-> (GhcException -> InterpreterError) -> GhcException -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InterpreterError
GhcException (String -> InterpreterError)
-> (GhcException -> String) -> GhcException -> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> String
showGhcEx
          newInterpreterSession :: m InterpreterSession
newInterpreterSession = () -> m InterpreterSession
forall (m :: * -> *) a. MonadIO m => a -> m (SessionData a)
newSessionData ()
          cleanSession :: InterpreterT m ()
cleanSession = InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules

#ifndef THREAD_SAFE_LINKER
{-# NOINLINE uniqueToken #-}
uniqueToken :: MVar ()
uniqueToken = unsafePerformIO $ newMVar ()

ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a
ifInterpreterNotRunning action = liftIO (tryTakeMVar uniqueToken) >>= \ case
    Nothing -> throwM MultipleInstancesNotAllowed
    Just x  -> action `finally` liftIO (putMVar uniqueToken x)
#endif

-- | The installed version of ghc is not thread-safe. This exception
--   is thrown whenever you try to execute @runInterpreter@ while another
--   instance is already running.
data MultipleInstancesNotAllowed = MultipleInstancesNotAllowed deriving Typeable

instance Exception MultipleInstancesNotAllowed

instance Show MultipleInstancesNotAllowed where
    show :: MultipleInstancesNotAllowed -> String
show MultipleInstancesNotAllowed
_ = String
"This version of GHC is not thread-safe," String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String
"can't safely run two instances of the interpreter simultaneously"

initialState :: InterpreterState
initialState :: InterpreterState
initialState = St {
                   activePhantoms :: [PhantomModule]
activePhantoms    = [],
                   zombiePhantoms :: [PhantomModule]
zombiePhantoms    = [],
                   phantomDirectory :: Maybe String
phantomDirectory  = Maybe String
forall a. Maybe a
Nothing,
                   hintSupportModule :: PhantomModule
hintSupportModule = String -> PhantomModule
forall a. HasCallStack => String -> a
error String
"No support module loaded!",
                   importQualHackMod :: Maybe PhantomModule
importQualHackMod = Maybe PhantomModule
forall a. Maybe a
Nothing,
                   qualImports :: [ModuleImport]
qualImports       = [],
                   defaultExts :: [(Extension, Bool)]
defaultExts       = String -> [(Extension, Bool)]
forall a. HasCallStack => String -> a
error String
"defaultExts missing!",
                   configuration :: InterpreterConfiguration
configuration     = InterpreterConfiguration
defaultConf
                  }

newSessionData :: MonadIO m => a -> m (SessionData a)
newSessionData :: forall (m :: * -> *) a. MonadIO m => a -> m (SessionData a)
newSessionData a
a =
    do initial_state    <- IO (IORef InterpreterState) -> m (IORef InterpreterState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef InterpreterState) -> m (IORef InterpreterState))
-> IO (IORef InterpreterState) -> m (IORef InterpreterState)
forall a b. (a -> b) -> a -> b
$ InterpreterState -> IO (IORef InterpreterState)
forall a. a -> IO (IORef a)
newIORef InterpreterState
initialState
       ghc_err_list_ref <- liftIO $ newIORef []
       logger           <- liftIO $ GHC.initLogger
       return SessionData {
         internalState   = initial_state,
         versionSpecific = a,
         ghcErrListRef   = ghc_err_list_ref,
         ghcLogger       = GHC.pushLogHook (const $ GHC.mkLogAction GhcError ghc_err_list_ref) logger
       }

-- The MonadInterpreter instance

instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where
    fromSession :: forall a. FromSession (InterpreterT m) a
fromSession InterpreterSession -> a
f = ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
forall (m :: * -> *) a.
ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
InterpreterT (ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a)
-> ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
forall a b. (a -> b) -> a -> b
$ (InterpreterSession -> a) -> ReaderT InterpreterSession (GhcT m) a
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks InterpreterSession -> a
f
    --
    modifySessionRef :: forall a. ModifySessionRef (InterpreterT m) a
modifySessionRef InterpreterSession -> IORef a
target a -> a
f =
        do ref <- FromSession (InterpreterT m) (IORef a)
forall a. FromSession (InterpreterT m) a
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession InterpreterSession -> IORef a
target
           liftIO $ atomicModifyIORef ref (\a
a -> (a -> a
f a
a, a
a))
    --
    runGhc :: forall a. RunGhc (InterpreterT m) a
runGhc = RunGhc (InterpreterT m) a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RunGhc (InterpreterT m) a
runGhcImpl

instance (Monad m) => Applicative (InterpreterT m) where
    pure :: forall a. a -> InterpreterT m a
pure  = a -> InterpreterT m a
forall a. a -> InterpreterT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b.
InterpreterT m (a -> b) -> InterpreterT m a -> InterpreterT m b
(<*>) = InterpreterT m (a -> b) -> InterpreterT m a -> InterpreterT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap