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