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
newPhantomModule :: MonadInterpreter m => m PhantomModule
newPhantomModule :: forall (m :: * -> *). MonadInterpreter m => m PhantomModule
newPhantomModule =
do Int
n <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
Int
p <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
Compat.getPID
([ModuleName]
ls,[ModuleName]
is) <- forall (m :: * -> *).
MonadInterpreter m =>
m ([ModuleName], [ModuleName])
allModulesInContext
let nums :: ModuleName
nums = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall a. Show a => a -> ModuleName
show (forall a. Num a => a -> a
abs Int
n::Int), forall a. Show a => a -> ModuleName
show Int
p, forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ModuleName]
ls forall a. [a] -> [a] -> [a]
++ [ModuleName]
is)]
let mod_name :: ModuleName
mod_name = Char
'M'forall a. a -> [a] -> [a]
:ModuleName
nums
ModuleName
tmp_dir <- forall (m :: * -> *). MonadInterpreter m => m ModuleName
getPhantomDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return PhantomModule{pmName :: ModuleName
pmName = ModuleName
mod_name, pmFile :: ModuleName
pmFile = ModuleName
tmp_dir ModuleName -> ModuleName -> ModuleName
</> ModuleName
mod_name ModuleName -> ModuleName -> ModuleName
<.> ModuleName
"hs"}
getPhantomDirectory :: MonadInterpreter m => m FilePath
getPhantomDirectory :: forall (m :: * -> *). MonadInterpreter m => m ModuleName
getPhantomDirectory =
do Maybe ModuleName
mfp <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe ModuleName
phantomDirectory
case Maybe ModuleName
mfp of
Just ModuleName
fp -> forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
fp
Maybe ModuleName
Nothing -> do ModuleName
tmp_dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ModuleName
getTemporaryDirectory
ModuleName
fp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> IO ModuleName
createTempDirectory ModuleName
tmp_dir ModuleName
"hint"
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{ phantomDirectory :: Maybe ModuleName
phantomDirectory = forall a. a -> Maybe a
Just ModuleName
fp })
forall (m :: * -> *). MonadInterpreter m => ModuleName -> m ()
setGhcOption forall a b. (a -> b) -> a -> b
$ ModuleName
"-i" forall a. [a] -> [a] -> [a]
++ ModuleName
fp
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleName
fp
allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])
allModulesInContext :: forall (m :: * -> *).
MonadInterpreter m =>
m ([ModuleName], [ModuleName])
allModulesInContext = forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc 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
[InteractiveImport]
ctx <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
GHC.getContext
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM 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 :: 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Module]
ns, ImportDecl GhcPs
d forall a. a -> [a] -> [a]
: [ImportDecl GhcPs]
ds)
(GHC.IIModule ModuleName
m) -> do Module
n <- forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
m forall a. Maybe a
Nothing; forall (m :: * -> *) a. Monad m => a -> m a
return (Module
n forall a. a -> [a] -> [a]
: [Module]
ns, [ImportDecl GhcPs]
ds)
modToIIMod :: GHC.Module -> GHC.InteractiveImport
modToIIMod :: Module -> InteractiveImport
modToIIMod = ModuleName -> InteractiveImport
GHC.IIModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName
getContextNames :: GHC.GhcMonad m => m([String], [String])
getContextNames :: forall (m :: * -> *). GhcMonad m => m ([ModuleName], [ModuleName])
getContextNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall {unit}. GenModule unit -> ModuleName
name forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> ModuleName
decl) forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
where name :: GenModule unit -> ModuleName
name = ModuleName -> ModuleName
GHC.moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName
decl :: ImportDecl GhcPs -> ModuleName
decl = ModuleName -> ModuleName
GHC.moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
GHC.unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' = forall a b. (a -> b) -> [a] -> [b]
map Module -> InteractiveImport
modToIIMod [Module]
ms
ds' :: [InteractiveImport]
ds' = forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> InteractiveImport
GHC.IIDecl [ImportDecl GhcPs]
ds
is :: [InteractiveImport]
is = [InteractiveImport]
ms' forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
ds'
in forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
GHC.setContext [InteractiveImport]
is
setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()
setContextModules :: forall (m :: * -> *). GhcMonad m => [Module] -> [Module] -> m ()
setContextModules [Module]
as = forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
as forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> ImportDecl GhcPs
GHC.simpleImportDecl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName)
fileTarget :: FilePath -> GHC.Target
fileTarget :: ModuleName -> Target
fileTarget ModuleName
f = TargetId -> Bool -> Maybe (InputFileBuffer, UTCTime) -> Target
GHC.Target (ModuleName -> Maybe Phase -> TargetId
GHC.TargetFile ModuleName
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Phase
next_phase) Bool
True 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 :: forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule ModuleName -> ModuleName
mod_text =
do PhantomModule
pm <- 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)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> IO ()
writeFile (PhantomModule -> ModuleName
pmFile PhantomModule
pm) (ModuleName -> ModuleName
mod_text forall a b. (a -> b) -> a -> b
$ PhantomModule -> ModuleName
pmName PhantomModule
pm)
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{activePhantoms :: [PhantomModule]
activePhantoms = PhantomModule
pmforall a. a -> [a] -> [a]
:InterpreterState -> [PhantomModule]
activePhantoms InterpreterState
s})
forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail (do
([Module]
old_top, [ImportDecl GhcPs]
old_imps) <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => Target -> m ()
GHC.addTarget Target
t
SuccessFlag
res <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load (ModuleName -> LoadHowMuch
GHC.LoadUpTo ModuleName
m)
if SuccessFlag -> Bool
isSucceeded SuccessFlag
res
then do forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
old_top [ImportDecl GhcPs]
old_imps
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ()
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
`catchIE` (\InterpreterError
err -> case InterpreterError
err of
WontCompile [GhcError]
_ -> do forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule PhantomModule
pm
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
err
InterpreterError
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
err)
forall (m :: * -> *) a. Monad m => a -> m a
return PhantomModule
pm
removePhantomModule :: forall m. MonadInterpreter m => PhantomModule -> m ()
removePhantomModule :: forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule PhantomModule
pm =
do
Bool
isLoaded <- forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
moduleIsLoaded forall a b. (a -> b) -> a -> b
$ PhantomModule -> ModuleName
pmName PhantomModule
pm
Bool
safeToRemove <-
if Bool
isLoaded
then do
Module
mod <- forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (PhantomModule -> ModuleName
pmName PhantomModule
pm)
([Module]
mods, [ImportDecl GhcPs]
imps) <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
let mods' :: [Module]
mods' = forall a. (a -> Bool) -> [a] -> [a]
filter (Module
mod forall a. Eq a => a -> a -> Bool
/=) [Module]
mods
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ 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 Module
mod' = do
Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
isPhantomModule (Module -> ModuleName
moduleToString Module
mod')
forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Module -> m Bool
isNotPhantom [Module]
mods'
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
let file_name :: ModuleName
file_name = PhantomModule -> ModuleName
pmFile PhantomModule
pm
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => TargetId -> m ()
GHC.removeTarget (Target -> TargetId
GHC.targetId forall a b. (a -> b) -> a -> b
$ ModuleName -> Target
fileTarget ModuleName
file_name)
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{activePhantoms :: [PhantomModule]
activePhantoms = forall a. (a -> Bool) -> [a] -> [a]
filter (PhantomModule
pm forall a. Eq a => a -> a -> Bool
/=) forall a b. (a -> b) -> a -> b
$ InterpreterState -> [PhantomModule]
activePhantoms InterpreterState
s})
if Bool
safeToRemove
then forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail forall a b. (a -> b) -> a -> b
$ do SuccessFlag
res <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SuccessFlag -> Bool
isSucceeded SuccessFlag
res) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ModuleName -> IO ()
removeFile (PhantomModule -> ModuleName
pmFile PhantomModule
pm)
else forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{zombiePhantoms :: [PhantomModule]
zombiePhantoms = PhantomModule
pmforall a. a -> [a] -> [a]
:InterpreterState -> [PhantomModule]
zombiePhantoms InterpreterState
s})
getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule])
getPhantomModules :: forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules = do [PhantomModule]
active <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
activePhantoms
[PhantomModule]
zombie <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
zombiePhantoms
forall (m :: * -> *) a. Monad m => a -> m a
return ([PhantomModule]
active, [PhantomModule]
zombie)
isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool
isPhantomModule :: forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
isPhantomModule ModuleName
mn = do ([PhantomModule]
as,[PhantomModule]
zs) <- forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModuleName
mn forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map PhantomModule -> ModuleName
pmName ([PhantomModule]
as forall a. [a] -> [a] -> [a]
++ [PhantomModule]
zs)
loadModules :: MonadInterpreter m => [String] -> m ()
loadModules :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
loadModules [ModuleName]
fs = do
forall (m :: * -> *). MonadInterpreter m => m ()
reset
forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
doLoad [ModuleName]
fs forall (m :: * -> *) a.
MonadInterpreter m =>
m a -> (InterpreterError -> m a) -> m a
`catchIE` (\InterpreterError
e -> forall (m :: * -> *). MonadInterpreter m => m ()
reset forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InterpreterError
e)
doLoad :: MonadInterpreter m => [String] -> m ()
doLoad :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
doLoad [ModuleName]
fs = forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail forall a b. (a -> b) -> a -> b
$ do
[Target]
targets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ModuleName
f->forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
ModuleName -> Maybe Phase -> m Target
GHC.guessTarget ModuleName
f forall a. Maybe a
Nothing) [ModuleName]
fs
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target]
targets
SuccessFlag
res <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets
forall (m :: * -> *). MonadInterpreter m => m ()
reinstallSupportModule
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SuccessFlag -> Bool
isSucceeded SuccessFlag
res) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just ()
isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool
isModuleInterpreted :: forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Bool
isModuleInterpreted ModuleName
moduleName = do
Module
mod <- forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule ModuleName
moduleName
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
mod
getLoadedModules :: MonadInterpreter m => m [ModuleName]
getLoadedModules :: forall (m :: * -> *). MonadInterpreter m => m [ModuleName]
getLoadedModules = do ([PhantomModule]
active_pms, [PhantomModule]
zombie_pms) <- forall (m :: * -> *).
MonadInterpreter m =>
m ([PhantomModule], [PhantomModule])
getPhantomModules
[ModuleName]
ms <- forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
modNameFromSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadInterpreter m => m [ModSummary]
getLoadedModSummaries
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ModuleName]
ms forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map PhantomModule -> ModuleName
pmName ([PhantomModule]
active_pms forall a. [a] -> [a] -> [a]
++ [PhantomModule]
zombie_pms)
modNameFromSummary :: GHC.ModSummary -> ModuleName
modNameFromSummary :: ModSummary -> ModuleName
modNameFromSummary = Module -> ModuleName
moduleToString 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
ModuleGraph
modGraph <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m ModuleGraph
GHC.getModuleGraph
let modSummaries :: [ModSummary]
modSummaries = ModuleGraph -> [ModSummary]
GHC.mgModSummaries ModuleGraph
modGraph
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\ModSummary
modl -> forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => ModuleName -> m Bool
GHC.isLoaded forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
GHC.ms_mod_name ModSummary
modl) [ModSummary]
modSummaries
setTopLevelModules :: MonadInterpreter m => [ModuleName] -> m ()
setTopLevelModules :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
setTopLevelModules [ModuleName]
ms =
do [ModSummary]
loaded_mods_ghc <- forall (m :: * -> *). MonadInterpreter m => m [ModSummary]
getLoadedModSummaries
let not_loaded :: [ModuleName]
not_loaded = [ModuleName]
ms forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
modNameFromSummary [ModSummary]
loaded_mods_ghc
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
not_loaded) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ ModuleName -> InterpreterError
NotAllowed (ModuleName
"These modules have not been loaded:\n" forall a. [a] -> [a] -> [a]
++
[ModuleName] -> ModuleName
unlines [ModuleName]
not_loaded)
[PhantomModule]
active_pms <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
activePhantoms
[Module]
ms_mods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [ModuleName]
ms forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map PhantomModule -> ModuleName
pmName [PhantomModule]
active_pms)
let mod_is_interpr :: Module -> m Bool
mod_is_interpr Module
modl = forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => Module -> m Bool
GHC.moduleIsInterpreted Module
modl
[Module]
not_interpreted <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *}. MonadInterpreter m => Module -> m Bool
mod_is_interpr) [Module]
ms_mods
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Module]
not_interpreted) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ ModuleName -> InterpreterError
NotAllowed (ModuleName
"These modules are not interpreted:\n" forall a. [a] -> [a] -> [a]
++
[ModuleName] -> ModuleName
unlines (forall a b. (a -> b) -> [a] -> [b]
map Module -> ModuleName
moduleToString [Module]
not_interpreted))
([Module]
_, [ImportDecl GhcPs]
old_imports) <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module]
ms_mods [ImportDecl GhcPs]
old_imports
setImports :: MonadInterpreter m => [ModuleName] -> m ()
setImports :: forall (m :: * -> *). MonadInterpreter m => [ModuleName] -> m ()
setImports [ModuleName]
ms = forall (m :: * -> *). MonadInterpreter m => [ModuleImport] -> m ()
setImportsF forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
m -> ModuleName -> ModuleQualification -> ImportList -> ModuleImport
ModuleImport ModuleName
m ModuleQualification
NotQualified ImportList
NoImportList) [ModuleName]
ms
setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m ()
setImportsQ :: forall (m :: * -> *).
MonadInterpreter m =>
[(ModuleName, Maybe ModuleName)] -> m ()
setImportsQ [(ModuleName, Maybe ModuleName)]
ms = forall (m :: * -> *). MonadInterpreter m => [ModuleImport] -> m ()
setImportsF forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
m,Maybe ModuleName
q) -> ModuleName -> ModuleQualification -> ImportList -> ModuleImport
ModuleImport ModuleName
m (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ModuleQualification
NotQualified (Maybe ModuleName -> ModuleQualification
QualifiedAs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Maybe ModuleName
q) ImportList
NoImportList) [(ModuleName, Maybe ModuleName)]
ms
setImportsF :: MonadInterpreter m => [ModuleImport] -> m ()
setImportsF :: forall (m :: * -> *). MonadInterpreter m => [ModuleImport] -> m ()
setImportsF [ModuleImport]
moduleImports = do
[Module]
regularMods <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleImport -> ModuleName
modName) [ModuleImport]
regularImports
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleImport -> ModuleName
modName) [ModuleImport]
phantomImports
Maybe PhantomModule
old_qual_hack_mod <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe PhantomModule
importQualHackMod
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule Maybe PhantomModule
old_qual_hack_mod
Maybe PhantomModule
maybe_phantom_module <- do
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleImport]
phantomImports
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
let moduleContents :: [ModuleName]
moduleContents = forall a b. (a -> b) -> [a] -> [b]
map ModuleImport -> ModuleName
newImportLine [ModuleImport]
phantomImports
PhantomModule
new_phantom_module <- forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule forall a b. (a -> b) -> a -> b
$ \ModuleName
mod_name
-> [ModuleName] -> ModuleName
unlines forall a b. (a -> b) -> a -> b
$ (ModuleName
"module " forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name forall a. [a] -> [a] -> [a]
++ ModuleName
" where ")
forall a. a -> [a] -> [a]
: [ModuleName]
moduleContents
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{importQualHackMod :: Maybe PhantomModule
importQualHackMod = forall a. a -> Maybe a
Just PhantomModule
new_phantom_module})
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just PhantomModule
new_phantom_module
[Module]
phantom_mods <- case Maybe PhantomModule
maybe_phantom_module of
Maybe PhantomModule
Nothing -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just PhantomModule
phantom_module-> do
Module
phantom_mod <- forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (PhantomModule -> ModuleName
pmName PhantomModule
phantom_module)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Module
phantom_mod]
([Module]
old_top_level, [ImportDecl GhcPs]
_) <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *).
GhcMonad m =>
m ([Module], [ImportDecl GhcPs])
getContext
let new_top_level :: [Module]
new_top_level = [Module]
phantom_mods forall a. [a] -> [a] -> [a]
++ [Module]
old_top_level
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => [Module] -> [Module] -> m ()
setContextModules [Module]
new_top_level [Module]
regularMods
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s ->InterpreterState
s{qualImports :: [ModuleImport]
qualImports = [ModuleImport]
phantomImports})
where
([ModuleImport]
regularImports, [ModuleImport]
phantomImports) = forall a b. [Either a b] -> ([a], [b])
partitionEithers
forall a b. (a -> b) -> a -> b
$ 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 forall a b. b -> Either a b
Right ModuleImport
m
else forall a b. a -> Either a b
Left ModuleImport
m)
[ModuleImport]
moduleImports
isQualified :: ModuleImport -> Bool
isQualified ModuleImport
m = ModuleImport -> ModuleQualification
modQual ModuleImport
m forall a. Eq a => a -> a -> Bool
/= ModuleQualification
NotQualified
hasImportList :: ModuleImport -> Bool
hasImportList ModuleImport
m = ModuleImport -> ImportList
modImp ModuleImport
m forall a. Eq a => a -> a -> Bool
/= ImportList
NoImportList
newImportLine :: ModuleImport -> ModuleName
newImportLine ModuleImport
m = 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 forall a. [a] -> [a] -> [a]
++ ModuleName
" as " forall a. [a] -> [a] -> [a]
++ ModuleName
q
QualifiedAs Maybe ModuleName
Nothing -> ModuleName
"qualified " forall a. [a] -> [a] -> [a]
++ ModuleImport -> ModuleName
modName ModuleImport
m
QualifiedAs (Just ModuleName
q) -> ModuleName
"qualified " forall a. [a] -> [a] -> [a]
++ ModuleImport -> ModuleName
modName ModuleImport
m forall a. [a] -> [a] -> [a]
++ ModuleName
" as " forall a. [a] -> [a] -> [a]
++ ModuleName
q
,case ModuleImport -> ImportList
modImp ModuleImport
m of
ImportList
NoImportList -> ModuleName
""
ImportList [ModuleName]
l -> ModuleName
" (" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate ModuleName
"," [ModuleName]
l forall a. [a] -> [a] -> [a]
++ ModuleName
")"
HidingList [ModuleName]
l -> ModuleName
" hiding (" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate ModuleName
"," [ModuleName]
l forall a. [a] -> [a] -> [a]
++ ModuleName
")"
]
cleanPhantomModules :: MonadInterpreter m => m ()
cleanPhantomModules :: forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules =
do
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [] []
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets []
SuccessFlag
_ <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets
[PhantomModule]
old_active <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
activePhantoms
[PhantomModule]
old_zombie <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> [PhantomModule]
zombiePhantoms
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{activePhantoms :: [PhantomModule]
activePhantoms = [],
zombiePhantoms :: [PhantomModule]
zombiePhantoms = [],
importQualHackMod :: Maybe PhantomModule
importQualHackMod = forall a. Maybe a
Nothing,
qualImports :: [ModuleImport]
qualImports = []})
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ModuleName -> IO ()
removeFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhantomModule -> ModuleName
pmFile) ([PhantomModule]
old_active forall a. [a] -> [a] -> [a]
++ [PhantomModule]
old_zombie)
Maybe ModuleName
old_phantomdir <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> Maybe ModuleName
phantomDirectory
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{phantomDirectory :: Maybe ModuleName
phantomDirectory = forall a. Maybe a
Nothing})
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) ModuleName -> IO ()
removeDirectory Maybe ModuleName
old_phantomdir
reset :: MonadInterpreter m => m ()
reset :: forall (m :: * -> *). MonadInterpreter m => m ()
reset = do
forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules
forall (m :: * -> *). MonadInterpreter m => m ()
installSupportModule
installSupportModule :: MonadInterpreter m => m ()
installSupportModule :: forall (m :: * -> *). MonadInterpreter m => m ()
installSupportModule = do PhantomModule
mod <- forall (m :: * -> *).
MonadInterpreter m =>
(ModuleName -> ModuleName) -> m PhantomModule
addPhantomModule ModuleName -> ModuleName
support_module
forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
st -> InterpreterState
st{hintSupportModule :: PhantomModule
hintSupportModule = PhantomModule
mod})
Module
mod' <- forall (m :: * -> *). MonadInterpreter m => ModuleName -> m Module
findModule (PhantomModule -> ModuleName
pmName PhantomModule
mod)
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
[Module] -> [ImportDecl GhcPs] -> m ()
setContext [Module
mod'] []
where support_module :: ModuleName -> ModuleName
support_module ModuleName
m = [ModuleName] -> ModuleName
unlines [
ModuleName
"module " forall a. [a] -> [a] -> [a]
++ ModuleName
m forall a. [a] -> [a] -> [a]
++ ModuleName
"( ",
ModuleName
" " forall a. [a] -> [a] -> [a]
++ ModuleName
_String forall a. [a] -> [a] -> [a]
++ ModuleName
",",
ModuleName
" " forall a. [a] -> [a] -> [a]
++ ModuleName
_show forall a. [a] -> [a] -> [a]
++ ModuleName
")",
ModuleName
"where",
ModuleName
"",
ModuleName
"import qualified Prelude as " forall a. [a] -> [a] -> [a]
++ ModuleName
_P forall a. [a] -> [a] -> [a]
++ ModuleName
" (String, Show(show))",
ModuleName
"",
ModuleName
"type " forall a. [a] -> [a] -> [a]
++ ModuleName
_String forall a. [a] -> [a] -> [a]
++ ModuleName
" = " forall a. [a] -> [a] -> [a]
++ ModuleName
_P forall a. [a] -> [a] -> [a]
++ ModuleName
".String",
ModuleName
"",
ModuleName
_show forall a. [a] -> [a] -> [a]
++ ModuleName
" :: " forall a. [a] -> [a] -> [a]
++ ModuleName
_P forall a. [a] -> [a] -> [a]
++ ModuleName
".Show a => a -> " forall a. [a] -> [a] -> [a]
++ ModuleName
_P forall a. [a] -> [a] -> [a]
++ ModuleName
".String",
ModuleName
_show forall a. [a] -> [a] -> [a]
++ ModuleName
" = " forall a. [a] -> [a] -> [a]
++ ModuleName
_P 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
reinstallSupportModule :: MonadInterpreter m => m ()
reinstallSupportModule :: forall (m :: * -> *). MonadInterpreter m => m ()
reinstallSupportModule = do PhantomModule
pm <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState InterpreterState -> PhantomModule
hintSupportModule
forall (m :: * -> *). MonadInterpreter m => PhantomModule -> m ()
removePhantomModule PhantomModule
pm
forall (m :: * -> *). MonadInterpreter m => m ()
installSupportModule
altStringName :: ModuleName -> String
altStringName :: ModuleName -> ModuleName
altStringName ModuleName
mod_name = ModuleName
"String_" forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name
altShowName :: ModuleName -> String
altShowName :: ModuleName -> ModuleName
altShowName ModuleName
mod_name = ModuleName
"show_" forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name
altPreludeName :: ModuleName -> String
altPreludeName :: ModuleName -> ModuleName
altPreludeName ModuleName
mod_name = ModuleName
"Prelude_" forall a. [a] -> [a] -> [a]
++ ModuleName
mod_name
supportString :: MonadInterpreter m => m String
supportString :: forall (m :: * -> *). MonadInterpreter m => m ModuleName
supportString = do ModuleName
mod_name <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState (PhantomModule -> ModuleName
pmName forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterState -> PhantomModule
hintSupportModule)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ModuleName
mod_name, ModuleName
".", ModuleName -> ModuleName
altStringName ModuleName
mod_name]
supportShow :: MonadInterpreter m => m String
supportShow :: forall (m :: * -> *). MonadInterpreter m => m ModuleName
supportShow = do ModuleName
mod_name <- forall (m :: * -> *) a.
MonadInterpreter m =>
(InterpreterState -> a) -> m a
fromState (PhantomModule -> ModuleName
pmName forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterState -> PhantomModule
hintSupportModule)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ModuleName
mod_name, ModuleName
".", ModuleName -> ModuleName
altShowName ModuleName
mod_name]