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.Error ( catchError, throwError, liftIO )

import Hint.Base
import Hint.Util ( (>=>) ) -- compat version
import Hint.Conversions
import qualified Hint.Util   as Util
import qualified Hint.Compat as Compat

import qualified Hint.GHC as GHC

import System.Random
import System.FilePath
import System.Directory
import qualified System.IO.UTF8 as UTF8 (writeFile)

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
newPhantomModule :: MonadInterpreter m => m PhantomModule
newPhantomModule =
    do n <- liftIO randomIO
       (ls,is) <- allModulesInContext
       let nums = concat [show (abs n::Int), 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 $ UTF8.writeFile (pm_file pm) (mod_text $ pm_name pm)
       --
       onState (\s -> s{active_phantoms = pm:active_phantoms s})
       mayFail (do -- GHC.load will remove all the modules from scope, so first
                   -- we save the context...
                   (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)
        `catchError` (\err -> case err of
                                WontCompile _ -> do removePhantomModule pm
                                                    throwError err
                                _             -> throwError err)
       --
       return pm

removePhantomModule :: MonadInterpreter m => PhantomModule -> m ()
removePhantomModule 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 <- moduleIsLoaded $ pm_name pm
       safeToRemove <-
           if isLoaded
             then do -- take it out of scope
                     mod <- findModule (pm_name pm)
                     (mods, imps) <- runGhc Compat.getContext
                     let mods' = filter (mod /=) mods
                     runGhc2 Compat.setContext mods' imps
                     --
                     let isNotPhantom = isPhantomModule . fromGhcRep_  >=>
                                          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 ()

-- Returns a tuple with the active and zombie phantom modules respectively
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)

-- | 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.
--
-- The interpreter is 'reset' both before loading the modules and in the event
-- of an error.
loadModules :: MonadInterpreter m => [String] -> m ()
loadModules fs = do -- first, unload everything, and do some clean-up
                    reset
                    doLoad fs `catchError` (\e -> reset >> throwError 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
                   -- loading the targets removes the support module
                   reinstallSupportModule
                   return $ guard (isSucceeded res) >> Just ()

-- | Returns True if the module was interpreted.
isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool
isModuleInterpreted m = findModule m >>= runGhc1 GHC.moduleIsInterpreted

-- | Returns the list of modules loaded with 'loadModules'.
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 =  fromGhcRep_ . 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

-- | 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 ms =
    do loaded_mods_ghc <- getLoadedModSummaries
       --
       let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc
       when (not . null $ not_loaded) $
         throwError $ 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) $
         throwError $ NotAllowed ("These modules are not interpreted:\n" ++
                                  unlines (map fromGhcRep_ 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 `catchError` (\e -> do restore; throwError e)
       restore
       return a

-- | Sets the modules whose exports must be in context.
--
--   Warning: 'setImports' and 'setImportsQ' 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 ms = setImportsQ $ zip ms (repeat Nothing)

-- | Sets the modules whose exports must be in context; some
--   of them may be qualified. E.g.:
--
--   @setImports [("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 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 -- just to be sure they exist
       --
       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' 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 =
    do -- Remove all modules from context
       runGhc2 Compat.setContext [] []
       --
       -- Unload all previously loaded modules
       runGhc1 GHC.setTargets []
       _ <- runGhc1 GHC.load 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 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)

-- | 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 = do -- clean up context
           cleanPhantomModules
           --
           -- Now, install a support module
           installSupportModule

-- Load a phantom module with all the symbols from the prelude we need
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",
                               "",
                               "type " ++ _String ++ " = P.String",
                               "",
                               _show ++ " :: P.Show a => a -> P.String",
                               _show ++ " = P.show"
                             ]
            where _String = altStringName m
                  _show   = altShowName 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 :: 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

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]

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