From: Simon Marlow Date: Fri, 3 Jun 2011 23:13:04 +0000 (+0100) Subject: Tidy up the ic_exports field of the InteractiveContext. Previously X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5cd39aa33f970ff42e22b1c9c73502e4229dc488 Tidy up the ic_exports field of the InteractiveContext. Previously was [(Module, Maybe ImportDecl)], now it is just [ImportDecl]. So now ":m +A" and "import A" do exactly the same thing in GHCi, and use the same code paths. --- diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 5015999..176182e 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -15,7 +15,7 @@ import HsDoc ( HsDocString ) import Outputable import FastString -import SrcLoc ( Located(..) ) +import SrcLoc ( Located(..), noLoc ) import Data.Data \end{code} @@ -40,6 +40,16 @@ data ImportDecl name ideclAs :: Maybe ModuleName, -- ^ as Module ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) } deriving (Data, Typeable) + +simpleImportDecl :: ModuleName -> ImportDecl name +simpleImportDecl mn = ImportDecl { + ideclName = noLoc mn, + ideclPkgQual = Nothing, + ideclSource = False, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing + } \end{code} \begin{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 22aa3f4..77e69fd 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -863,37 +863,47 @@ emptyModIface mod %************************************************************************ \begin{code} --- | Interactive context, recording information relevant to GHCi +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHC session. +-- data InteractiveContext = InteractiveContext { - ic_toplev_scope :: [Module] -- ^ The context includes the "top-level" scope of - -- these modules - - , ic_exports :: [(Module, Maybe (ImportDecl RdrName))] -- ^ The context includes just the exported parts of these - -- modules - - , ic_rn_gbl_env :: GlobalRdrEnv -- ^ The contexts' cached 'GlobalRdrEnv', built from - -- 'ic_toplev_scope' and 'ic_exports' - - , ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user. - -- Later Ids shadow earlier ones with the same OccName - -- Expressions are typed with these Ids in the envt - -- For runtime-debugging, these Ids may have free - -- TcTyVars of RuntimUnkSkol flavour, but no free TyVars - -- (because the typechecker doesn't expect that) + -- These two fields are only stored here so that the client + -- can retrieve them with GHC.getContext. GHC itself doesn't + -- use them, but it does reset them to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + ic_toplev_scope :: [Module], + -- ^ The context includes the "top-level" scope of + -- these modules + ic_imports :: [ImportDecl RdrName], + -- ^ The context is extended with these import declarations + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The contexts' cached 'GlobalRdrEnv', built by + -- 'InteractiveEval.setContext' + + ic_tmp_ids :: [Id], + -- ^ Names bound during interaction with the user. Later + -- Ids shadow earlier ones with the same OccName + -- Expressions are typed with these Ids in the envt For + -- runtime-debugging, these Ids may have free TcTyVars of + -- RuntimUnkSkol flavour, but no free TyVars (because the + -- typechecker doesn't expect that) #ifdef GHCI - , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts #endif - , ic_cwd :: Maybe FilePath -- virtual CWD of the program + ic_cwd :: Maybe FilePath + -- virtual CWD of the program } emptyInteractiveContext :: InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], - ic_exports = [], + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tmp_ids = [] #ifdef GHCI diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index e0a30b4..bb5fab6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -40,10 +40,9 @@ module InteractiveEval ( import GhcMonad import HscMain -import HsSyn (ImportDecl) +import HsSyn import HscTypes -import TcRnDriver -import RnNames (gresFromAvails) +import RnNames (gresFromAvails) import InstEnv import Type import TcType hiding( typeKind ) @@ -68,14 +67,13 @@ import ErrUtils import SrcLoc import BreakArray import RtClosureInspect -import BasicTypes import Outputable import FastString import MonadUtils import System.Directory import Data.Dynamic -import Data.List (find, partition) +import Data.List (find) import Control.Monad import Foreign hiding (unsafePerformIO) import Foreign.C @@ -779,37 +777,27 @@ fromListBL bound l = BL (length l) bound l [] -- module. They always shadow anything in scope in the current context. setContext :: GhcMonad m => [Module] -- ^ entire top level scope of these modules - -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules + -> [ImportDecl RdrName] -- ^ these import declarations -> m () -setContext toplev_mods other_mods = do +setContext toplev_mods import_decls = do hsc_env <- getSession let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env - (decls,mods) = partition (isJust . snd) other_mods -- time for tracing - export_mods = map fst mods - imprt_decls = map noLoc (catMaybes (map snd decls)) + imprt_decls = map noLoc import_decls -- - export_env <- liftIO $ mkExportEnv hsc_env export_mods import_env <- if null imprt_decls then return emptyGlobalRdrEnv else do let this_mod | null toplev_mods = pRELUDE | otherwise = head toplev_mods liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls + toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs + + let all_env = foldr plusGlobalRdrEnv import_env toplev_envs modifySession $ \_ -> hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = other_mods, - ic_rn_gbl_env = all_env }} - --- Make a GlobalRdrEnv based on the exports of the modules only. -mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv -mkExportEnv hsc_env mods - = do { stuff <- mapM (getModuleExports hsc_env) mods - ; let (_msgs, mb_name_sets) = unzip stuff - envs = [ availsToGlobalRdrEnv (moduleName mod) avails - | (Just avails, mod) <- zip mb_name_sets mods ] - ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs } + ic_imports = import_decls, + ic_rn_gbl_env = all_env }} availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv availsToGlobalRdrEnv mod_name avails @@ -837,9 +825,9 @@ mkTopLevEnv hpt modl -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))]) +getContext :: GhcMonad m => m ([Module],[ImportDecl RdrName]) getContext = withSession $ \HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_exports ic) + return (ic_toplev_scope ic, ic_imports ic) -- | Returns @True@ if the specified module is interpreted, and hence has -- its full top-level scope available. @@ -949,15 +937,9 @@ compileExpr expr = withSession $ \hsc_env -> do dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do - (full,exports) <- getContext - setContext full $ - (mkModule - (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ,Nothing):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" Just (ids, hvals) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt - setContext full exports vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of (_:[], v:[]) -> return v diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 5aa6959..7af30ba 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1366,18 +1366,14 @@ tcRnType hsc_env ictxt rdr_type -- could not be found. getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod - = let - ic = hsc_IC hsc_env - checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic) - in - initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) + = initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod) -- Get the export avail info and also load all orphan and family-instance -- modules. Finally, check that the family instances of all modules in the -- interactive context are consistent (these modules are in the second -- argument). -tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] -tcGetModuleExports mod directlyImpMods +tcGetModuleExports :: Module -> TcM [AvailInfo] +tcGetModuleExports mod = do { let doc = ptext (sLit "context for compiling statements") ; iface <- initIfaceTcRn $ loadSysInterface doc mod @@ -1385,10 +1381,6 @@ tcGetModuleExports mod directlyImpMods -- interfaces, so their instances are visible. ; loadOrphanModules (dep_orphs (mi_deps iface)) False - -- Check that the family instances of all directly loaded - -- modules are consistent. - ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods - ; ifaceExportNames (mi_exports iface) } diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 2aff483..52b28ef 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -56,7 +56,7 @@ data GHCiState = GHCiState editor :: String, stop :: String, options :: [GHCiOption], - prelude :: GHC.Module, + prelude :: GHC.ModuleName, line_number :: !Int, -- input line break_ctr :: !Int, breaks :: ![(Int, BreakLocation)], @@ -78,7 +78,7 @@ data GHCiState = GHCiState ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) } -data CtxtCmd -- In each case, the first [String] are the starred modules +data CtxtCmd -- In each case, the first [String] are the starred modules -- and the second are the unstarred ones = SetContext [String] [String] | AddModules [String] [String] @@ -210,7 +210,7 @@ instance ExceptionMonad (InputT GHCi) where gunblock = Haskeline.unblock -- for convenience... -getPrelude :: GHCi Module +getPrelude :: GHCi ModuleName getPrelude = getGHCiState >>= return . prelude getDynFlags :: GhcMonad m => m DynFlags diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 0f68607..757b634 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -137,7 +137,7 @@ builtin_commands = [ ("kind", keepGoing' kindOfType, completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), - ("module", keepGoing setContext, completeSetModule), + ("module", keepGoing moduleCmd, completeSetModule), ("main", keepGoing runMain, completeFilename), ("print", keepGoing printCmd, completeExpression), ("quit", quit, noCompletion), @@ -346,8 +346,8 @@ interactiveUI srcs maybe_exprs = do #endif -- initial context is just the Prelude - prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing - GHC.setContext [] [(prel_mod, Nothing)] + let prel_mn = GHC.mkModuleName "Prelude" + GHC.setContext [] [simpleImportDecl prel_mn] default_editor <- liftIO $ findEditor @@ -359,7 +359,7 @@ interactiveUI srcs maybe_exprs = do editor = default_editor, -- session = session, options = [], - prelude = prel_mod, + prelude = prel_mn, line_number = 1, break_ctr = 0, breaks = [], @@ -544,7 +544,7 @@ fileLoop hdl = do mkPrompt :: GHCi String mkPrompt = do - (toplevs,exports) <- GHC.getContext + (toplevs,imports) <- GHC.getContext resumes <- GHC.getResumeContext -- st <- getGHCiState @@ -570,7 +570,7 @@ mkPrompt = do -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+> -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+> hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> - hsep (map (ppr . GHC.moduleName) (nub (map fst exports))) + hsep (map ppr (nub (map ideclName imports))) deflt_prompt = dots <> context_bit <> modules_bit @@ -1151,7 +1151,7 @@ reloadModule m = do else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> LoadHowMuch -> InputT GHCi SuccessFlag +doLoad :: Bool -> ([Module],[ImportDecl RdrName]) -> LoadHowMuch -> InputT GHCi SuccessFlag doLoad retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. @@ -1160,7 +1160,7 @@ doLoad retain_context prev_context howmuch = do afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Bool -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> InputT GHCi () +afterLoad :: SuccessFlag -> Bool -> ([Module],[ImportDecl RdrName]) -> InputT GHCi () afterLoad ok retain_context prev_context = do lift revertCAFs -- always revert CAFs on load. lift discardTickArrays @@ -1172,10 +1172,10 @@ afterLoad ok retain_context prev_context = do lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries -setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad :: ([Module],[ImportDecl RdrName]) -> Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([], [(prel_mod, Nothing)]) + setContextKeepingPackageModules prev keep_ctxt ([], [simpleImportDecl prel_mod]) setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets @@ -1203,25 +1203,40 @@ setContextAfterLoad prev keep_ctxt ms = do if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([],[(prel_mod,Nothing),(m,Nothing)]) + setContextKeepingPackageModules prev keep_ctxt + ([], [simpleImportDecl prel_mod, + simpleImportDecl (GHC.moduleName m)]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules - :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- previous context + :: ([Module],[ImportDecl RdrName]) -- previous context -> Bool -- re-execute :module commands - -> ([Module],[(Module, Maybe (ImportDecl RdrName))]) -- new context + -> ([Module],[ImportDecl RdrName]) -- new context -> GHCi () setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do - let (_,bs0) = prev_context + let (_,imports0) = prev_context prel_mod <- getPrelude -- filter everything, not just lefts - let pkg_modules = filter ((\p -> not (isHomeModule p) && p /= prel_mod) . fst) bs0 - let bs1 = if null as then nubBy sameFst ((prel_mod,Nothing) : bs) else bs - GHC.setContext as (nubBy sameFst (bs1 ++ pkg_modules)) + + let is_pkg_mod i + | unLoc (ideclName i) == prel_mod = return False + | otherwise = do + e <- gtry $ GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + case e :: Either SomeException Module of + Left _ -> return False + Right m -> return (not (isHomeModule m)) + + pkg_modules <- filterM is_pkg_mod imports0 + + let bs1 = if null as + then nubBy sameMod (simpleImportDecl prel_mod : bs) + else bs + + GHC.setContext as (nubBy sameMod (bs1 ++ pkg_modules)) if keep_ctxt then do st <- getGHCiState - mapM_ (playCtxtCmd False) (remembered_ctx st) + playCtxtCmds False (remembered_ctx st) else do st <- getGHCiState setGHCiState st{ remembered_ctx = [] } @@ -1229,8 +1244,8 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId -sameFst :: (Module, Maybe (ImportDecl RdrName)) -> (Module, Maybe (ImportDecl RdrName)) -> Bool -sameFst x y = fst x == fst y +sameMod :: ImportDecl RdrName -> ImportDecl RdrName -> Bool +sameMod x y = unLoc (ideclName x) == unLoc (ideclName y) modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do @@ -1321,7 +1336,10 @@ browseCmd bang m = -- recently-added module occurs last, it seems. case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True - ([], bs@(_:_)) -> browseModule bang (fst (last bs)) True + ([], bs@(_:_)) -> do + let i = last bs + m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + browseModule bang m True ([], []) -> ghcError (CmdLineError ":browse: no current module") _ -> ghcError (CmdLineError "syntax: :browse ") @@ -1337,7 +1355,8 @@ browseModule bang modl exports_only = do -- just so we can get an appropriate PrintUnqualified (as,bs) <- GHC.getContext prel_mod <- lift getPrelude - if exports_only then GHC.setContext [] [(prel_mod,Nothing), (modl,Nothing)] + if exports_only then GHC.setContext [] [simpleImportDecl prel_mod, + simpleImportDecl (GHC.moduleName modl)] else GHC.setContext [modl] [] target_unqual <- GHC.getPrintUnqual GHC.setContext as bs @@ -1415,13 +1434,13 @@ browseModule bang modl exports_only = do newContextCmd :: CtxtCmd -> GHCi () newContextCmd cmd = do - playCtxtCmd True cmd + playCtxtCmds True [cmd] st <- getGHCiState let cmds = remembered_ctx st setGHCiState st{ remembered_ctx = cmds ++ [cmd] } -setContext :: String -> GHCi () -setContext str +moduleCmd :: String -> GHCi () +moduleCmd str | all sensible strs = newContextCmd cmd | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where @@ -1441,53 +1460,65 @@ setContext str starred ('*':m) = Left m starred m = Right m -playCtxtCmd:: Bool -> CtxtCmd -> GHCi () -playCtxtCmd fail cmd = do - (prev_as,prev_bs) <- GHC.getContext +type Context = ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) + +playCtxtCmds :: Bool -> [CtxtCmd] -> GHCi () +playCtxtCmds fail cmds = do + ctx <- GHC.getContext + (as,bs) <- foldM (playCtxtCmd fail) ctx cmds + GHC.setContext as bs + +playCtxtCmd:: Bool -> Context -> CtxtCmd -> GHCi Context +playCtxtCmd fail (prev_as, prev_bs) cmd = do case cmd of SetContext as bs -> do (as',bs') <- do_checks as bs prel_mod <- getPrelude - let bs'' = if null as && prel_mod `notElem` (map fst bs') - then (prel_mod,Nothing):bs' + let bs'' = if null as && prel_mod `notElem` bs' + then prel_mod : bs' else bs' - GHC.setContext as' bs'' + return (as', map simpleImportDecl bs'') AddModules as bs -> do (as',bs') <- do_checks as bs - -- it should replace the old stuff, not the other way around - -- need deleteAllBy, not deleteFirstsBy for sameFst - let remaining_as = prev_as \\ (as' ++ map fst bs') - remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as') - GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs') + let (remaining_as, remaining_bs) = + prev_without (map moduleName as' ++ bs') + return (remaining_as ++ as', remaining_bs ++ map simpleImportDecl bs') RemModules as bs -> do (as',bs') <- do_checks as bs - let new_as = prev_as \\ (as' ++ map fst bs') - new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs') - GHC.setContext new_as new_bs + let (new_as, new_bs) = prev_without (map moduleName as' ++ bs') + return (new_as, new_bs) Import str -> do m_idecl <- maybe_fail $ GHC.parseImportDecl str case m_idecl of - Nothing -> return () + Nothing -> return (prev_as, prev_bs) Just idecl -> do m_mdl <- maybe_fail $ loadModuleName idecl case m_mdl of - Nothing -> return () - Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)]) - + Nothing -> return (prev_as, prev_bs) + Just _ -> return (prev_as, prev_bs ++ [idecl]) + -- we don't filter the module out of the old declarations, + -- because 'import' is supposed to be cumulative. where maybe_fail | fail = liftM Just | otherwise = trymaybe + prev_without names = (as',bs') + where as' = deleteAllBy sameModName prev_as names + bs' = deleteAllBy importsSameMod prev_bs names + do_checks as bs = do as' <- mapM (maybe_fail . wantInterpretedModule) as - bs' <- mapM (maybe_fail . lookupModule) bs - return (catMaybes as', map contextualize (catMaybes bs')) + bs' <- mapM (maybe_fail . liftM moduleName . lookupModule) bs + return (catMaybes as', catMaybes bs') + + sameModName a b = moduleName a == b + importsSameMod a b = unLoc (ideclName a) == b - contextualize x = (x,Nothing) - deleteAllBy f a b = filter (\x->(not (any (f x) b))) a + deleteAllBy :: (a -> b -> Bool) -> [a] -> [b] -> [a] + deleteAllBy f as bs = filter (\a-> not (any (f a) bs)) as trymaybe ::GHCi a -> GHCi (Maybe a) trymaybe m = do @@ -1828,8 +1859,8 @@ completeModule = wrapIdentCompleter $ \w -> do completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do modules <- case m of Just '-' -> do - (toplevs, exports) <- GHC.getContext - return $ map GHC.moduleName (nub (map fst exports) ++ toplevs) + (toplevs, imports) <- GHC.getContext + return $ map GHC.moduleName toplevs ++ map (unLoc.ideclName) imports _ -> do dflags <- GHC.getSessionDynFlags let pkg_mods = allExposedModules dflags