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.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 {
                             InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a
unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a
                           }
    deriving (a -> InterpreterT m b -> InterpreterT m a
(a -> b) -> InterpreterT m a -> InterpreterT m b
(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
<$ :: a -> InterpreterT m b -> InterpreterT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> InterpreterT m b -> InterpreterT m a
fmap :: (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)
a -> InterpreterT m a
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)
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
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 :: a -> InterpreterT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> InterpreterT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (InterpreterT m)
Monad, Monad (InterpreterT m)
Monad (InterpreterT m) =>
(forall a. IO a -> InterpreterT m a) -> MonadIO (InterpreterT m)
IO a -> InterpreterT m a
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 :: IO a -> InterpreterT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> InterpreterT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (InterpreterT m)
MonadIO, Monad (InterpreterT m)
e -> InterpreterT m a
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 :: e -> InterpreterT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
e -> InterpreterT m a
$cp1MonadThrow :: forall (m :: * -> *). MonadCatch m => Monad (InterpreterT m)
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)
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
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 :: 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
$cp1MonadCatch :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
MonadThrow (InterpreterT m)
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)
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m 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)
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 :: 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 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 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
$cp1MonadMask :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
MonadCatch (InterpreterT m)
MonadMask)

execute :: (MonadIO m, MonadMask m)
        => String
        -> InterpreterSession
        -> InterpreterT m a
        -> m (Either InterpreterError a)
execute :: String
-> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute libdir :: String
libdir s :: 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 :: 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 :: RunGhc (InterpreterT m) a
runGhcImpl a :: 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
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
. Bag ErrMsg -> [SDoc]
GHC.pprErrMsgBagWithLoc
      (Bag ErrMsg -> [SDoc])
-> (SourceError -> Bag ErrMsg) -> SourceError -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> Bag ErrMsg
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 GhcException -> String -> String
GHC.showGhcException ""

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

initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m)
           => [String]
           -> InterpreterT m ()
initialize :: [String] -> InterpreterT m ()
initialize args :: [String]
args =
    do GhcErrLogger
log_handler <- FromSession (InterpreterT m) GhcErrLogger
forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession InterpreterSession -> GhcErrLogger
forall a. SessionData a -> GhcErrLogger
ghcErrLogger
       -- Set a custom log handler, to intercept error messages :S
       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
       (df2 :: DynFlags
df2, extra :: [String]
extra) <- RunGhc2 (InterpreterT m) DynFlags [String] (DynFlags, [String])
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
DynFlags -> [String] -> GhcT n (DynFlags, [String])
forall (m :: * -> *).
GhcMonad m =>
DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags 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 [ "flags: '"
                                          , [String] -> String
unwords [String]
extra
                                          , "' not recognized"])

       -- Observe that, setSessionDynFlags loads info on packages
       -- available; calling this function once is mandatory!
       [InstalledUnitId]
_ <- RunGhc1 (InterpreterT m) DynFlags [InstalledUnitId]
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
DynFlags -> GhcT n [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
df2{log_action :: GhcErrLogger
GHC.log_action = GhcErrLogger
log_handler}

       let extMap :: [(String, Extension)]
extMap      = (FlagSpec Extension -> (String, Extension))
-> [FlagSpec Extension] -> [(String, Extension)]
forall a b. (a -> b) -> [a] -> [b]
map (\fs :: FlagSpec Extension
fs -> (FlagSpec Extension -> String
forall flag. FlagSpec flag -> String
GHC.flagSpecName FlagSpec Extension
fs, FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
GHC.flagSpecFlag FlagSpec Extension
fs)) [FlagSpec Extension]
GHC.xFlags
       let toOpt :: String -> Extension
toOpt e :: String
e     = let err :: a
err = String -> a
forall a. HasCallStack => String -> a
error ("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 e :: 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 (\s :: InterpreterState
s -> InterpreterState
s{defaultExts :: [(Extension, Bool)]
defaultExts = [(Extension, Bool)]
defExts})

       InterpreterT m ()
forall (m :: * -> *). MonadInterpreter m => m ()
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 :: 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 :: [String] -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgs args :: [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 :: [String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir args :: [String]
args libdir :: String
libdir action :: InterpreterT m a
action =
  m (Either InterpreterError a) -> m (Either InterpreterError a)
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
ifInterpreterNotRunning (m (Either InterpreterError a) -> m (Either InterpreterError a))
-> m (Either InterpreterError a) -> m (Either InterpreterError a)
forall a b. (a -> b) -> a -> b
$
    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

{-# NOINLINE uniqueToken #-}
uniqueToken :: MVar ()
uniqueToken :: MVar ()
uniqueToken = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()

ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a
ifInterpreterNotRunning :: m a -> m a
ifInterpreterNotRunning action :: m a
action =
    do Maybe ()
maybe_token <- IO (Maybe ()) -> m (Maybe ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> m (Maybe ())) -> IO (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
uniqueToken
       case Maybe ()
maybe_token of
           Nothing -> MultipleInstancesNotAllowed -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM MultipleInstancesNotAllowed
MultipleInstancesNotAllowed
           Just x :: ()
x  -> m a
action m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
uniqueToken ()
x)

-- | 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 _ = "This version of GHC is not thread-safe," String -> String -> String
forall a. [a] -> [a] -> [a]
++
             "can't safely run two instances of the interpreter simultaneously"

initialState :: InterpreterState
initialState :: InterpreterState
initialState = St :: [PhantomModule]
-> [PhantomModule]
-> Maybe String
-> PhantomModule
-> Maybe PhantomModule
-> [ModuleImport]
-> [(Extension, Bool)]
-> InterpreterConfiguration
-> InterpreterState
St {
                   activePhantoms :: [PhantomModule]
activePhantoms    = [],
                   zombiePhantoms :: [PhantomModule]
zombiePhantoms    = [],
#if defined(NEED_PHANTOM_DIRECTORY)
                   phantomDirectory :: Maybe String
phantomDirectory  = Maybe String
forall a. Maybe a
Nothing,
#endif
                   hintSupportModule :: PhantomModule
hintSupportModule = String -> PhantomModule
forall a. HasCallStack => String -> a
error "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 "defaultExts missing!",
                   configuration :: InterpreterConfiguration
configuration     = InterpreterConfiguration
defaultConf
                  }

newSessionData :: MonadIO m => a -> m (SessionData a)
newSessionData :: a -> m (SessionData a)
newSessionData a :: 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 []
       SessionData a -> m (SessionData a)
forall (m :: * -> *) a. Monad m => a -> m a
return SessionData :: forall a.
IORef InterpreterState
-> a -> IORef [GhcError] -> GhcErrLogger -> SessionData a
SessionData {
         internalState :: IORef InterpreterState
internalState   = IORef InterpreterState
initial_state,
         versionSpecific :: a
versionSpecific = a
a,
         ghcErrListRef :: IORef [GhcError]
ghcErrListRef   = IORef [GhcError]
ghc_err_list_ref,
         ghcErrLogger :: GhcErrLogger
ghcErrLogger    = IORef [GhcError] -> GhcErrLogger
mkLogHandler IORef [GhcError]
ghc_err_list_ref
       }

mkLogHandler :: IORef [GhcError] -> GhcErrLogger
mkLogHandler :: IORef [GhcError] -> GhcErrLogger
mkLogHandler r :: IORef [GhcError]
r df :: DynFlags
df _ _ src :: SrcSpan
src style :: PprStyle
style msg :: SDoc
msg =
    let renderErrMsg :: SDoc -> String
renderErrMsg = DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
df
        errorEntry :: GhcError
errorEntry = (SDoc -> String) -> SrcSpan -> PprStyle -> SDoc -> GhcError
mkGhcError SDoc -> String
renderErrMsg SrcSpan
src PprStyle
style 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]
:)

mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError
mkGhcError :: (SDoc -> String) -> SrcSpan -> PprStyle -> SDoc -> GhcError
mkGhcError render :: SDoc -> String
render src_span :: SrcSpan
src_span style :: PprStyle
style msg :: SDoc
msg = GhcError :: String -> GhcError
GhcError{errMsg :: String
errMsg = String
niceErrMsg}
    where niceErrMsg :: String
niceErrMsg = SDoc -> String
render (SDoc -> String) -> (SDoc -> SDoc) -> SDoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PprStyle -> SDoc -> SDoc
GHC.withPprStyle PprStyle
style (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

-- The MonadInterpreter instance

instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where
    fromSession :: FromSession (InterpreterT m) a
fromSession f :: 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 r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks InterpreterSession -> a
f
    --
    modifySessionRef :: ModifySessionRef (InterpreterT m) a
modifySessionRef target :: InterpreterSession -> IORef a
target f :: 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 -> a
f a
a, a
a))
    --
    runGhc :: 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 :: a -> InterpreterT m a
pure  = a -> InterpreterT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: 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