module Hint.Context (
ModuleName, isModuleInterpreted,
loadModules, getLoadedModules, setTopLevelModules,
setImports, setImportsQ,
reset,
PhantomModule(..), ModuleText,
addPhantomModule, removePhantomModule, getPhantomModules,
cleanPhantomModules,
allModulesInContext, onAnEmptyContext,
support_String, support_show
)
where
import Prelude hiding ( mod )
import Data.Char
import Data.List
import Control.Monad ( liftM, filterM, when, guard )
import Control.Monad.Trans ( liftIO )
import Control.Monad.Catch
import Hint.Base
import Hint.Util ( (>=>) )
import Hint.Conversions
import qualified Hint.Util as Util
import qualified Hint.Compat as Compat
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{pm_name = mod_name, pm_file = tmp_dir </> nums}
allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])
allModulesInContext = runGhc Compat.getContextNames
addPhantomModule :: MonadInterpreter m
=> (ModuleName -> ModuleText)
-> m PhantomModule
addPhantomModule mod_text =
do pm <- newPhantomModule
let t = Compat.fileTarget (pm_file pm)
m = GHC.mkModuleName (pm_name pm)
liftIO $ writeFile (pm_file pm) (mod_text $ pm_name pm)
onState (\s -> s{active_phantoms = pm:active_phantoms s})
mayFail (do
(old_top, old_imps) <- runGhc Compat.getContext
runGhc1 GHC.addTarget t
res <- runGhc1 GHC.load (GHC.LoadUpTo m)
if isSucceeded res
then do runGhc2 Compat.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 $ pm_name pm
safeToRemove <-
if isLoaded
then do
mod <- findModule (pm_name pm)
(mods, imps) <- runGhc Compat.getContext
let mods' = filter (mod /=) mods
runGhc2 Compat.setContext mods' imps
let isNotPhantom = isPhantomModule . moduleToString >=>
return . not
null `liftM` filterM isNotPhantom mods'
else return True
let file_name = pm_file pm
runGhc1 GHC.removeTarget (Compat.targetId $ Compat.fileTarget file_name)
onState (\s -> s{active_phantoms = filter (pm /=) $ active_phantoms s})
if safeToRemove
then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets
return $ guard (isSucceeded res) >> Just ()
liftIO $ removeFile (pm_file pm)
else do onState (\s -> s{zombie_phantoms = pm:zombie_phantoms s})
return ()
getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule])
getPhantomModules = do active <- fromState active_phantoms
zombie <- fromState zombie_phantoms
return (active, zombie)
isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool
isPhantomModule mn = do (as,zs) <- getPhantomModules
return $ mn `elem` (map pm_name $ 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 = do mayFail $ do
targets <- mapM (\f->runGhc2 Compat.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 pm_name $ 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
when (not . null $ not_loaded) $
throwM $ NotAllowed ("These modules have not been loaded:\n" ++
unlines not_loaded)
active_pms <- fromState active_phantoms
ms_mods <- mapM findModule (nub $ ms ++ map pm_name active_pms)
let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted
not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods
when (not . null $ not_interpreted) $
throwM $ NotAllowed ("These modules are not interpreted:\n" ++
unlines (map moduleToString not_interpreted))
(_, old_imports) <- runGhc Compat.getContext
runGhc2 Compat.setContext ms_mods old_imports
onAnEmptyContext :: MonadInterpreter m => m a -> m a
onAnEmptyContext action =
do (old_mods, old_imps) <- runGhc Compat.getContext
runGhc2 Compat.setContext [] []
let restore = runGhc2 Compat.setContext old_mods old_imps
a <- action `catchIE` (\e -> do restore; throwM e)
restore
return a
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 import_qual_hack_mod
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{import_qual_hack_mod = Just new_pm})
return $ Just new_pm
else return Nothing
pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm
(old_top_level, _) <- runGhc Compat.getContext
let new_top_level = pm ++ old_top_level
runGhc2 Compat.setContextModules new_top_level unqual_mods
onState (\s ->s{qual_imports = quals})
cleanPhantomModules :: MonadInterpreter m => m ()
cleanPhantomModules =
do
runGhc2 Compat.setContext [] []
runGhc1 GHC.setTargets []
_ <- runGhc1 GHC.load GHC.LoadAllTargets
old_active <- fromState active_phantoms
old_zombie <- fromState zombie_phantoms
onState (\s -> s{active_phantoms = [],
zombie_phantoms = [],
import_qual_hack_mod = Nothing,
qual_imports = []})
liftIO $ mapM_ (removeFile . pm_file) (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{hint_support_module = mod})
mod' <- findModule (pm_name mod)
runGhc2 Compat.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 hint_support_module
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
support_String :: MonadInterpreter m => m String
support_String = do mod_name <- fromState (pm_name . hint_support_module)
return $ concat [mod_name, ".", altStringName mod_name]
support_show :: MonadInterpreter m => m String
support_show = do mod_name <- fromState (pm_name . hint_support_module)
return $ concat [mod_name, ".", altShowName mod_name]