module Hint.Context (
      isModuleInterpreted,
      loadModules, getLoadedModules, setTopLevelModules,
      setImports, setImportsQ, setImportsF,
      reset,

      PhantomModule(..),
      cleanPhantomModules,

      supportString, supportShow
) where

import Prelude hiding (mod)

import Data.Char
import Data.Either (partitionEithers)
import Data.List

import Control.Arrow ((***))

import Control.Monad (filterM, unless, guard, foldM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Catch

import Hint.Base
import Hint.Conversions
import qualified Hint.CompatPlatform as Compat

import qualified Hint.GHC as GHC

import System.Random
import System.FilePath
import System.Directory

import Data.Maybe (maybe)
import Hint.Configuration (setGhcOption)
import System.IO.Temp

type ModuleText = String

-- When creating a phantom module we have a situation similar to that of
-- @Hint.Util.safeBndFor@: we want to avoid picking a module name that is
-- already in-scope. Additionally, since this may be used with sandboxing in
-- mind we want to avoid easy-to-guess names. Thus, we do a trick similar
-- to the one in safeBndFor, but including a random number instead of an
-- additional digit. Finally, to avoid clashes between two processes
-- that are concurrently running with the same random seed (e.g., initialized
-- with the system time with not enough resolution), we also include the process id
newPhantomModule :: MonadInterpreter m => m PhantomModule
newPhantomModule :: m PhantomModule
newPhantomModule =
    do Int
n <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
forall a. Random a => IO a
randomIO
       Int
p <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
Compat.getPID
       (ls :: [ModuleName]
ls,is :: [ModuleName]
is) <- m ([ModuleName], [ModuleName])
forall (m :: * -> *).
MonadInterpreter m =>
m ([ModuleName], [ModuleName])
allModulesInContext
       let nums :: ModuleName
nums = [ModuleName] -> ModuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Int -> ModuleName
forall a. Show a => a -> ModuleName
show (Int -> Int
forall a. Num a => a -> a
abs Int
n::Int), Int -> ModuleName
forall a. Show a => a -> ModuleName
show Int
p, (Char -> Bool) -> ModuleName -> ModuleName
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit (ModuleName -> ModuleName) -> ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> ModuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ModuleName]
ls [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
is)]
       let mod_name :: ModuleName
mod_name = 'M'Char -> ModuleName -> ModuleName
forall a. a -> [a] -> [a]
:ModuleName
nums
       --
       ModuleName
tmp_dir <- m ModuleName
forall (m :: * -> *). MonadInterpreter m => m ModuleName
getPhantomDirectory
       --
       PhantomModule -> m PhantomModule
forall (m :: * -> *) a. Monad m => a -> m a
return PhantomModule :: ModuleName -> ModuleName -> PhantomModule
PhantomModule{pmName :: ModuleName
pmName = ModuleName
mod_name, pmFile :: ModuleName
pmFile = ModuleName
tmp_dir ModuleName -> ModuleName -> ModuleName
</> ModuleName
mod_name ModuleName -> ModuleName -> ModuleName
<.> "hs"}

getPhantomDirectory :: MonadInterpreter m => m FilePath
getPhantomDirectory :: m ModuleName
getPhantomDirectory =
    -- When a module is loaded by file name, ghc-8.4.1 loses track of the
    -- file location after the first time it has been loaded, so we create
    -- a directory for the phantom modules and add it to the search path.
    do Maybe ModuleName
mfp <- (InterpreterState -> Maybe ModuleName) -> m (Maybe ModuleName)
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe ModuleName
phantomDirectory
       case Maybe ModuleName
mfp of
           Just fp :: ModuleName
fp -> ModuleName -> m ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
fp
           Nothing -> do ModuleName
tmp_dir <- IO ModuleName -> m ModuleName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ModuleName
getTemporaryDirectory
                         ModuleName
fp <- IO ModuleName -> m ModuleName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModuleName -> m ModuleName) -> IO ModuleName -> m ModuleName
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> IO ModuleName
createTempDirectory ModuleName
tmp_dir "hint"
                         (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{ phantomDirectory :: Maybe ModuleName
phantomDirectory = ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
fp })
                         ModuleName -> m ()
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m ()
setGhcOption (ModuleName -> m ()) -> ModuleName -> m ()
forall a b. (a -> b) -> a -> b
$ "-i" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
fp
                         ModuleName -> m ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
fp

allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])
allModulesInContext :: m ([ModuleName], [ModuleName])
allModulesInContext = RunGhc m ([ModuleName], [ModuleName])
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n ([ModuleName], [ModuleName])
forall (m :: * -> *). GhcMonad m => m ([ModuleName], [ModuleName])
getContextNames

getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs])
getContext :: m ([Module], [ImportDecl GhcPs])
getContext = do
    [InteractiveImport]
ctx <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
GHC.getContext
    (([Module], [ImportDecl GhcPs])
 -> InteractiveImport -> m ([Module], [ImportDecl GhcPs]))
-> ([Module], [ImportDecl GhcPs])
-> [InteractiveImport]
-> m ([Module], [ImportDecl GhcPs])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Module], [ImportDecl GhcPs])
-> InteractiveImport -> m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
([Module], [ImportDecl GhcPs])
-> InteractiveImport -> m ([Module], [ImportDecl GhcPs])
f ([], []) [InteractiveImport]
ctx
  where
    f :: (GHC.GhcMonad m) =>
         ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) ->
         GHC.InteractiveImport ->
         m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs])
    f :: ([Module], [ImportDecl GhcPs])
-> InteractiveImport -> m ([Module], [ImportDecl GhcPs])
f (ns :: [Module]
ns, ds :: [ImportDecl GhcPs]
ds) i :: InteractiveImport
i = case InteractiveImport
i of
      (GHC.IIDecl d :: ImportDecl GhcPs
d)     -> ([Module], [ImportDecl GhcPs]) -> m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Module]
ns, ImportDecl GhcPs
d ImportDecl GhcPs -> [ImportDecl GhcPs] -> [ImportDecl GhcPs]
forall a. a -> [a] -> [a]
: [ImportDecl GhcPs]
ds)
      (GHC.IIModule m :: ModuleName
m) -> do Module
n <- ModuleName -> Maybe FastString -> m Module
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
m Maybe FastString
forall a. Maybe a
Nothing; ([Module], [ImportDecl GhcPs]) -> m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *) a. Monad m => a -> m a
return (Module
n Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
ns, [ImportDecl GhcPs]
ds)

modToIIMod :: GHC.Module -> GHC.InteractiveImport
modToIIMod :: Module -> InteractiveImport
modToIIMod = ModuleName -> InteractiveImport
GHC.IIModule (ModuleName -> InteractiveImport)
-> (Module -> ModuleName) -> Module -> InteractiveImport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
GHC.moduleName

getContextNames :: GHC.GhcMonad m => m([String], [String])
getContextNames :: m ([ModuleName], [ModuleName])
getContextNames = (([Module], [ImportDecl GhcPs]) -> ([ModuleName], [ModuleName]))
-> m ([Module], [ImportDecl GhcPs])
-> m ([ModuleName], [ModuleName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Module -> ModuleName) -> [Module] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Module -> ModuleName
name ([Module] -> [ModuleName])
-> ([ImportDecl GhcPs] -> [ModuleName])
-> ([Module], [ImportDecl GhcPs])
-> ([ModuleName], [ModuleName])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (ImportDecl GhcPs -> ModuleName)
-> [ImportDecl GhcPs] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> ModuleName
forall pass. ImportDecl pass -> ModuleName
decl) m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
    where name :: Module -> ModuleName
name = ModuleName -> ModuleName
GHC.moduleNameString (ModuleName -> ModuleName)
-> (Module -> ModuleName) -> Module -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
GHC.moduleName
          decl :: ImportDecl pass -> ModuleName
decl = ModuleName -> ModuleName
GHC.moduleNameString (ModuleName -> ModuleName)
-> (ImportDecl pass -> ModuleName) -> ImportDecl pass -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc (Located ModuleName -> ModuleName)
-> (ImportDecl pass -> Located ModuleName)
-> ImportDecl pass
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
GHC.ideclName

setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m ()
setContext :: [Module] -> [ImportDecl GhcPs] -> m ()
setContext ms :: [Module]
ms ds :: [ImportDecl GhcPs]
ds =
  let ms' :: [InteractiveImport]
ms' = (Module -> InteractiveImport) -> [Module] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map Module -> InteractiveImport
modToIIMod [Module]
ms
      ds' :: [InteractiveImport]
ds' = (ImportDecl GhcPs -> InteractiveImport)
-> [ImportDecl GhcPs] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> InteractiveImport
GHC.IIDecl [ImportDecl GhcPs]
ds
      is :: [InteractiveImport]
is = [InteractiveImport]
ms' [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
ds'
  in [InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
GHC.setContext [InteractiveImport]
is

-- Explicitly-typed variants of getContext/setContext, for use where we modify
-- or override the context.
setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()
setContextModules :: [Module] -> [Module] -> m ()
setContextModules as :: [Module]
as = [Module] -> [ImportDecl GhcPs] -> m ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
as ([ImportDecl GhcPs] -> m ())
-> ([Module] -> [ImportDecl GhcPs]) -> [Module] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> ImportDecl GhcPs) -> [Module] -> [ImportDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> ImportDecl GhcPs
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
GHC.simpleImportDecl (ModuleName -> ImportDecl GhcPs)
-> (Module -> ModuleName) -> Module -> ImportDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
GHC.moduleName)

fileTarget :: FilePath -> GHC.Target
fileTarget :: ModuleName -> Target
fileTarget f :: ModuleName
f = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> Maybe Phase -> TargetId
GHC.TargetFile ModuleName
f (Maybe Phase -> TargetId) -> Maybe Phase -> TargetId
forall a b. (a -> b) -> a -> b
$ Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
next_phase) Bool
True Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
    where next_phase :: Phase
next_phase = HscSource -> Phase
GHC.Cpp HscSource
GHC.HsSrcFile

addPhantomModule :: MonadInterpreter m
                 => (ModuleName -> ModuleText)
                 -> m PhantomModule
addPhantomModule :: (ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule mod_text :: ModuleName -> ModuleName
mod_text =
    do PhantomModule
pm <- m PhantomModule
forall (m :: * -> *). MonadInterpreter m => m PhantomModule
newPhantomModule
       let t :: Target
t = ModuleName -> Target
fileTarget (PhantomModule -> ModuleName
pmFile PhantomModule
pm)
           m :: ModuleName
m = ModuleName -> ModuleName
GHC.mkModuleName (PhantomModule -> ModuleName
pmName PhantomModule
pm)
       --
       IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> IO ()
writeFile (PhantomModule -> ModuleName
pmFile PhantomModule
pm) (ModuleName -> ModuleName
mod_text (ModuleName -> ModuleName) -> ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ PhantomModule -> ModuleName
pmName PhantomModule
pm)
       --
       (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{activePhantoms :: [PhantomModule]
activePhantoms = PhantomModule
pmPhantomModule -> [PhantomModule] -> [PhantomModule]
forall a. a -> [a] -> [a]
:InterpreterState -> [PhantomModule]
activePhantoms InterpreterState
s})
       m (Maybe ()) -> m ()
forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail (do -- GHC.load will remove all the modules from scope, so first
                   -- we save the context...
                   (old_top :: [Module]
old_top, old_imps :: [ImportDecl GhcPs]
old_imps) <- RunGhc m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
                   --
                   RunGhc1 m Target ()
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
Target -> GhcT n ()
forall (m :: * -> *). GhcMonad m => Target -> m ()
GHC.addTarget Target
t
                   SuccessFlag
res <- RunGhc1 m LoadHowMuch SuccessFlag
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
LoadHowMuch -> GhcT n SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load (ModuleName -> LoadHowMuch
GHC.LoadUpTo ModuleName
m)
                   --
                   if SuccessFlag -> Bool
isSucceeded SuccessFlag
res
                     then do RunGhc2 m [Module] [ImportDecl GhcPs] ()
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Module] -> [ImportDecl GhcPs] -> GhcT n ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
old_top [ImportDecl GhcPs]
old_imps
                             Maybe () -> m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> m (Maybe ())) -> Maybe () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()
                     else Maybe () -> m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing)
        m () -> (InterpreterError -> m ()) -> m ()
forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
`catchIE` (\err :: InterpreterError
err -> case InterpreterError
err of
                             WontCompile _ -> do PhantomModule -> m ()
forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule PhantomModule
pm
                                                 InterpreterError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
err
                             _             -> InterpreterError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
err)
       --
       PhantomModule -> m PhantomModule
forall (m :: * -> *) a. Monad m => a -> m a
return PhantomModule
pm

removePhantomModule :: forall m. MonadInterpreter m => PhantomModule -> m ()
removePhantomModule :: PhantomModule -> m ()
removePhantomModule pm :: PhantomModule
pm =
    do -- We don't want to actually unload this module, because that
       -- would mean that all the real modules might get reloaded and the
       -- user didn't require that (they may be in a non-compiling state!).
       -- However, this means that we can't actually delete the file, because
       -- it is an active target. Therefore, we simply take it out of scope
       -- and mark it as "delete me when possible" (i.e., next time the
       -- @loadModules@ function is called).
       --
       Bool
isLoaded <- ModuleName -> m Bool
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
moduleIsLoaded (ModuleName -> m Bool) -> ModuleName -> m Bool
forall a b. (a -> b) -> a -> b
$ PhantomModule -> ModuleName
pmName PhantomModule
pm
       Bool
safeToRemove <-
           if Bool
isLoaded
             then do -- take it out of scope
                     Module
mod <- ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (PhantomModule -> ModuleName
pmName PhantomModule
pm)
                     (mods :: [Module]
mods, imps :: [ImportDecl GhcPs]
imps) <- RunGhc m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
                     let mods' :: [Module]
mods' = (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter (Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
/=) [Module]
mods
                     RunGhc2 m [Module] [ImportDecl GhcPs] ()
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Module] -> [ImportDecl GhcPs] -> GhcT n ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
mods' [ImportDecl GhcPs]
imps
                     --
                     let isNotPhantom :: GHC.Module -> m Bool
                         isNotPhantom :: Module -> m Bool
isNotPhantom mod' :: Module
mod' = do
                           Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName -> m Bool
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
isPhantomModule (Module -> ModuleName
moduleToString Module
mod')
                     [Module] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Module] -> Bool) -> m [Module] -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Module -> m Bool) -> [Module] -> m [Module]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Module -> m Bool
isNotPhantom [Module]
mods'
             else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       --
       let file_name :: ModuleName
file_name = PhantomModule -> ModuleName
pmFile PhantomModule
pm
       RunGhc1 m TargetId ()
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
TargetId -> GhcT n ()
forall (m :: * -> *). GhcMonad m => TargetId -> m ()
GHC.removeTarget (Target -> TargetId
GHC.targetId (Target -> TargetId) -> Target -> TargetId
forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
fileTarget ModuleName
file_name)
       --
       (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{activePhantoms :: [PhantomModule]
activePhantoms = (PhantomModule -> Bool) -> [PhantomModule] -> [PhantomModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (PhantomModule
pm PhantomModule -> PhantomModule -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([PhantomModule] -> [PhantomModule])
-> [PhantomModule] -> [PhantomModule]
forall a b. (a -> b) -> a -> b
$ InterpreterState -> [PhantomModule]
activePhantoms InterpreterState
s})
       --
       if Bool
safeToRemove
         then m (Maybe ()) -> m ()
forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail (m (Maybe ()) -> m ()) -> m (Maybe ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do SuccessFlag
res <- RunGhc1 m LoadHowMuch SuccessFlag
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
LoadHowMuch -> GhcT n SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets
                           Maybe () -> m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> m (Maybe ())) -> Maybe () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SuccessFlag -> Bool
isSucceeded SuccessFlag
res) Maybe () -> Maybe () -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Maybe ()
forall a. a -> Maybe a
Just ()
              m (Maybe ()) -> m () -> m (Maybe ())
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> IO ()
removeFile (PhantomModule -> ModuleName
pmFile PhantomModule
pm)
         else (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{zombiePhantoms :: [PhantomModule]
zombiePhantoms = PhantomModule
pmPhantomModule -> [PhantomModule] -> [PhantomModule]
forall a. a -> [a] -> [a]
:InterpreterState -> [PhantomModule]
zombiePhantoms InterpreterState
s})

-- Returns a tuple with the active and zombie phantom modules respectively
getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule])
getPhantomModules :: m ([PhantomModule], [PhantomModule])
getPhantomModules = do [PhantomModule]
active <- (InterpreterState -> [PhantomModule]) -> m [PhantomModule]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
activePhantoms
                       [PhantomModule]
zombie <- (InterpreterState -> [PhantomModule]) -> m [PhantomModule]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
zombiePhantoms
                       ([PhantomModule], [PhantomModule])
-> m ([PhantomModule], [PhantomModule])
forall (m :: * -> *) a. Monad m => a -> m a
return ([PhantomModule]
active, [PhantomModule]
zombie)

isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool
isPhantomModule :: ModuleName -> m Bool
isPhantomModule mn :: ModuleName
mn = do (as :: [PhantomModule]
as,zs :: [PhantomModule]
zs) <- m ([PhantomModule], [PhantomModule])
forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules
                        Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ModuleName
mn ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (PhantomModule -> ModuleName) -> [PhantomModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map PhantomModule -> ModuleName
pmName ([PhantomModule]
as [PhantomModule] -> [PhantomModule] -> [PhantomModule]
forall a. [a] -> [a] -> [a]
++ [PhantomModule]
zs)

-- | Tries to load all the requested modules from their source file.
--   Modules my be indicated by their ModuleName (e.g. \"My.Module\") or
--   by the full path to its source file.
--
-- The interpreter is 'reset' both before loading the modules and in the event
-- of an error.
--
-- /IMPORTANT/: Like in a ghci session, this will also load (and interpret)
--  any dependency that is not available via an installed package. Make
--  sure that you are not loading any module that is also being used to
--  compile your application.  In particular, you need to avoid modules
--  that define types that will later occur in an expression that you will
--  want to interpret.
--
-- The problem in doing this is that those types will have two incompatible
-- representations at runtime: 1) the one in the compiled code and 2) the
-- one in the interpreted code. When interpreting such an expression (bringing
-- it to program-code) you will likely get a segmentation fault, since the
-- latter representation will be used where the program assumes the former.
--
-- The rule of thumb is: never make the interpreter run on the directory
-- with the source code of your program! If you want your interpreted code to
-- use some type that is defined in your program, then put the defining module
-- on a library and make your program depend on that package.
loadModules :: MonadInterpreter m => [String] -> m ()
loadModules :: [ModuleName] -> m ()
loadModules fs :: [ModuleName]
fs = do -- first, unload everything, and do some clean-up
                    m ()
forall (m :: * -> *). MonadInterpreter m => m ()
reset
                    [ModuleName] -> m ()
forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
doLoad [ModuleName]
fs m () -> (InterpreterError -> m ()) -> m ()
forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
`catchIE` (\e :: InterpreterError
e -> m ()
forall (m :: * -> *). MonadInterpreter m => m ()
reset m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InterpreterError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
e)

doLoad :: MonadInterpreter m => [String] -> m ()
doLoad :: [ModuleName] -> m ()
doLoad fs :: [ModuleName]
fs = m (Maybe ()) -> m ()
forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail (m (Maybe ()) -> m ()) -> m (Maybe ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
                   [Target]
targets <- (ModuleName -> m Target) -> [ModuleName] -> m [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\f :: ModuleName
f->RunGhc2 m ModuleName (Maybe Phase) Target
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
ModuleName -> Maybe Phase -> GhcT n Target
forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe Phase -> m Target
GHC.guessTarget ModuleName
f Maybe Phase
forall a. Maybe a
Nothing) [ModuleName]
fs
                   --
                   RunGhc1 m [Target] ()
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Target] -> GhcT n ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets
                   SuccessFlag
res <- RunGhc1 m LoadHowMuch SuccessFlag
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
LoadHowMuch -> GhcT n SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets
                   -- loading the targets removes the support module
                   m ()
forall (m :: * -> *). MonadInterpreter m => m ()
reinstallSupportModule
                   Maybe () -> m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> m (Maybe ())) -> Maybe () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SuccessFlag -> Bool
isSucceeded SuccessFlag
res) Maybe () -> Maybe () -> Maybe ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Maybe ()
forall a. a -> Maybe a
Just ()

-- | Returns True if the module was interpreted.
isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool
isModuleInterpreted :: ModuleName -> m Bool
isModuleInterpreted moduleName :: ModuleName
moduleName = do
  Module
mod <- ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule ModuleName
moduleName
  RunGhc1 m Module Bool
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
Module -> GhcT n Bool
forall (m :: * -> *). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
mod

-- | Returns the list of modules loaded with 'loadModules'.
getLoadedModules :: MonadInterpreter m => m [ModuleName]
getLoadedModules :: m [ModuleName]
getLoadedModules = do (active_pms :: [PhantomModule]
active_pms, zombie_pms :: [PhantomModule]
zombie_pms) <- m ([PhantomModule], [PhantomModule])
forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules
                      [ModuleName]
ms <- (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
modNameFromSummary ([ModSummary] -> [ModuleName]) -> m [ModSummary] -> m [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [ModSummary]
forall (m :: * -> *). MonadInterpreter m => m [ModSummary]
getLoadedModSummaries
                      [ModuleName] -> m [ModuleName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleName] -> m [ModuleName]) -> [ModuleName] -> m [ModuleName]
forall a b. (a -> b) -> a -> b
$ [ModuleName]
ms [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a] -> [a]
\\ (PhantomModule -> ModuleName) -> [PhantomModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map PhantomModule -> ModuleName
pmName ([PhantomModule]
active_pms [PhantomModule] -> [PhantomModule] -> [PhantomModule]
forall a. [a] -> [a] -> [a]
++ [PhantomModule]
zombie_pms)

modNameFromSummary :: GHC.ModSummary -> ModuleName
modNameFromSummary :: ModSummary -> ModuleName
modNameFromSummary = Module -> ModuleName
moduleToString (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
GHC.ms_mod

getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary]
getLoadedModSummaries :: m [ModSummary]
getLoadedModSummaries = do
    ModuleGraph
modGraph <- RunGhc m ModuleGraph
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
    let modSummaries :: [ModSummary]
modSummaries = ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
modGraph
    (ModSummary -> m Bool) -> [ModSummary] -> m [ModSummary]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (RunGhc1 m ModuleName Bool
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
ModuleName -> GhcT n Bool
forall (m :: * -> *). GhcMonad m => ModuleName -> m Bool
GHC.isLoaded (ModuleName -> m Bool)
-> (ModSummary -> ModuleName) -> ModSummary -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModuleName
GHC.ms_mod_name) [ModSummary]
modSummaries

-- | Sets the modules whose context is used during evaluation. All bindings
--   of these modules are in scope, not only those exported.
--
--   Modules must be interpreted to use this function.
setTopLevelModules :: MonadInterpreter m => [ModuleName] -> m ()
setTopLevelModules :: [ModuleName] -> m ()
setTopLevelModules ms :: [ModuleName]
ms =
    do [ModSummary]
loaded_mods_ghc <- m [ModSummary]
forall (m :: * -> *). MonadInterpreter m => m [ModSummary]
getLoadedModSummaries
       --
       let not_loaded :: [ModuleName]
not_loaded = [ModuleName]
ms [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a] -> [a]
\\ (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
modNameFromSummary [ModSummary]
loaded_mods_ghc
       Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
not_loaded) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
         InterpreterError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> m ()) -> InterpreterError -> m ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> InterpreterError
NotAllowed ("These modules have not been loaded:\n" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++
                              [ModuleName] -> ModuleName
unlines [ModuleName]
not_loaded)
       --
       [PhantomModule]
active_pms <- (InterpreterState -> [PhantomModule]) -> m [PhantomModule]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
activePhantoms
       [Module]
ms_mods <- (ModuleName -> m Module) -> [ModuleName] -> m [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule ([ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ [ModuleName]
ms [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ (PhantomModule -> ModuleName) -> [PhantomModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map PhantomModule -> ModuleName
pmName [PhantomModule]
active_pms)
       --
       let mod_is_interpr :: Module -> m Bool
mod_is_interpr = RunGhc1 m Module Bool
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
Module -> GhcT n Bool
forall (m :: * -> *). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted
       [Module]
not_interpreted <- (Module -> m Bool) -> [Module] -> m [Module]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (m Bool -> m Bool) -> (Module -> m Bool) -> Module -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> m Bool
mod_is_interpr) [Module]
ms_mods
       Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Module] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Module]
not_interpreted) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
         InterpreterError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InterpreterError -> m ()) -> InterpreterError -> m ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> InterpreterError
NotAllowed ("These modules are not interpreted:\n" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++
                              [ModuleName] -> ModuleName
unlines ((Module -> ModuleName) -> [Module] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Module -> ModuleName
moduleToString [Module]
not_interpreted))
       --
       (_, old_imports :: [ImportDecl GhcPs]
old_imports) <- RunGhc m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
       RunGhc2 m [Module] [ImportDecl GhcPs] ()
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Module] -> [ImportDecl GhcPs] -> GhcT n ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
ms_mods [ImportDecl GhcPs]
old_imports

-- | Sets the modules whose exports must be in context.
--
--   Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive.
--   If you have a list of modules to be used qualified and another list
--   unqualified, then you need to do something like
--
--   >  setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds)
setImports :: MonadInterpreter m => [ModuleName] -> m ()
setImports :: [ModuleName] -> m ()
setImports ms :: [ModuleName]
ms = [ModuleImport] -> m ()
forall (m :: * -> *). MonadInterpreter m => [ModuleImport] -> m ()
setImportsF ([ModuleImport] -> m ()) -> [ModuleImport] -> m ()
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ModuleImport) -> [ModuleName] -> [ModuleImport]
forall a b. (a -> b) -> [a] -> [b]
map (\m :: ModuleName
m -> ModuleName -> ModuleQualification -> ImportList -> ModuleImport
ModuleImport ModuleName
m ModuleQualification
NotQualified ImportList
NoImportList) [ModuleName]
ms

-- | Sets the modules whose exports must be in context; some
--   of them may be qualified. E.g.:
--
--   @setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")]@.
--
--   Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map.
setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m ()
setImportsQ :: [(ModuleName, Maybe ModuleName)] -> m ()
setImportsQ ms :: [(ModuleName, Maybe ModuleName)]
ms = [ModuleImport] -> m ()
forall (m :: * -> *). MonadInterpreter m => [ModuleImport] -> m ()
setImportsF ([ModuleImport] -> m ()) -> [ModuleImport] -> m ()
forall a b. (a -> b) -> a -> b
$ ((ModuleName, Maybe ModuleName) -> ModuleImport)
-> [(ModuleName, Maybe ModuleName)] -> [ModuleImport]
forall a b. (a -> b) -> [a] -> [b]
map (\(m :: ModuleName
m,q :: Maybe ModuleName
q) -> ModuleName -> ModuleQualification -> ImportList -> ModuleImport
ModuleImport ModuleName
m (ModuleQualification
-> (ModuleName -> ModuleQualification)
-> Maybe ModuleName
-> ModuleQualification
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ModuleQualification
NotQualified (Maybe ModuleName -> ModuleQualification
QualifiedAs (Maybe ModuleName -> ModuleQualification)
-> (ModuleName -> Maybe ModuleName)
-> ModuleName
-> ModuleQualification
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just) Maybe ModuleName
q) ImportList
NoImportList) [(ModuleName, Maybe ModuleName)]
ms

-- | Sets the modules whose exports must be in context; some
--   may be qualified or have imports lists. E.g.:
--
--   @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@

setImportsF :: MonadInterpreter m => [ModuleImport] -> m ()
setImportsF :: [ModuleImport] -> m ()
setImportsF moduleImports :: [ModuleImport]
moduleImports = do
       [Module]
regularMods <- (ModuleImport -> m Module) -> [ModuleImport] -> m [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (ModuleName -> m Module)
-> (ModuleImport -> ModuleName) -> ModuleImport -> m Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleImport -> ModuleName
modName) [ModuleImport]
regularImports
       (ModuleImport -> m Module) -> [ModuleImport] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (ModuleName -> m Module)
-> (ModuleImport -> ModuleName) -> ModuleImport -> m Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleImport -> ModuleName
modName) [ModuleImport]
phantomImports -- just to be sure they exist
       --
       Maybe PhantomModule
old_qual_hack_mod <- (InterpreterState -> Maybe PhantomModule)
-> m (Maybe PhantomModule)
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe PhantomModule
importQualHackMod
       m () -> (PhantomModule -> m ()) -> Maybe PhantomModule -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) PhantomModule -> m ()
forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule Maybe PhantomModule
old_qual_hack_mod
       --
       Maybe PhantomModule
maybe_phantom_module <- do
         if [ModuleImport] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleImport]
phantomImports
           then Maybe PhantomModule -> m (Maybe PhantomModule)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PhantomModule
forall a. Maybe a
Nothing
           else do
             let moduleContents :: [ModuleName]
moduleContents = (ModuleImport -> ModuleName) -> [ModuleImport] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleImport -> ModuleName
newImportLine [ModuleImport]
phantomImports
             PhantomModule
new_phantom_module <- (ModuleName -> ModuleName) -> m PhantomModule
forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule ((ModuleName -> ModuleName) -> m PhantomModule)
-> (ModuleName -> ModuleName) -> m PhantomModule
forall a b. (a -> b) -> a -> b
$ \mod_name :: ModuleName
mod_name
               -> [ModuleName] -> ModuleName
unlines ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ ("module " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " where ")
                          ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
moduleContents
             (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{importQualHackMod :: Maybe PhantomModule
importQualHackMod = PhantomModule -> Maybe PhantomModule
forall a. a -> Maybe a
Just PhantomModule
new_phantom_module})
             Maybe PhantomModule -> m (Maybe PhantomModule)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PhantomModule -> m (Maybe PhantomModule))
-> Maybe PhantomModule -> m (Maybe PhantomModule)
forall a b. (a -> b) -> a -> b
$ PhantomModule -> Maybe PhantomModule
forall a. a -> Maybe a
Just PhantomModule
new_phantom_module
       --
       [Module]
phantom_mods <- case Maybe PhantomModule
maybe_phantom_module of
         Nothing -> do
           [Module] -> m [Module]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
         Just phantom_module :: PhantomModule
phantom_module-> do
           Module
phantom_mod <- ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (PhantomModule -> ModuleName
pmName PhantomModule
phantom_module)
           [Module] -> m [Module]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Module
phantom_mod]
       (old_top_level :: [Module]
old_top_level, _) <- RunGhc m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
GhcT n ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
       let new_top_level :: [Module]
new_top_level = [Module]
phantom_mods [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
old_top_level
       RunGhc2 m [Module] [Module] ()
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Module] -> [Module] -> GhcT n ()
forall (m :: * -> *). GhcMonad m => [Module] -> [Module] -> m ()
setContextModules [Module]
new_top_level [Module]
regularMods
       --
       (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s ->InterpreterState
s{qualImports :: [ModuleImport]
qualImports = [ModuleImport]
phantomImports})
  where
    (regularImports :: [ModuleImport]
regularImports, phantomImports :: [ModuleImport]
phantomImports) = [Either ModuleImport ModuleImport]
-> ([ModuleImport], [ModuleImport])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
                                     ([Either ModuleImport ModuleImport]
 -> ([ModuleImport], [ModuleImport]))
-> [Either ModuleImport ModuleImport]
-> ([ModuleImport], [ModuleImport])
forall a b. (a -> b) -> a -> b
$ (ModuleImport -> Either ModuleImport ModuleImport)
-> [ModuleImport] -> [Either ModuleImport ModuleImport]
forall a b. (a -> b) -> [a] -> [b]
map (\m :: ModuleImport
m -> if ModuleImport -> Bool
isQualified ModuleImport
m Bool -> Bool -> Bool
|| ModuleImport -> Bool
hasImportList ModuleImport
m
                                                  then ModuleImport -> Either ModuleImport ModuleImport
forall a b. b -> Either a b
Right ModuleImport
m  -- phantom
                                                  else ModuleImport -> Either ModuleImport ModuleImport
forall a b. a -> Either a b
Left ModuleImport
m)
                                           [ModuleImport]
moduleImports
    isQualified :: ModuleImport -> Bool
isQualified m :: ModuleImport
m = ModuleImport -> ModuleQualification
modQual ModuleImport
m ModuleQualification -> ModuleQualification -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleQualification
NotQualified
    hasImportList :: ModuleImport -> Bool
hasImportList m :: ModuleImport
m = ModuleImport -> ImportList
modImp ModuleImport
m ImportList -> ImportList -> Bool
forall a. Eq a => a -> a -> Bool
/= ImportList
NoImportList
    newImportLine :: ModuleImport -> ModuleName
newImportLine m :: ModuleImport
m = [ModuleName] -> ModuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["import ", case ModuleImport -> ModuleQualification
modQual ModuleImport
m of
                                            NotQualified -> ModuleImport -> ModuleName
modName ModuleImport
m
                                            ImportAs q :: ModuleName
q -> ModuleImport -> ModuleName
modName ModuleImport
m ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " as " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
q
                                            QualifiedAs Nothing -> "qualified " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleImport -> ModuleName
modName ModuleImport
m
                                            QualifiedAs (Just q :: ModuleName
q) -> "qualified " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleImport -> ModuleName
modName ModuleImport
m ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " as " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
q
                             ,case ModuleImport -> ImportList
modImp ModuleImport
m of
                                 NoImportList -> ""
                                 ImportList l :: [ModuleName]
l -> " (" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName -> [ModuleName] -> ModuleName
forall a. [a] -> [[a]] -> [a]
intercalate "," [ModuleName]
l ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ")"
                                 HidingList l :: [ModuleName]
l -> " hiding (" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName -> [ModuleName] -> ModuleName
forall a. [a] -> [[a]] -> [a]
intercalate "," [ModuleName]
l ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ")"
                             ]

-- | 'cleanPhantomModules' works like 'reset', but skips the
--   loading of the support module that installs '_show'. Its purpose
--   is to clean up all temporary files generated for phantom modules.
cleanPhantomModules :: MonadInterpreter m => m ()
cleanPhantomModules :: m ()
cleanPhantomModules =
    do -- Remove all modules from context
       RunGhc2 m [Module] [ImportDecl GhcPs] ()
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Module] -> [ImportDecl GhcPs] -> GhcT n ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [] []
       --
       -- Unload all previously loaded modules
       RunGhc1 m [Target] ()
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Target] -> GhcT n ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets []
       SuccessFlag
_ <- RunGhc1 m LoadHowMuch SuccessFlag
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
LoadHowMuch -> GhcT n SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets
       --
       -- At this point, GHCi would call rts_revertCAFs and
       -- reset the buffering of stdin, stdout and stderr.
       -- Should we do any of these?
       --
       -- liftIO $ rts_revertCAFs
       --
       -- We now remove every phantom module and forget about qual imports
       [PhantomModule]
old_active <- (InterpreterState -> [PhantomModule]) -> m [PhantomModule]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
activePhantoms
       [PhantomModule]
old_zombie <- (InterpreterState -> [PhantomModule]) -> m [PhantomModule]
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
zombiePhantoms
       (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{activePhantoms :: [PhantomModule]
activePhantoms      = [],
                        zombiePhantoms :: [PhantomModule]
zombiePhantoms      = [],
                        importQualHackMod :: Maybe PhantomModule
importQualHackMod = Maybe PhantomModule
forall a. Maybe a
Nothing,
                        qualImports :: [ModuleImport]
qualImports         = []})
       IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (PhantomModule -> IO ()) -> [PhantomModule] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName -> IO ()
removeFile (ModuleName -> IO ())
-> (PhantomModule -> ModuleName) -> PhantomModule -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhantomModule -> ModuleName
pmFile) ([PhantomModule]
old_active [PhantomModule] -> [PhantomModule] -> [PhantomModule]
forall a. [a] -> [a] -> [a]
++ [PhantomModule]
old_zombie)

       Maybe ModuleName
old_phantomdir <- (InterpreterState -> Maybe ModuleName) -> m (Maybe ModuleName)
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe ModuleName
phantomDirectory
       (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\s :: InterpreterState
s -> InterpreterState
s{phantomDirectory :: Maybe ModuleName
phantomDirectory    = Maybe ModuleName
forall a. Maybe a
Nothing})
       IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do IO () -> (ModuleName -> IO ()) -> Maybe ModuleName -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ModuleName -> IO ()
removeDirectory Maybe ModuleName
old_phantomdir

-- | All imported modules are cleared from the context, and
--   loaded modules are unloaded. It is similar to a @:load@ in
--   GHCi, but observe that not even the Prelude will be in
--   context after a reset.
reset :: MonadInterpreter m => m ()
reset :: m ()
reset = do -- clean up context
           m ()
forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules
           --
           -- Now, install a support module
           m ()
forall (m :: * -> *). MonadInterpreter m => m ()
installSupportModule

-- Load a phantom module with all the symbols from the prelude we need
installSupportModule :: MonadInterpreter m => m ()
installSupportModule :: m ()
installSupportModule = do PhantomModule
mod <- (ModuleName -> ModuleName) -> m PhantomModule
forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule ModuleName -> ModuleName
support_module
                          (InterpreterState -> InterpreterState) -> m ()
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\st :: InterpreterState
st -> InterpreterState
st{hintSupportModule :: PhantomModule
hintSupportModule = PhantomModule
mod})
                          Module
mod' <- ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (PhantomModule -> ModuleName
pmName PhantomModule
mod)
                          RunGhc2 m [Module] [ImportDecl GhcPs] ()
forall (m :: * -> *) a b c. MonadInterpreter m => RunGhc2 m a b c
runGhc2 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
[Module] -> [ImportDecl GhcPs] -> GhcT n ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module
mod'] []
    --
    where support_module :: ModuleName -> ModuleName
support_module m :: ModuleName
m = [ModuleName] -> ModuleName
unlines [
                               "module " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
m ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ "( ",
                               "    " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_String ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ",",
                               "    " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_show   ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ")",
                               "where",
                               "",
                               "import qualified Prelude as " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " (String, Show(show))",
                               "",
                               "type " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_String ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " = " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ".String",
                               "",
                               ModuleName
_show ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " :: " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ".Show a => a -> " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ".String",
                               ModuleName
_show ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ " = " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ".show"
                             ]
            where _String :: ModuleName
_String = ModuleName -> ModuleName
altStringName ModuleName
m
                  _show :: ModuleName
_show   = ModuleName -> ModuleName
altShowName ModuleName
m
                  _P :: ModuleName
_P      = ModuleName -> ModuleName
altPreludeName ModuleName
m

-- Call it when the support module is an active phantom module but has been
-- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets)
reinstallSupportModule :: MonadInterpreter m => m ()
reinstallSupportModule :: m ()
reinstallSupportModule = do PhantomModule
pm <- (InterpreterState -> PhantomModule) -> m PhantomModule
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> PhantomModule
hintSupportModule
                            PhantomModule -> m ()
forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule PhantomModule
pm
                            m ()
forall (m :: * -> *). MonadInterpreter m => m ()
installSupportModule

altStringName :: ModuleName -> String
altStringName :: ModuleName -> ModuleName
altStringName mod_name :: ModuleName
mod_name = "String_" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name

altShowName :: ModuleName -> String
altShowName :: ModuleName -> ModuleName
altShowName mod_name :: ModuleName
mod_name = "show_" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name

altPreludeName :: ModuleName -> String
altPreludeName :: ModuleName -> ModuleName
altPreludeName mod_name :: ModuleName
mod_name = "Prelude_" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name

supportString :: MonadInterpreter m => m String
supportString :: m ModuleName
supportString = do ModuleName
mod_name <- (InterpreterState -> ModuleName) -> m ModuleName
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState (PhantomModule -> ModuleName
pmName (PhantomModule -> ModuleName)
-> (InterpreterState -> PhantomModule)
-> InterpreterState
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterState -> PhantomModule
hintSupportModule)
                   ModuleName -> m ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> m ModuleName) -> ModuleName -> m ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> ModuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ModuleName
mod_name, ".", ModuleName -> ModuleName
altStringName ModuleName
mod_name]

supportShow :: MonadInterpreter m => m String
supportShow :: m ModuleName
supportShow = do ModuleName
mod_name <- (InterpreterState -> ModuleName) -> m ModuleName
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState (PhantomModule -> ModuleName
pmName (PhantomModule -> ModuleName)
-> (InterpreterState -> PhantomModule)
-> InterpreterState
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterState -> PhantomModule
hintSupportModule)
                 ModuleName -> m ModuleName
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> m ModuleName) -> ModuleName -> m ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> ModuleName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ModuleName
mod_name, ".", ModuleName -> ModuleName
altShowName ModuleName
mod_name]

-- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED?
-- foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()