module Hint.Context (
isModuleInterpreted,
loadModules, getLoadedModules, setTopLevelModules,
setImports, setImportsQ,
reset,
PhantomModule(..),
cleanPhantomModules,
supportString, supportShow
) where
import Prelude hiding (mod)
import Data.Char
import Data.List
import Control.Arrow ((***))
import Control.Monad (liftM, filterM, unless, guard, foldM, (>=>))
import Control.Monad.Trans (liftIO)
import Control.Monad.Catch
import Hint.Base
import Hint.Conversions
import qualified Hint.Util as Util
import qualified Hint.CompatPlatform as Compat
import qualified Hint.GHC as GHC
import System.Random
import System.FilePath
import System.Directory
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 <- liftIO getTemporaryDirectory
return PhantomModule{pmName = mod_name, pmFile = tmp_dir </> nums}
allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])
allModulesInContext = runGhc getContextNames
getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.RdrName])
getContext = GHC.getContext >>= foldM f ([], [])
where
f :: (GHC.GhcMonad m) =>
([GHC.Module], [GHC.ImportDecl GHC.RdrName]) ->
GHC.InteractiveImport ->
m ([GHC.Module], [GHC.ImportDecl GHC.RdrName])
f (ns, ds) i = case i of
(GHC.IIDecl d) -> return (ns, d : ds)
m@(GHC.IIModule _) -> do n <- iiModToMod m; return (n : ns, ds)
modToIIMod :: GHC.Module -> GHC.InteractiveImport
modToIIMod = GHC.IIModule . GHC.moduleName
iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module
iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing
iiModToMod _ = error "iiModToMod!"
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.RdrName] -> 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 :: 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 = isPhantomModule . moduleToString >=>
return . not
null `liftM` 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 do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets
return $ guard (isSucceeded res) >> Just ()
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 m = findModule m >>= runGhc1 GHC.moduleIsInterpreted
getLoadedModules :: MonadInterpreter m => m [ModuleName]
getLoadedModules = do (active_pms, zombie_pms) <- getPhantomModules
ms <- map modNameFromSummary `liftM` 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 all_mod_summ <- runGhc GHC.getModuleGraph
filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) all_mod_summ
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 (liftM 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 = setImportsQ $ zip ms (repeat Nothing)
setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m ()
setImportsQ ms =
do let qualOrNot (a, mb) = maybe (Right a) (Left . (,) a) mb
(quals, unquals) = Util.partitionEither $ map qualOrNot ms
unqual_mods <- mapM findModule unquals
mapM_ (findModule . fst) quals
old_qual_hack_mod <- fromState importQualHackMod
maybe (return ()) removePhantomModule old_qual_hack_mod
new_pm <- if not $ null quals
then do
new_pm <- addPhantomModule $ \mod_name -> unlines $
("module " ++ mod_name ++ " where ") :
["import qualified " ++ m ++ " as " ++ n |
(m,n) <- quals]
onState (\s -> s{importQualHackMod = Just new_pm})
return $ Just new_pm
else return Nothing
pm <- maybe (return []) (findModule . pmName >=> return . return) new_pm
(old_top_level, _) <- runGhc getContext
let new_top_level = pm ++ old_top_level
runGhc2 setContextModules new_top_level unqual_mods
onState (\s ->s{qualImports = quals})
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)
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]