diff options
| -rw-r--r-- | compiler/basicTypes/RdrName.lhs | 5 | ||||
| -rw-r--r-- | compiler/hsSyn/HsImpExp.lhs | 12 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 2 | ||||
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 22 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 4 | ||||
| -rw-r--r-- | compiler/main/HscStats.lhs | 3 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 29 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 53 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 6 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 60 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 22 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 202 |
13 files changed, 231 insertions, 191 deletions
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 3b19356e49..096c866941 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -682,9 +682,12 @@ ppr_defn (UnhelpfulLoc _) = empty instance Outputable ImportSpec where ppr imp_spec - = ptext (sLit "imported from") <+> ppr (importSpecModule imp_spec) + = ptext (sLit "imported") <+> qual + <+> ptext (sLit "from") <+> ppr (importSpecModule imp_spec) <+> pprLoc where + qual | is_qual (is_decl imp_spec) = ptext (sLit "qualified") + | otherwise = empty loc = importSpecLoc imp_spec pprLoc = case loc of RealSrcSpan s -> ptext (sLit "at") <+> ppr s diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 9dbb4417ae..0f7ad6e678 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -38,6 +38,7 @@ data ImportDecl name ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: Bool, -- ^ True => qualified + ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) ideclAs :: Maybe ModuleName, -- ^ as Module ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) } deriving (Data, Typeable) @@ -48,6 +49,7 @@ simpleImportDecl mn = ImportDecl { ideclPkgQual = Nothing, ideclSource = False, ideclSafe = True, + ideclImplicit = False, ideclQualified = False, ideclAs = Nothing, ideclHiding = Nothing @@ -56,11 +58,17 @@ simpleImportDecl mn = ImportDecl { \begin{code} instance (Outputable name) => Outputable (ImportDecl name) where - ppr (ImportDecl mod' pkg from safe qual as spec) - = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_safe safe, + ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg + , ideclSource = from, ideclSafe = safe + , ideclQualified = qual, ideclImplicit = implicit + , ideclAs = as, ideclHiding = spec }) + = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_implicit implicit, pp_safe safe, pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) 4 (pp_spec spec) where + pp_implicit False = empty + pp_implicit True = ptext (sLit ("(implicit)")) + pp_pkg Nothing = empty pp_pkg (Just p) = doubleQuotes (ftext p) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7e1a4631a5..1ca97731a0 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1173,7 +1173,7 @@ checkDependencies hsc_env summary iface orM = foldr f (return False) where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _ _)) = do + dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do find_res <- liftIO $ findImportedModule hsc_env mod pkg case find_res of Found _ mod diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3ebfd52bad..c7b7687023 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -38,7 +38,7 @@ module GHC ( -- * Loading\/compiling the program depanal, - load, LoadHowMuch(..), + load, LoadHowMuch(..), InteractiveImport(..), SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index c7a281cff8..a3f7e79dde 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -100,19 +100,21 @@ mkPrelImports this_mod loc implicit_prelude import_decls | otherwise = [preludeImportDecl] where explicit_prelude_import - = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls, - unLoc mod == pRELUDE_NAME ] + = notNull [ () | L _ (ImportDecl { ideclName = mod + , ideclPkgQual = Nothing }) + <- import_decls + , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl RdrName preludeImportDecl - = L loc $ - ImportDecl (L loc pRELUDE_NAME) - Nothing {- No specific package -} - False {- Not a boot interface -} - False {- Not a safe import -} - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} + = L loc $ ImportDecl { ideclName = L loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = False, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } parseError :: SrcSpan -> Message -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 2603d21bc4..ff52d2de76 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -312,9 +312,7 @@ hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ fmap tcg_rdr_env $ - tcRnImports hsc_env this_mod loc import_decls - where - loc = mkGeneralSrcSpan (mkFastString "In a call to hscRnImportDecls") + tcRnImports hsc_env this_mod import_decls #endif -- ----------------------------------------------------------------------------- diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 76699a5f85..34310e038c 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -123,7 +123,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) sig_info (GenericSig _ _) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) - import_info (L _ (ImportDecl _ _ _ safe qual as spec)) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) safe_info = qual_info qual_info False = 0 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d43105b02d..436feb0094 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -42,6 +42,7 @@ module HscTypes ( -- * Interactive context InteractiveContext(..), emptyInteractiveContext, + InteractiveImport(..), icPrintUnqual, extendInteractiveContext, substInteractiveContext, mkPrintUnqualified, pprModulePrefix, @@ -883,15 +884,12 @@ emptyModIface mod -- data InteractiveContext = InteractiveContext { - -- 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 + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it 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_imports :: [InteractiveImport], + -- ^ The GHCi context is extended with these imports ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The contexts' cached 'GlobalRdrEnv', built by @@ -914,11 +912,17 @@ data InteractiveContext -- virtual CWD of the program } +data InteractiveImport + = IIDecl (ImportDecl RdrName) -- Bring the exports of a particular module + -- (filtered by an import decl) into scope + | IIModule Module -- Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + emptyInteractiveContext :: InteractiveContext emptyInteractiveContext - = InteractiveContext { ic_toplev_scope = [], - ic_imports = [], + = InteractiveContext { ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tmp_ids = [] #ifdef GHCI @@ -948,6 +952,10 @@ substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = ictxt { ic_tmp_ids = map subst_ty ids } where subst_ty id = id `setIdType` substTy subst (idType id) + +instance Outputable InteractiveImport where + ppr (IIModule m) = char '*' <> ppr m + ppr (IIDecl d) = ppr d \end{code} %************************************************************************ @@ -1675,6 +1683,7 @@ ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies ideclName = noLoc mod_nm, ideclPkgQual = Nothing, ideclSource = False, + ideclImplicit = True, -- Maybe implicit because not "in the program text" ideclQualified = False, ideclAs = Nothing, ideclHiding = Nothing, diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 0386273de8..24f340b33d 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -778,29 +778,32 @@ fromListBL bound l = BL (length l) bound l [] -- Setting the context doesn't throw away any bindings; the bindings -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. -setContext :: GhcMonad m => - [Module] -- ^ entire top level scope of these modules - -> [ImportDecl RdrName] -- ^ these import declarations - -> m () -setContext toplev_mods import_decls = do - hsc_env <- getSession - let old_ic = hsc_IC hsc_env - hpt = hsc_HPT hsc_env - imprt_decls = map noLoc import_decls - -- - 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 import_env toplev_envs - modifySession $ \_ -> - hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_imports = import_decls, - ic_rn_gbl_env = all_env }} +setContext :: GhcMonad m => [InteractiveImport] -> m () +setContext imports + = do { hsc_env <- getSession + ; let old_ic = hsc_IC hsc_env + ; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports + ; modifySession $ \_ -> + hsc_env{ hsc_IC = old_ic { ic_imports = imports + , ic_rn_gbl_env = all_env }}} + +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv +-- Compute the GlobalRdrEnv for the interactive context +findGlobalRdrEnv hsc_env imports + = do { idecls_env <- hscRnImportDecls hsc_env this_mod idecls + -- This call also loads any orphan modules + ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods + ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } + where + idecls :: [LImportDecl RdrName] + idecls = [noLoc d | IIDecl d <- imports] + + imods :: [Module] + imods = [m | IIModule m <- imports] + + this_mod = case imods of + [] -> pRELUDE + (m:_) -> m availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv availsToGlobalRdrEnv mod_name avails @@ -828,9 +831,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],[ImportDecl RdrName]) +getContext :: GhcMonad m => m [InteractiveImport] getContext = withSession $ \HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_imports ic) + return (ic_imports ic) -- | Returns @True@ if the specified module is interpreted, and hence has -- its full top-level scope available. diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index d199fb534f..42988feeeb 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -504,7 +504,11 @@ importdecls :: { [LImportDecl RdrName] } importdecl :: { LImportDecl RdrName } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - { L (comb4 $1 $6 $7 $8) (ImportDecl $6 $5 $2 $3 $4 (unLoc $7) (unLoc $8)) } + { L (comb4 $1 $6 $7 $8) $ + ImportDecl { ideclName = $6, ideclPkgQual = $5 + , ideclSource = $2, ideclSafe = $3 + , ideclQualified = $4, ideclImplicit = False + , ideclAs = unLoc $7, ideclHiding = unLoc $8 } } maybe_src :: { IsBootInterface } : '{-# SOURCE' '#-}' { True } diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index c6c941c4ca..c28c5c765d 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -21,8 +21,6 @@ import RnHsDoc ( rnHsDoc ) import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad - -import HeaderInfo ( mkPrelImports ) import PrelNames import Module import Name @@ -132,29 +130,21 @@ with yes we have gone with no for now. \begin{code} -rnImports :: SrcSpan -> [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports :: [LImportDecl RdrName] + -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImports prel_imp_loc imports +rnImports imports -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful -- warning for {- SOURCE -} ones that are unnecessary = do this_mod <- getModule - implicit_prelude <- xoptM Opt_ImplicitPrelude - let prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude imports - (source, ordinary) = partition is_source_import imports - is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot - - ifWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ addWarn (implicitPreludeWarn) - - stuff1 <- mapM (rnImportDecl this_mod True) prel_imports - stuff2 <- mapM (rnImportDecl this_mod False) ordinary - stuff3 <- mapM (rnImportDecl this_mod False) source + let (source, ordinary) = partition is_source_import imports + is_source_import d = ideclSource (unLoc d) + stuff1 <- mapM (rnImportDecl this_mod) ordinary + stuff2 <- mapM (rnImportDecl this_mod) source -- Safe Haskell: See Note [Tracking Trust Transitively] let (decls, rdr_env, imp_avails, hpc_usage) = - combine (stuff1 ++ stuff2 ++ stuff3) + combine (stuff1 ++ stuff2) return (decls, rdr_env, imp_avails, hpc_usage) where @@ -169,15 +159,15 @@ rnImports prel_imp_loc imports imp_avails1 `plusImportAvails` imp_avails2, hpc_usage1 || hpc_usage2 ) -rnImportDecl :: Module -> Bool +rnImportDecl :: Module -> LImportDecl RdrName -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImportDecl this_mod implicit_prelude - (L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg - , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_only - , ideclAs = as_mod, ideclHiding = imp_details })) +rnImportDecl this_mod + (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_only, ideclImplicit = implicit + , ideclAs = as_mod, ideclHiding = imp_details })) = setSrcSpan loc $ do when (isJust mb_pkg) $ do @@ -194,11 +184,11 @@ rnImportDecl this_mod implicit_prelude -- (Opt_WarnMissingImportList also checks for T(..) items -- but that is done in checkDodgyImport below) case imp_details of - Just (False, _) -> return () -- Explicit import list - _ | implicit_prelude -> return () - | qual_only -> return () - | otherwise -> ifWOptM Opt_WarnMissingImportList $ - addWarn (missingImportListWarn imp_mod_name) + Just (False, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> ifWOptM Opt_WarnMissingImportList $ + addWarn (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg @@ -309,8 +299,8 @@ rnImportDecl this_mod implicit_prelude -- should the import be safe? mod_safe' = mod_safe - || (not implicit_prelude && safeDirectImpsReq dflags) - || (implicit_prelude && safeImplicitImpsReq dflags) + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) imports = ImportAvails { imp_mods = unitModuleEnv imp_mod @@ -339,8 +329,8 @@ rnImportDecl this_mod implicit_prelude _ -> return () ) - let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot mod_safe' - qual_only as_mod new_imp_details) + let new_imp_decl = L loc (decl { ideclSafe = mod_safe' + , ideclHiding = new_imp_details }) return (new_imp_decl, gbl_env, imports, mi_hpc iface) ) @@ -1758,10 +1748,6 @@ moduleWarn mod (DeprecatedTxt txt) <+> ptext (sLit "is deprecated:"), nest 2 (vcat (map ppr txt)) ] -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = ptext (sLit "Module `Prelude' implicitly imported") - packageImportErr :: SDoc packageImportErr = ptext (sLit "Package-qualified imports are not enabled; use -XPackageImports") diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index cdd614299e..437877aa7d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -37,6 +37,7 @@ import InstEnv import FamInstEnv import TcAnnotations import TcBinds +import HeaderInfo ( mkPrelImports ) import TcType ( tidyTopType ) import TcDefaults import TcEnv @@ -131,8 +132,15 @@ tcRnModule hsc_env hsc_src save_rn_syntax initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ - do { -- Deal with imports; - tcg_env <- tcRnImports hsc_env this_mod prel_imp_loc import_decls ; + do { -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM Opt_ImplicitPrelude; + let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } ; + + ifWOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; + + tcg_env <- tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; setGblEnv tcg_env $ do { -- Load the hi-boot interface for this module, if any @@ -192,6 +200,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcDump tcg_env ; return tcg_env }}}} + + +implicitPreludeWarn :: SDoc +implicitPreludeWarn + = ptext (sLit "Module `Prelude' implicitly imported") \end{code} @@ -203,10 +216,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax \begin{code} tcRnImports :: HscEnv -> Module - -> SrcSpan -- Location for the implicit prelude import -> [LImportDecl RdrName] -> TcM TcGblEnv -tcRnImports hsc_env this_mod prel_imp_loc import_decls - = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports prel_imp_loc import_decls ; +tcRnImports hsc_env this_mod import_decls + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) -- Make sure we record the dependencies from the DynFlags in the EPS or we diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 50914945fa..21d6abd805 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -22,7 +22,7 @@ import Debugger -- The GHC interface import qualified GHC hiding (resume, runStmt) import GHC ( LoadHowMuch(..), Target(..), TargetId(..), - TyThing(..), Phase, + InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) import PprTyThing @@ -53,6 +53,7 @@ import Linker import Util import NameSet import Maybes ( orElse, expectJust ) +import ListSetOps( removeRedundant ) import FastString import Encoding import Foreign.C @@ -350,7 +351,7 @@ interactiveUI srcs maybe_exprs = do -- initial context is just the Prelude let prel_mn = GHC.mkModuleName "Prelude" - GHC.setContext [] [simpleImportDecl prel_mn] + GHC.setContext [IIDecl (simpleImportDecl prel_mn)] default_editor <- liftIO $ findEditor @@ -548,7 +549,7 @@ fileLoop hdl = do mkPrompt :: GHCi String mkPrompt = do - (toplevs,imports) <- GHC.getContext + imports <- GHC.getContext resumes <- GHC.getResumeContext -- st <- getGHCiState @@ -573,8 +574,8 @@ mkPrompt = do -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in -- 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 (nub (map ideclName imports))) + hsep [ char '*' <> ppr (GHC.moduleName m) | IIModule m <- imports ] <+> + hsep (map ppr (nub [unLoc (ideclName d) | IIDecl d <- imports])) deflt_prompt = dots <> context_bit <> modules_bit @@ -1163,7 +1164,7 @@ reloadModule m = do else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Bool -> ([Module],[ImportDecl RdrName]) -> LoadHowMuch -> InputT GHCi SuccessFlag +doLoad :: Bool -> [InteractiveImport] -> 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. @@ -1172,7 +1173,7 @@ doLoad retain_context prev_context howmuch = do afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Bool -> ([Module],[ImportDecl RdrName]) -> InputT GHCi () +afterLoad :: SuccessFlag -> Bool -> [InteractiveImport] -> InputT GHCi () afterLoad ok retain_context prev_context = do lift revertCAFs -- always revert CAFs on load. lift discardTickArrays @@ -1184,10 +1185,9 @@ afterLoad ok retain_context prev_context = do lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries -setContextAfterLoad :: ([Module],[ImportDecl RdrName]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad :: [InteractiveImport] -> Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad prev keep_ctxt [] = do - prel_mod <- getPrelude - setContextKeepingPackageModules prev keep_ctxt ([], [simpleImportDecl prel_mod]) + setContextKeepingPackageModules prev keep_ctxt [] setContextAfterLoad prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets @@ -1212,39 +1212,35 @@ setContextAfterLoad prev keep_ctxt ms = do load_this summary | m <- GHC.ms_mod summary = do b <- GHC.moduleIsInterpreted m - if b then setContextKeepingPackageModules prev keep_ctxt ([m], []) + if b then setContextKeepingPackageModules prev keep_ctxt [IIModule m] else do - prel_mod <- getPrelude setContextKeepingPackageModules prev keep_ctxt - ([], [simpleImportDecl prel_mod, - simpleImportDecl (GHC.moduleName m)]) + [IIDecl $ simpleImportDecl (GHC.moduleName m)] -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules - :: ([Module],[ImportDecl RdrName]) -- previous context + :: [InteractiveImport] -- previous context -> Bool -- re-execute :module commands - -> ([Module],[ImportDecl RdrName]) -- new context + -> [InteractiveImport] -- new context -> GHCi () -setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do - let (_,imports0) = prev_context +setContextKeepingPackageModules prev_context keep_ctxt new_context = do prel_mod <- getPrelude -- filter everything, not just lefts - let is_pkg_mod i - | unLoc (ideclName i) == prel_mod = return False - | otherwise = do - e <- gtry $ GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + let is_pkg_import :: InteractiveImport -> GHCi Bool + is_pkg_import (IIDecl d) + | let mod_name = unLoc (ideclName d) + , mod_name /= prel_mod + = do e <- gtry $ GHC.findModule mod_name (ideclPkgQual d) case e :: Either SomeException Module of Left _ -> return False Right m -> return (not (isHomeModule m)) + is_pkg_import _ = return False - pkg_modules <- filterM is_pkg_mod imports0 - - let bs1 = if null as - then nubBy sameMod (simpleImportDecl prel_mod : bs) - else bs + prev_pkg_imports <- filterM is_pkg_import prev_context - GHC.setContext as (nubBy sameMod (bs1 ++ pkg_modules)) + mySetContext (prev_pkg_imports ++ new_context) + -- if keep_ctxt then do st <- getGHCiState @@ -1256,9 +1252,6 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId -sameMod :: ImportDecl RdrName -> ImportDecl RdrName -> Bool -sameMod x y = unLoc (ideclName x) == unLoc (ideclName y) - modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags @@ -1338,18 +1331,8 @@ isSafeCmd m = [s] | looksLikeModuleName s -> do m <- lift $ lookupModule s isSafeModule m - [] -> do - (as,bs) <- GHC.getContext - -- Guess which module the user wants to browse. Pick - -- modules that are interpreted first. The most - -- recently-added module occurs last, it seems. - case (as,bs) of - (as@(_:_), _) -> isSafeModule $ last as - ([], bs@(_:_)) -> do - let i = last bs - m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + [] -> do m <- guessCurrentModule isSafeModule m - ([], []) -> ghcError (CmdLineError ":issafe: no current module") _ -> ghcError (CmdLineError "syntax: :issafe <module>") isSafeModule :: Module -> InputT GHCi () @@ -1389,20 +1372,21 @@ browseCmd bang m = [s] | looksLikeModuleName s -> do m <- lift $ lookupModule s browseModule bang m True - [] -> do - (as,bs) <- GHC.getContext - -- Guess which module the user wants to browse. Pick - -- modules that are interpreted first. The most - -- recently-added module occurs last, it seems. - case (as,bs) of - (as@(_:_), _) -> browseModule bang (last as) True - ([], bs@(_:_)) -> do - let i = last bs - m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i) + [] -> do m <- guessCurrentModule browseModule bang m True - ([], []) -> ghcError (CmdLineError ":browse: no current module") _ -> ghcError (CmdLineError "syntax: :browse <module>") +guessCurrentModule :: InputT GHCi Module +-- Guess which module the user wants to browse. Pick +-- modules that are interpreted first. The most +-- recently-added module occurs last, it seems. +guessCurrentModule + = do { imports <- GHC.getContext + ; when (null imports) (ghcError (CmdLineError ":issafe: no current module")) + ; case (last imports) of + IIModule m -> return m + IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d) } + -- without bang, show items in context of their parents and omit children -- with bang, show class methods and data constructors separately, and -- indicate import modules, to aid qualifying unqualified names @@ -1411,15 +1395,15 @@ browseModule :: Bool -> Module -> Bool -> InputT GHCi () browseModule bang modl exports_only = do -- :browse! reports qualifiers wrt current context current_unqual <- GHC.getPrintUnqual + -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified - (as,bs) <- GHC.getContext - prel_mod <- lift getPrelude - if exports_only then GHC.setContext [] [simpleImportDecl prel_mod, - simpleImportDecl (GHC.moduleName modl)] - else GHC.setContext [modl] [] + imports <- GHC.getContext + lift $ mySetContext (if exports_only + then [IIDecl $ simpleImportDecl (GHC.moduleName modl)] + else [IIModule modl]) target_unqual <- GHC.getPrintUnqual - GHC.setContext as bs + GHC.setContext imports let unqual = if bang then current_unqual else target_unqual @@ -1520,65 +1504,59 @@ moduleCmd str starred ('*':m) = Left m starred m = Right m -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 + ctx' <- foldM (playCtxtCmd fail) ctx cmds + mySetContext ctx' -playCtxtCmd:: Bool -> Context -> CtxtCmd -> GHCi Context -playCtxtCmd fail (prev_as, prev_bs) cmd = do +playCtxtCmd:: Bool -> [InteractiveImport] -> CtxtCmd -> GHCi [InteractiveImport] +playCtxtCmd fail prev 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` bs' - then prel_mod : bs' - else bs' - return (as', map simpleImportDecl bs'') + return (mk_imps as' bs') AddModules as bs -> do (as',bs') <- do_checks as bs - let (remaining_as, remaining_bs) = - prev_without (map moduleName as' ++ bs') - return (remaining_as ++ as', remaining_bs ++ map simpleImportDecl bs') + return (prev_without as' bs' prev ++ mk_imps as' bs') RemModules as bs -> do (as',bs') <- do_checks as bs - let (new_as, new_bs) = prev_without (map moduleName as' ++ bs') - return (new_as, new_bs) + return (prev_without as' bs' prev) Import str -> do m_idecl <- maybe_fail $ GHC.parseImportDecl str case m_idecl of - Nothing -> return (prev_as, prev_bs) + Nothing -> return prev Just idecl -> do m_mdl <- maybe_fail $ loadModuleName idecl case m_mdl of - Nothing -> return (prev_as, prev_bs) - Just _ -> return (prev_as, prev_bs ++ [idecl]) - -- we don't filter the module out of the old declarations, + Nothing -> return prev + Just _ -> return (prev ++ [IIDecl 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 + prev_without :: [Module] -> [ModuleName] + -> [InteractiveImport] -> [InteractiveImport] + prev_without as bs imports + = filterOut is_new imports + where + is_new ii = iiModuleName ii `elem` new + new = map moduleName as ++ bs + do_checks :: [String] -> [String] -> GHCi ([Module], [ModuleName]) do_checks as bs = do as' <- mapM (maybe_fail . wantInterpretedModule) as 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 - - deleteAllBy :: (a -> b -> Bool) -> [a] -> [b] -> [a] - deleteAllBy f as bs = filter (\a-> not (any (f a) bs)) as + mk_imps :: [Module] -> [ModuleName] -> [InteractiveImport] + mk_imps as bs = [IIModule a | a <- as] ++ + [IIDecl (simpleImportDecl b) | b <- bs] trymaybe ::GHCi a -> GHCi (Maybe a) trymaybe m = do @@ -1587,6 +1565,42 @@ trymaybe m = do Left _ -> return Nothing Right a -> return (Just a) +mySetContext :: [InteractiveImport] -> GHCi () +-- Remove redundant imports +-- and add an implicit Prelude one +mySetContext imports + = do { prel_mod <- getPrelude + ; let imports1 = removeRedundant subsumesID imports + prel_imports + | any no_prelude_imp imports1 = [] + | otherwise = [IIDecl (simpleImportDecl prel_mod)] + no_prelude_imp (IIModule {}) = True + no_prelude_imp (IIDecl d) = unLoc (ideclName d) == prel_mod + + ; GHC.setContext (prel_imports ++ imports1) } + +iiModuleName :: InteractiveImport -> ModuleName +iiModuleName (IIModule m) = moduleName m +iiModuleName (IIDecl d) = unLoc (ideclName d) + +iiModules :: [InteractiveImport] -> [Module] +iiModules is = [m | IIModule m <- is] + +-- iiDecls :: [InteractiveImport] -> [ImportDecl RdrName] +-- iiDecls is = [d | IIDecl d <- is] + +subsumesID :: InteractiveImport -> InteractiveImport -> Bool +-- Remove any redundant imports +subsumesID (IIModule m1) (IIModule m2) = m1==m2 +subsumesID (IIModule m1) (IIDecl d) = moduleName m1 == unLoc (ideclName d) +subsumesID (IIDecl d1) (IIDecl d2) -- A bit crude + = unLoc (ideclName d1) == unLoc (ideclName d2) + && ideclAs d1 == ideclAs d2 + && not (ideclQualified d1) + && isNothing (ideclHiding d1) +subsumesID _ _ = False + + ---------------------------------------------------------------------------- -- Code for `:set' @@ -1731,7 +1745,7 @@ newDynFlags minus_opts = do _ <- GHC.load LoadAllTargets liftIO (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context - setContextAfterLoad ([],[]) False [] + setContextAfterLoad [] False [] return () @@ -1933,8 +1947,8 @@ completeModule = wrapIdentCompleter $ \w -> do completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do modules <- case m of Just '-' -> do - (toplevs, imports) <- GHC.getContext - return $ map GHC.moduleName toplevs ++ map (unLoc.ideclName) imports + imports <- GHC.getContext + return $ map iiModuleName imports _ -> do dflags <- GHC.getSessionDynFlags let pkg_mods = allExposedModules dflags @@ -2253,8 +2267,8 @@ breakSwitch (arg1:rest) mod <- wantInterpretedModule arg1 breakByModule mod rest | all isDigit arg1 = do - (toplevel, _) <- GHC.getContext - case toplevel of + imports <- GHC.getContext + case iiModules imports of (mod : _) -> breakByModuleLine mod (read arg1) rest [] -> do liftIO $ putStrLn "Cannot find default module for breakpoint." @@ -2410,8 +2424,8 @@ listCmd' str = list2 (words str) list2 :: [String] -> InputT GHCi () list2 [arg] | all isDigit arg = do - (toplevel, _) <- GHC.getContext - case toplevel of + imports <- GHC.getContext + case iiModules imports of [] -> liftIO $ putStrLn "No module to list" (mod : _) -> listModuleLine mod (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do |