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 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 :: forall (m :: * -> *). MonadInterpreter m => m PhantomModule
newPhantomModule =
    do n <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
       p <- liftIO Compat.getPID
       (ls,is) <- allModulesInContext
       let 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 = Char
'M'Char -> ModuleName -> ModuleName
forall a. a -> [a] -> [a]
:ModuleName
nums
       --
       tmp_dir <- getPhantomDirectory
       --
       return PhantomModule{pmName = mod_name, pmFile = tmp_dir </> mod_name <.> "hs"}

getPhantomDirectory :: MonadInterpreter m => m FilePath
getPhantomDirectory :: forall (m :: * -> *). MonadInterpreter m => 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 mfp <- (InterpreterState -> Maybe ModuleName) -> m (Maybe ModuleName)
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe ModuleName
phantomDirectory
       case mfp of
           Just ModuleName
fp -> ModuleName -> m ModuleName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
fp
           Maybe ModuleName
Nothing -> do tmp_dir <- IO ModuleName -> m ModuleName
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ModuleName
getTemporaryDirectory
                         fp <- liftIO $ createTempDirectory tmp_dir "hint"
                         onState (\InterpreterState
s -> InterpreterState
s{ phantomDirectory = Just fp })
                         setGhcOption $ "-i" ++ fp
                         return fp

allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])
allModulesInContext :: forall (m :: * -> *).
MonadInterpreter m =>
m ([ModuleName], [ModuleName])
allModulesInContext = RunGhc m ([ModuleName], [ModuleName])
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc GhcT n ([ModuleName], [ModuleName])
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 :: forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext = do
    ctx <- m [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
GHC.getContext
    foldM f ([], []) ctx
  where
    f :: (GHC.GhcMonad m) =>
         ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) ->
         GHC.InteractiveImport ->
         m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs])
    f :: forall (m :: * -> *).
GhcMonad m =>
([Module], [ImportDecl GhcPs])
-> InteractiveImport -> m ([Module], [ImportDecl GhcPs])
f ([Module]
ns, [ImportDecl GhcPs]
ds) InteractiveImport
i = case InteractiveImport
i of
      (GHC.IIDecl ImportDecl GhcPs
d)     -> ([Module], [ImportDecl GhcPs]) -> m ([Module], [ImportDecl GhcPs])
forall a. a -> m a
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 ModuleName
m) -> do 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; return (n : ns, 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
forall unit. GenModule unit -> ModuleName
GHC.moduleName

getContextNames :: GHC.GhcMonad m => m([String], [String])
getContextNames :: forall (m :: * -> *). GhcMonad m => m ([ModuleName], [ModuleName])
getContextNames = (([Module], [ImportDecl GhcPs]) -> ([ModuleName], [ModuleName]))
-> m ([Module], [ImportDecl GhcPs])
-> m ([ModuleName], [ModuleName])
forall a b. (a -> b) -> m a -> m b
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
forall {unit}. GenModule unit -> ModuleName
name ([Module] -> [ModuleName])
-> ([ImportDecl GhcPs] -> [ModuleName])
-> ([Module], [ImportDecl GhcPs])
-> ([ModuleName], [ModuleName])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
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
decl) m ([Module], [ImportDecl GhcPs])
forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
    where name :: GenModule unit -> ModuleName
name = ModuleName -> ModuleName
GHC.moduleNameString (ModuleName -> ModuleName)
-> (GenModule unit -> ModuleName) -> GenModule unit -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName
          decl :: ImportDecl GhcPs -> ModuleName
decl = ModuleName -> ModuleName
GHC.moduleNameString (ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
GHC.unLoc (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> ImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> XRec GhcPs ModuleName
ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
GHC.ideclName

setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m ()
setContext :: forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
ms [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 :: forall (m :: * -> *). GhcMonad m => [Module] -> [Module] -> m ()
setContextModules [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
GHC.simpleImportDecl (ModuleName -> ImportDecl GhcPs)
-> (Module -> ModuleName) -> Module -> ImportDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName)

addPhantomModule :: MonadInterpreter m
                 => (ModuleName -> ModuleText)
                 -> m PhantomModule
addPhantomModule :: forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule ModuleName -> ModuleName
mod_text =
    do pm <- m PhantomModule
forall (m :: * -> *). MonadInterpreter m => m PhantomModule
newPhantomModule
       df <- runGhc GHC.getSessionDynFlags
       let t = DynFlags -> ModuleName -> Target
GHC.fileTarget DynFlags
df (PhantomModule -> ModuleName
pmFile PhantomModule
pm)
       --
       liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm)
       --
       onState (\InterpreterState
s -> InterpreterState
s{activePhantoms = pm:activePhantoms s})
       mayFail (do -- GHC.load will remove all the modules from
                   -- scope, so first we save the context...
                   (old_top, old_imps) <- runGhc getContext
                   --
                   runGhc $ GHC.addTarget t
                   res <- runGhc $ GHC.load GHC.LoadAllTargets
                   --
                   if isSucceeded res
                     then do runGhc $ setContext old_top old_imps
                             return $ Just ()
                     else return Nothing)
        `catchIE` (\InterpreterError
err -> case InterpreterError
err of
                             WontCompile [GhcError]
_ -> do PhantomModule -> m ()
forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule PhantomModule
pm
                                                 InterpreterError -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM InterpreterError
err
                             InterpreterError
_             -> InterpreterError -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM InterpreterError
err)
       --
       return pm

removePhantomModule :: forall m. MonadInterpreter m => PhantomModule -> m ()
removePhantomModule :: forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule 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).
       --
       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
       safeToRemove <-
           if isLoaded
             then do -- take it out of scope
                     mod <- findModule (pmName pm)
                     (mods, imps) <- runGhc getContext
                     let 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
                     runGhc $ setContext mods' imps
                     --
                     let isNotPhantom :: GHC.Module -> m Bool
                         isNotPhantom 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')
                     null <$> filterM isNotPhantom mods'
             else return True
       --
       let file_name = PhantomModule -> ModuleName
pmFile PhantomModule
pm
       runGhc $ do df <- GHC.getSessionDynFlags
                   GHC.removeTarget (GHC.targetId $ GHC.fileTarget df file_name)
       --
       onState (\InterpreterState
s -> InterpreterState
s{activePhantoms = filter (pm /=) $ activePhantoms s})
       --
       if safeToRemove
         then mayFail $ do res <- runGhc $ GHC.load GHC.LoadAllTargets
                           return $ guard (isSucceeded res) >> Just ()
              `finally` do liftIO $ removeFile (pmFile pm)
         else onState (\InterpreterState
s -> InterpreterState
s{zombiePhantoms = pm:zombiePhantoms s})

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

isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool
isPhantomModule :: forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
isPhantomModule ModuleName
mn = do (as,zs) <- m ([PhantomModule], [PhantomModule])
forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules
                        return $ mn `elem` map pmName (as ++ 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. Note that in order to use code from
--   that module, you also need to call 'setImports' (to use the exported types
--   and definitions) or 'setTopLevelModules' (to also use the private types
--   and definitions).
--
-- 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 :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
loadModules [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` (\InterpreterError
e -> m ()
forall (m :: * -> *). MonadInterpreter m => m ()
reset m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InterpreterError -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM InterpreterError
e)

doLoad :: MonadInterpreter m => [String] -> m ()
doLoad :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
doLoad [ModuleName]
fs = do targets <- (ModuleName -> m Target) -> [ModuleName] -> m [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ModuleName
f->RunGhc m Target
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m Target -> RunGhc m Target
forall a b. (a -> b) -> a -> b
$ 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
               --
               reinstallSupportModule targets

-- | Returns True if the module was interpreted.
isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool
isModuleInterpreted :: forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
isModuleInterpreted ModuleName
moduleName = do
  mod <- ModuleName -> m Module
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule ModuleName
moduleName
  runGhc $ GHC.moduleIsInterpreted mod

-- | Returns the list of modules loaded with 'loadModules'.
getLoadedModules :: MonadInterpreter m => m [ModuleName]
getLoadedModules :: forall (m :: * -> *). MonadInterpreter m => m [ModuleName]
getLoadedModules = do (active_pms, zombie_pms) <- m ([PhantomModule], [PhantomModule])
forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules
                      ms <- map modNameFromSummary <$> getLoadedModSummaries
                      return $ ms \\ map pmName (active_pms ++ 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 :: forall (m :: * -> *). MonadInterpreter m => m [ModSummary]
getLoadedModSummaries = do
    modGraph <- RunGhc m ModuleGraph
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc GhcT n ModuleGraph
forall {n :: * -> *}.
(MonadIO n, MonadMask n) =>
GhcT n ModuleGraph
forall (m :: * -> *). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
    let modSummaries = ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
modGraph
    filterM (\ModSummary
modl -> RunGhc m Bool
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m Bool -> RunGhc m Bool
forall a b. (a -> b) -> a -> b
$ ModuleName -> GhcT n Bool
forall (m :: * -> *). GhcMonad m => ModuleName -> m Bool
GHC.isLoaded (ModuleName -> GhcT n Bool) -> ModuleName -> GhcT n Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
GHC.ms_mod_name ModSummary
modl) 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 :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
setTopLevelModules [ModuleName]
ms =
    do loaded_mods_ghc <- m [ModSummary]
forall (m :: * -> *). MonadInterpreter m => m [ModSummary]
getLoadedModSummaries
       --
       let 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
       unless (null not_loaded) $
         throwM $ NotAllowed ("These modules have not been loaded:\n" ++
                              unlines not_loaded)
       --
       active_pms <- fromState activePhantoms
       ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms)
       --
       let mod_is_interpr Module
modl = RunGhc m Bool
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m Bool -> RunGhc m Bool
forall a b. (a -> b) -> a -> b
$ Module -> GhcT n Bool
forall (m :: * -> *). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
modl
       not_interpreted <- filterM (fmap not . mod_is_interpr) ms_mods
       unless (null not_interpreted) $
         throwM $ NotAllowed ("These modules are not interpreted:\n" ++
                              unlines (map moduleToString not_interpreted))
       --
       (_, old_imports) <- runGhc getContext
       runGhc $ setContext ms_mods old_imports

-- | Sets the modules whose exports must be in context. These can be modules
-- previously loaded with 'loadModules', or modules from packages which hint is
-- aware of. This includes package databases specified to
-- 'unsafeRunInterpreterWithArgs' by the @-package-db=...@ parameter, and
-- packages specified by a ghc environment file created by @cabal build --write-ghc-environment-files=always@.
--
--   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 :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
setImports [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 (\ModuleName
m -> ModuleName -> ModuleQualification -> ImportList -> ModuleImport
ModuleImport ModuleName
m ModuleQualification
NotQualified ImportList
NoImportList) [ModuleName]
ms

-- | A variant of 'setImports' where modules 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 :: forall (m :: * -> *).
MonadInterpreter m =>
[(ModuleName, Maybe ModuleName)] -> m ()
setImportsQ [(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 (\(ModuleName
m,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

-- | A variant of 'setImportsQ' where modules may have an explicit import list. e.g.:
--
--   @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@

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

-- | '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 :: forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules =
    do -- Remove all modules from context
       RunGhc m ()
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m () -> RunGhc m ()
forall a b. (a -> b) -> a -> b
$ [Module] -> [ImportDecl GhcPs] -> GhcT n ()
forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [] []
       --
       -- Unload all previously loaded modules
       RunGhc m ()
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m () -> RunGhc m ()
forall a b. (a -> b) -> a -> b
$ [Target] -> GhcT n ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets []
       _ <- RunGhc m SuccessFlag
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m SuccessFlag -> RunGhc m SuccessFlag
forall a b. (a -> b) -> a -> b
$ LoadHowMuch -> GhcT n SuccessFlag
forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f 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
       old_active <- fromState activePhantoms
       old_zombie <- fromState zombiePhantoms
       onState (\InterpreterState
s -> InterpreterState
s{activePhantoms      = [],
                        zombiePhantoms      = [],
                        importQualHackMod = Nothing,
                        qualImports         = []})
       liftIO $ mapM_ (removeFile . pmFile) (old_active ++ old_zombie)

       old_phantomdir <- fromState phantomDirectory
       onState (\InterpreterState
s -> InterpreterState
s{phantomDirectory    = Nothing})
       liftIO $ do maybe (return ()) removeDirectory 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 :: forall (m :: * -> *). MonadInterpreter m => m ()
reset = do -- clean up context
           m ()
forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules
           --
           -- Now, install a support module
           [Target] -> m ()
forall (m :: * -> *). MonadInterpreter m => [Target] -> m ()
installSupportModule []

-- Load a phantom module with all the symbols from the prelude we need
installSupportModule :: MonadInterpreter m => [GHC.Target] -> m ()
installSupportModule :: forall (m :: * -> *). MonadInterpreter m => [Target] -> m ()
installSupportModule [Target]
ts = do RunGhc m ()
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m () -> RunGhc m ()
forall a b. (a -> b) -> a -> b
$ [Target] -> GhcT n ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
ts
                             mod <- (ModuleName -> ModuleName) -> m PhantomModule
forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule ModuleName -> ModuleName
support_module
                             onState (\InterpreterState
st -> InterpreterState
st{hintSupportModule = mod})
                             mod' <- findModule (pmName mod)
                             runGhc $ setContext [mod'] []
    --
    where support_module :: ModuleName -> ModuleName
support_module ModuleName
m = [ModuleName] -> ModuleName
unlines [
                               ModuleName
"module " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
m ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
"( ",
                               ModuleName
"    " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_String ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
",",
                               ModuleName
"    " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_show   ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
")",
                               ModuleName
"where",
                               ModuleName
"",
                               ModuleName
"import qualified Prelude as " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" (String, Show(show))",
                               ModuleName
"",
                               ModuleName
"type " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_String ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" = " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
".String",
                               ModuleName
"",
                               ModuleName
_show ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" :: " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
".Show a => a -> " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
".String",
                               ModuleName
_show ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" = " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
_P ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
".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 :: [GHC.Target] -> MonadInterpreter m => m ()
reinstallSupportModule :: forall (m :: * -> *). [Target] -> MonadInterpreter m => m ()
reinstallSupportModule [Target]
ts = do pm <- (InterpreterState -> PhantomModule) -> m PhantomModule
forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> PhantomModule
hintSupportModule
                               removePhantomModule pm
                               installSupportModule ts

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

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

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

supportString :: MonadInterpreter m => m String
supportString :: forall (m :: * -> *). MonadInterpreter m => m ModuleName
supportString = do 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)
                   return $ concat [mod_name, ".", altStringName mod_name]

supportShow :: MonadInterpreter m => m String
supportShow :: forall (m :: * -> *). MonadInterpreter m => m ModuleName
supportShow = do 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)
                 return $ concat [mod_name, ".", altShowName mod_name]

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