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
<$ :: forall a b. a -> InterpreterT m b -> InterpreterT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> InterpreterT m b -> InterpreterT m a
fmap :: forall a b. (a -> b) -> InterpreterT m a -> InterpreterT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpreterT m a -> InterpreterT m b
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
return :: forall a. a -> InterpreterT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> InterpreterT m a
>> :: forall a b.
InterpreterT m 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 -> (a -> InterpreterT m b) -> InterpreterT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
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
liftIO :: forall a. IO a -> InterpreterT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> InterpreterT m a
MonadIO, Monad (InterpreterT m)
Monad (InterpreterT m)
-> (forall e a. Exception e => e -> InterpreterT m a)
-> MonadThrow (InterpreterT m)
forall e a. Exception e => e -> InterpreterT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadCatch m => Monad (InterpreterT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
e -> InterpreterT m a
throwM :: forall e a. Exception e => e -> InterpreterT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
e -> InterpreterT m a
MonadThrow, MonadThrow (InterpreterT m)
MonadThrow (InterpreterT m)
-> (forall e a.
Exception e =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a)
-> MonadCatch (InterpreterT m)
forall e a.
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, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
MonadCatch, MonadCatch (InterpreterT m)
MonadCatch (InterpreterT m)
-> (forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b)
-> (forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b)
-> (forall a b c.
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c))
-> MonadMask (InterpreterT m)
forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b
forall a b c.
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) =>
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b
forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m) =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m) =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
uninterruptibleMask :: forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b
mask :: forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b
$cmask :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
((forall a. InterpreterT m a -> InterpreterT m a)
-> InterpreterT m b)
-> InterpreterT m b
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.
(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 (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 (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 (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.
(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
dynFlags <- RunGhc (InterpreterT 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
InterpreterError -> InterpreterT m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> InterpreterT m a)
-> InterpreterError -> InterpreterT m a
forall a b. (a -> b) -> a -> b
$ DynFlags -> SourceError -> InterpreterError
compilationError DynFlags
dynFlags SourceError
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 (m :: * -> *) e a. (MonadThrow m, 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 (m :: * -> *) e a. (MonadThrow m, 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
""
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
logger <- FromSession (InterpreterT m) Logger
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession InterpreterSession -> Logger
forall a. SessionData a -> Logger
ghcLogger
DynFlags
df0 <- RunGhc (InterpreterT 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 df1 :: DynFlags
df1 = DynFlags -> DynFlags
configureDynFlags DynFlags
df0
(DynFlags
df2, [String]
extra) <- RunGhc (InterpreterT m) (DynFlags, [String])
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc (InterpreterT m) (DynFlags, [String])
-> RunGhc (InterpreterT m) (DynFlags, [String])
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [String] -> GhcT n (DynFlags, [String])
forall (m :: * -> *).
GhcMonad m =>
Logger -> DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags Logger
logger DynFlags
df1 [String]
args
Bool -> InterpreterT m () -> InterpreterT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extra) (InterpreterT m () -> InterpreterT m ())
-> InterpreterT m () -> InterpreterT m ()
forall a b. (a -> b) -> a -> b
$
InterpreterError -> InterpreterT m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> InterpreterT m ())
-> InterpreterError -> InterpreterT m ()
forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
UnknownError ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"flags: '"
, [String] -> String
unwords [String]
extra
, String
"' not recognized"])
RunGhc (InterpreterT m) ()
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc (InterpreterT m) () -> RunGhc (InterpreterT m) ()
forall a b. (a -> b) -> a -> b
$ (Logger -> Logger) -> GhcT n ()
forall (m :: * -> *). GhcMonad m => (Logger -> Logger) -> m ()
GHC.modifyLogger (Logger -> Logger -> Logger
forall a b. a -> b -> a
const Logger
logger)
()
_ <- RunGhc (InterpreterT m) ()
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc (InterpreterT m) () -> RunGhc (InterpreterT m) ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> GhcT n ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
df2
let extMap :: [(String, Extension)]
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 -> Extension
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 -> (Extension, Bool)
getOptVal String
e = (String -> Extension
asExtension String
e, Extension -> DynFlags -> Bool
GHC.xopt (String -> Extension
toOpt String
e) DynFlags
df2)
let defExts :: [(Extension, Bool)]
defExts = (String -> (Extension, Bool)) -> [String] -> [(Extension, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (Extension, Bool)
getOptVal [String]
supportedExtensions
(InterpreterState -> InterpreterState) -> InterpreterT m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{defaultExts :: [(Extension, Bool)]
defaultExts = [(Extension, Bool)]
defExts})
InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => m ()
reset
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 []
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 InterpreterSession
s <- m InterpreterSession
newInterpreterSession m InterpreterSession
-> (GhcException -> m InterpreterSession) -> m InterpreterSession
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`MC.catch` GhcException -> m InterpreterSession
forall {a}. GhcException -> m a
rethrowGhcException
String
-> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String
-> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute String
libdir InterpreterSession
s ([String] -> InterpreterT m ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadMask m, Functor m) =>
[String] -> InterpreterT m ()
initialize [String]
args InterpreterT m () -> InterpreterT m a -> InterpreterT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InterpreterT m a
action InterpreterT m a -> InterpreterT m () -> InterpreterT m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` InterpreterT m ()
cleanSession)
where rethrowGhcException :: GhcException -> m a
rethrowGhcException = InterpreterError -> m a
forall (m :: * -> *) e a. (MonadThrow m, 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
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 IORef InterpreterState
initial_state <- IO (IORef InterpreterState) -> m (IORef InterpreterState)
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
IORef [GhcError]
ghc_err_list_ref <- IO (IORef [GhcError]) -> m (IORef [GhcError])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [GhcError]) -> m (IORef [GhcError]))
-> IO (IORef [GhcError]) -> m (IORef [GhcError])
forall a b. (a -> b) -> a -> b
$ [GhcError] -> IO (IORef [GhcError])
forall a. a -> IO (IORef a)
newIORef []
Logger
logger <- IO Logger -> m Logger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> m Logger) -> IO Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ IO Logger
GHC.initLogger
SessionData a -> m (SessionData a)
forall (m :: * -> *) a. Monad m => a -> m a
return SessionData {
internalState :: IORef InterpreterState
internalState = IORef InterpreterState
initial_state,
versionSpecific :: a
versionSpecific = a
a,
ghcErrListRef :: IORef [GhcError]
ghcErrListRef = IORef [GhcError]
ghc_err_list_ref,
ghcLogger :: Logger
ghcLogger = (LogAction -> LogAction) -> Logger -> Logger
GHC.pushLogHook (LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const (LogAction -> LogAction -> LogAction)
-> LogAction -> LogAction -> LogAction
forall a b. (a -> b) -> a -> b
$ IORef [GhcError] -> LogAction
mkLogAction IORef [GhcError]
ghc_err_list_ref) Logger
logger
}
mkLogAction :: IORef [GhcError] -> GHC.LogAction
mkLogAction :: IORef [GhcError] -> LogAction
mkLogAction IORef [GhcError]
r = (DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> (SDoc -> SDoc)
-> SDoc
-> IO ())
-> LogAction
forall {t} {t} {t} {t} {a} {t} {t}.
(t -> t -> t -> t -> (a -> a) -> t -> t)
-> t -> t -> t -> t -> t -> t
mkLogAction' ((DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> (SDoc -> SDoc)
-> SDoc
-> IO ())
-> LogAction)
-> (DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> (SDoc -> SDoc)
-> SDoc
-> IO ())
-> LogAction
forall a b. (a -> b) -> a -> b
$ \DynFlags
df WarnReason
_ Severity
_ SrcSpan
src SDoc -> SDoc
withStyle SDoc
msg ->
let renderErrMsg :: SDoc -> String
renderErrMsg = DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
df (SDoc -> String) -> (SDoc -> SDoc) -> SDoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> SDoc
withStyle
errorEntry :: GhcError
errorEntry = (SDoc -> String) -> SrcSpan -> SDoc -> GhcError
mkGhcError SDoc -> String
renderErrMsg SrcSpan
src SDoc
msg
in IORef [GhcError] -> ([GhcError] -> [GhcError]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [GhcError]
r (GhcError
errorEntry GhcError -> [GhcError] -> [GhcError]
forall a. a -> [a] -> [a]
:)
where
mkLogAction' :: (t -> t -> t -> t -> (a -> a) -> t -> t)
-> t -> t -> t -> t -> t -> t
mkLogAction' t -> t -> t -> t -> (a -> a) -> t -> t
f =
#if MIN_VERSION_ghc(9,0,0)
\t
df t
wr t
sev t
src t
msg -> t -> t -> t -> t -> (a -> a) -> t -> t
f t
df t
wr t
sev t
src a -> a
forall a. a -> a
id t
msg
#else
\df wr sev src style msg -> f df wr sev src (GHC.withPprStyle style) msg
#endif
mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.Message -> GhcError
mkGhcError :: (SDoc -> String) -> SrcSpan -> SDoc -> GhcError
mkGhcError SDoc -> String
render SrcSpan
src_span SDoc
msg = GhcError{errMsg :: String
errMsg = String
niceErrMsg}
where niceErrMsg :: String
niceErrMsg = SDoc -> String
render (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ Severity -> SrcSpan -> SDoc -> SDoc
GHC.mkLocMessage Severity
GHC.SevError SrcSpan
src_span SDoc
msg
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 IORef a
ref <- FromSession (InterpreterT m) (IORef a)
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession InterpreterSession -> IORef a
target
IO a -> InterpreterT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> InterpreterT m a) -> IO a -> InterpreterT m a
forall a b. (a -> b) -> a -> b
$ IORef a -> (a -> (a, a)) -> IO a
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
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 (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