diff options
| -rw-r--r-- | compiler/basicTypes/Module.lhs | 23 | ||||
| -rw-r--r-- | compiler/basicTypes/Name.lhs | 18 | ||||
| -rw-r--r-- | compiler/basicTypes/RdrName.lhs | 4 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.lhs | 3 | ||||
| -rw-r--r-- | compiler/ghci/Linker.lhs | 16 | ||||
| -rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 6 | ||||
| -rw-r--r-- | compiler/iface/IfaceEnv.lhs | 18 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Base.hs | 4 | ||||
| -rw-r--r-- | compiler/main/DynamicLoading.hs | 26 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 32 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 329 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 9 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 23 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 2 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/FamInst.lhs | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.lhs | 19 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 196 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 23 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.lhs | 4 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.lhs | 17 | ||||
| -rw-r--r-- | compiler/types/FamInstEnv.lhs | 13 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 30 |
23 files changed, 462 insertions, 369 deletions
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index f9e7942a45..90bf717a85 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -41,6 +41,7 @@ module Module dphParPackageId, mainPackageId, thisGhcPackageId, + interactivePackageId, isInteractiveModule, -- * The Module type Module, @@ -357,20 +358,24 @@ packageIdString = unpackFS . packageIdFS integerPackageId, primPackageId, basePackageId, rtsPackageId, thPackageId, dphSeqPackageId, dphParPackageId, - mainPackageId, thisGhcPackageId :: PackageId -primPackageId = fsToPackageId (fsLit "ghc-prim") -integerPackageId = fsToPackageId (fsLit cIntegerLibrary) -basePackageId = fsToPackageId (fsLit "base") -rtsPackageId = fsToPackageId (fsLit "rts") -thPackageId = fsToPackageId (fsLit "template-haskell") -dphSeqPackageId = fsToPackageId (fsLit "dph-seq") -dphParPackageId = fsToPackageId (fsLit "dph-par") -thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion)) + mainPackageId, thisGhcPackageId, interactivePackageId :: PackageId +primPackageId = fsToPackageId (fsLit "ghc-prim") +integerPackageId = fsToPackageId (fsLit cIntegerLibrary) +basePackageId = fsToPackageId (fsLit "base") +rtsPackageId = fsToPackageId (fsLit "rts") +thPackageId = fsToPackageId (fsLit "template-haskell") +dphSeqPackageId = fsToPackageId (fsLit "dph-seq") +dphParPackageId = fsToPackageId (fsLit "dph-par") +thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion)) +interactivePackageId = fsToPackageId (fsLit "interactive") -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix -- to symbol names, since there can be only one main package per program. mainPackageId = fsToPackageId (fsLit "main") + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = modulePackageId mod == interactivePackageId \end{code} %************************************************************************ diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index bddf2decc5..e2742bb3a8 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -442,17 +442,17 @@ instance OutputableBndr Name where pprName :: Name -> SDoc -pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) +pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ n True builtin - External mod -> pprExternal sty uniq mod occ n False UserSyntax + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ where uniq = mkUniqueGrimily (iBox u) -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Name -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ name is_wired is_builtin +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified @@ -462,7 +462,7 @@ pprExternal sty uniq mod occ name is_wired is_builtin pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = pprModulePrefix sty mod name <> ppr_occ_name occ + | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressModulePrefixes dflags @@ -491,14 +491,14 @@ pprSystem sty uniq occ -- so print the unique -pprModulePrefix :: PprStyle -> Module -> Name -> SDoc +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in HscTypes -pprModulePrefix sty mod name = sdocWithDynFlags $ \dflags -> +pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressModulePrefixes dflags then empty else - case qualName sty name of -- See Outputable.QualifyName: + case qualName sty mod occ of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 56f48aee16..4ffeae0d77 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -265,9 +265,7 @@ instance Outputable RdrName where ppr (Exact name) = ppr name ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod name <> ppr occ) - where name = mkExternalName (mkUniqueGrimily 0) mod occ noSrcSpan - -- Note [Outputable Orig RdrName] in HscTypes + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) instance OutputableBndr RdrName where pprBndr _ n diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 709f2fed0c..7ef407b10c 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -34,7 +34,6 @@ import NameEnv import Rules import BasicTypes ( Activation(.. ) ) import CoreMonad ( endPass, CoreToDo(..) ) -import PrelNames ( iNTERACTIVE ) import FastString import ErrUtils import Outputable @@ -232,7 +231,7 @@ deSugarExpr hsc_env tc_expr ; showPass dflags "Desugar" -- Do desugaring - ; (msgs, mb_core_expr) <- initDs hsc_env iNTERACTIVE rdr_env + ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env type_env fam_inst_env $ dsLExpr tc_expr diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 62f7a701c1..eb3e226ab4 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -52,7 +52,6 @@ import FastString import Config import Platform import SysTools -import PrelNames -- Standard libraries import Control.Monad @@ -525,27 +524,26 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { -- 1. Find the dependent home-pkg-modules/packages from each iface - -- (omitting iINTERACTIVE, which is already linked) - (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods) + -- (omitting modules from the interactive package, which is already linked) + ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) emptyUniqSet emptyUniqSet; - let { + ; let { -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable mods_needed = mods_s `minusList` linked_mods ; pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; linked_mods = map (moduleName.linkableModule) - (objs_loaded pls ++ bcos_loaded pls) - } ; + (objs_loaded pls ++ bcos_loaded pls) } -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot -- compilation) we may need to use maybe_getFileLinkable - let { osuf = objectSuf dflags } ; - lnks_needed <- mapM (get_linkable osuf) mods_needed ; + ; let { osuf = objectSuf dflags } + ; lnks_needed <- mapM (get_linkable osuf) mods_needed - return (lnks_needed, pkgs_needed) } + ; return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index eb1c644f78..76b845114a 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -569,7 +569,11 @@ runTR hsc_env thing = do Just x -> return x runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) -runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE +runTR_maybe hsc_env thing_inside + = do { (_errs, res) <- initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) + thing_inside + ; return res } traceTR :: SDoc -> TR () traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index ef102e4fc7..42c3e32605 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -110,12 +110,14 @@ allocateGlobalBinder name_supply mod occ loc -- Their wired-in-ness is in their NameSort -- and their Module is correct. - Just name | isWiredInName name -> (name_supply, name) - | mod /= iNTERACTIVE -> (new_name_supply, name') - -- Note [interactive name cache] + Just name | isWiredInName name + -> (name_supply, name) + | otherwise + -> (new_name_supply, name') where uniq = nameUnique name name' = mkExternalName uniq mod occ loc + -- name' is like name, but with the right SrcSpan new_cache = extendNameCache (nsNames name_supply) mod occ name' new_name_supply = name_supply {nsNames = new_cache} @@ -128,16 +130,6 @@ allocateGlobalBinder name_supply mod occ loc new_cache = extendNameCache (nsNames name_supply) mod occ name new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} -{- Note [interactive name cache] - -In GHCi we always create Names with the same Module, ":Interactive". -However, we want to be able to shadow older declarations with newer -ones, and we don't want the Name cache giving us back the same Unique -for the new Name as for the old, hence this special case. - -See also Note [Outputable Orig RdrName] in HscTypes. --} - newImplicitBinder :: Name -- Base name -> (OccName -> OccName) -- Occurrence name modifier -> TcRnIf m n Name -- Implicit name diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index fb9668b5ee..5d5f385ade 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -404,7 +404,7 @@ strDisplayName_llvm lbl = do dflags <- getDynFlags let sdoc = pprCLabel platform lbl depth = Outp.PartWay 1 - style = Outp.mkUserStyle (const Outp.NameNotInScope2, const True) depth + style = Outp.mkUserStyle (\ _ _ -> Outp.NameNotInScope2, Outp.alwaysQualifyModules) depth str = Outp.renderWithStyle dflags sdoc style return (fsLit (dropInfoSuffix str)) @@ -422,7 +422,7 @@ strProcedureName_llvm lbl = do dflags <- getDynFlags let sdoc = pprCLabel platform lbl depth = Outp.PartWay 1 - style = Outp.mkUserStyle (const Outp.NameUnqual, const False) depth + style = Outp.mkUserStyle Outp.neverQualify depth str = Outp.renderWithStyle dflags sdoc style return (fsLit str) diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 049846439c..ffafc78216 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -5,10 +5,10 @@ module DynamicLoading ( forceLoadModuleInterfaces, forceLoadNameModuleInterface, forceLoadTyCon, - + -- * Finding names lookupRdrNameInModuleForPlugins, - + -- * Loading values getValueSafely, getHValueSafely, @@ -20,18 +20,16 @@ module DynamicLoading ( import Linker ( linkModule, getHValue ) import SrcLoc ( noSrcSpan ) import Finder ( findImportedModule, cannotFindModule ) -import DriverPhases ( HscSource(HsSrcFile) ) -import TcRnMonad ( initTc, initIfaceTcRn ) +import TcRnMonad ( initTcInteractive, initIfaceTcRn ) import LoadIface ( loadPluginInterface ) import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..) , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName, gre_name ) import RnNames ( gresFromAvails ) -import PrelNames ( iNTERACTIVE ) import DynFlags -import HscTypes ( HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv ) +import HscTypes import BasicTypes ( HValue ) -import TypeRep ( TyThing(..), pprTyThingCategory ) +import TypeRep ( pprTyThingCategory ) import Type ( Type, eqType ) import TyCon ( TyCon ) import Name ( Name, nameModule_maybe ) @@ -52,7 +50,10 @@ import GHC.Exts ( unsafeCoerce# ) -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () forceLoadModuleInterfaces hsc_env doc modules - = (initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ mapM_ (loadPluginInterface doc) modules) >> return () + = (initTcInteractive hsc_env $ + initIfaceTcRn $ + mapM_ (loadPluginInterface doc) modules) + >> return () -- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. @@ -151,7 +152,9 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do case found_module of Found _ mod -> do -- Find the exports of the module - (_, mb_iface) <- initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ loadPluginInterface (ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")) mod + (_, mb_iface) <- initTcInteractive hsc_env $ + initIfaceTcRn $ + loadPluginInterface doc mod case mb_iface of Just iface -> do -- Try and find the required name in the exports @@ -166,8 +169,9 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where dflags = hsc_dflags hsc_env - + where + dflags = hsc_dflags hsc_env + doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule") wrongTyThingError :: Name -> TyThing -> SDoc wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index a6c187eb95..d2fa195e98 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -283,9 +283,10 @@ hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do -- is used to indicate that. hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) -hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe' $ tcRnGetInfo hsc_env name +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } #ifdef GHCI hscIsGHCiMonad :: HscEnv -> String -> IO Name @@ -1327,7 +1328,7 @@ you run it you get a list of HValues that should be the same length as the list of names; add them to the ClosureEnv. A naked expression returns a singleton Name [it]. The stmt is lifted into the -IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver +IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes -} #ifdef GHCI @@ -1349,16 +1350,18 @@ hscStmtWithLocation :: HscEnv -> IO (Maybe ([Id], IO [HValue], FixityEnv)) hscStmtWithLocation hsc_env0 stmt source linenumber = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing Just parsed_stmt -> do -- Rename and typecheck it - -- Here we lift the stmt into the IO monad, see Note - -- [Interactively-bound Ids in GHCi] in TcRnDriver - (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env parsed_stmt + hsc_env <- getHscEnv + let interactive_hsc_env = setInteractivePackage hsc_env + -- Bindings created here belong to the interactive package + -- See Note [The interactive package] in HscTypes + -- (NB: maybe not necessary, since Stmts bind only Ids) + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt interactive_hsc_env parsed_stmt -- Desugar it ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr @@ -1366,6 +1369,9 @@ hscStmtWithLocation hsc_env0 stmt source linenumber = handleWarnings -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisPackageId + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr let hval_io = unsafeCoerce# hval :: IO [HValue] @@ -1386,12 +1392,15 @@ hscDeclsWithLocation :: HscEnv -> IO ([TyThing], InteractiveContext) hscDeclsWithLocation hsc_env0 str source linenumber = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv L _ (HsModule{ hsmodDecls = decls }) <- hscParseThingWithLocation source linenumber parseModule str {- Rename and typecheck it -} - tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls + hsc_env <- getHscEnv + let interactive_hsc_env = setInteractivePackage hsc_env + -- Bindings created here belong to the interactive package + -- See Note [The interactive package] in HscTypes + tc_gblenv <- ioMsgMaybe $ tcRnDeclsi interactive_hsc_env decls {- Grab the new instances -} -- We grab the whole environment because of the overlapping that may have @@ -1432,7 +1441,6 @@ hscDeclsWithLocation hsc_env0 str source linenumber = prepd_binds data_tycons mod_breaks let src_span = srcLocSpan interactiveSrcLoc - hsc_env <- getHscEnv liftIO $ linkDecls hsc_env src_span cbc let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) @@ -1611,7 +1619,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr {- Convert to BCOs -} - ; bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr + ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr {- link it -} ; hval <- linkExpr hsc_env srcspan bcos diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index b7ea898405..071f7ef55f 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -31,7 +31,7 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, + hptInstances, hptRules, hptVectInfo, pprHPT, hptObjs, -- * State relating to known packages @@ -50,8 +50,8 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, extendInteractiveContext, substInteractiveContext, - setInteractivePrintName, - InteractiveImport(..), + setInteractivePrintName, icInteractiveModule, + InteractiveImport(..), setInteractivePackage, mkPrintUnqualified, pprModulePrefix, -- * Interfaces @@ -144,7 +144,7 @@ import Class import TyCon import CoAxiom import DataCon -import PrelNames ( gHC_PRIM, ioTyConName, printName ) +import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import Packages hiding ( Version(..) ) import DynFlags import DriverPhases ( Phase, HscSource(..), isHsBoot, hscSourceString ) @@ -155,7 +155,7 @@ import Maybes import Outputable import BreakArray import SrcLoc -import Unique +-- import Unique import UniqFM import UniqSupply import FastString @@ -168,7 +168,7 @@ import ErrUtils import Platform import Util -import Control.Monad ( mplus, guard, liftM, when, ap ) +import Control.Monad ( guard, liftM, when, ap ) import Data.Array ( Array, array ) import Data.IORef import Data.Time @@ -218,12 +218,13 @@ runHsc hsc_env (Hsc hsc) = do printOrThrowWarnings (hsc_dflags hsc_env) w return a +runInteractiveHsc :: HscEnv -> Hsc a -> IO a -- A variant of runHsc that switches in the DynFlags from the -- InteractiveContext before running the Hsc computation. --- -runInteractiveHsc :: HscEnv -> Hsc a -> IO a -runInteractiveHsc hsc_env = - runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) }) +runInteractiveHsc hsc_env + = runHsc (hsc_env { hsc_dflags = interactive_dflags }) + where + interactive_dflags = ic_dflags (hsc_IC hsc_env) -- ----------------------------------------------------------------------------- -- Source Errors @@ -451,6 +452,21 @@ emptyHomePackageTable = emptyUFM emptyPackageIfaceTable :: PackageIfaceTable emptyPackageIfaceTable = emptyModuleEnv +pprHPT :: HomePackageTable -> SDoc +-- A bit aribitrary for now +pprHPT hpt + = vcat [ hang (ppr (mi_module (hm_iface hm))) + 2 (ppr (md_types (hm_details hm))) + | hm <- eltsUFM hpt ] + +lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo +-- The HPT is indexed by ModuleName, not Module, +-- we must check for a hit on the right Module +lookupHptByModule hpt mod + = case lookupUFM hpt (moduleName mod) of + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo { @@ -487,15 +503,10 @@ lookupIfaceByModule -> PackageIfaceTable -> Module -> Maybe ModIface -lookupIfaceByModule dflags hpt pit mod - | modulePackageId mod == thisPackage dflags - -- The module comes from the home package, so look first - -- in the HPT. If it's not from the home package it's wrong to look - -- in the HPT, because the HPT is indexed by *ModuleName* not Module - = fmap hm_iface (lookupUFM hpt (moduleName mod)) - `mplus` lookupModuleEnv pit mod - - | otherwise = lookupModuleEnv pit mod -- Look in PIT only +lookupIfaceByModule _dflags hpt pit mod + = case lookupHptByModule hpt mod of + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod -- If the module does come from the home package, why do we look in the PIT as well? -- (a) In OneShot mode, even home-package modules accumulate in the PIT @@ -1080,6 +1091,110 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) %* * %************************************************************************ +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type and class declarations at the command prompt are treated as if +they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactivePackageId, and +PrelNames.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at <interactive>:2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined. + +So the main invariant continues to hold, that in any session an original +name M.T only refers to oe unique thing. (In a previous iteration both +the T's above were called :Interactive.T, albeit with different uniques, +which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when + extend the HPT. + + * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -package-name says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get + to be in the 'interactive' package? By setting 'thisPackage' just + before the typecheck/rename step for command-line processing; + see the calls to HscTypes.setInteractivePackage in + HscMain.hscDeclsWithLocation and hscStmtWithLocation. + + * The main trickiness is that the type environment (tcg_type_env and + fixity envt (tcg_fix_env) now contains entities from all the + GhciN modules together, rather than just a single module as is usually + the case. So you can't use "nameIsLocalOrFrom" to decide whether + to look in the TcGblEnv vs the HPT/PTE. This is a change, but not + a problem provided you know. + + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds + b) with an Internal Name (not External) + c) and a tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) They start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. It would be possible subsequently to give + them an External Name (in a GhciN module) but then we'd have + to substitute it out. So for now they stay Internal. + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +However note that TyCons, Classes, and even Ids bound by other top-level +declarations in GHCi (eg foreign import, record selectors) currently get +External Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + + \begin{code} -- | Interactive context, recording information about the state of the -- context in which statements are executed in a GHC session. @@ -1089,28 +1204,33 @@ data InteractiveContext -- ^ The 'DynFlags' used to evaluate interative expressions -- and statements. - ic_monad :: Name, - -- ^ The monad that GHCi is executing in + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] - ic_imports :: [InteractiveImport], - -- ^ The GHCi context is extended with these imports + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with + -- these imports -- -- 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_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front) + -- See Note [ic_tythings] + ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The cached 'GlobalRdrEnv', built by -- 'InteractiveEval.setContext' and updated regularly -- It contains everything in scope at the command line, -- including everything in ic_tythings - ic_tythings :: [TyThing], - -- ^ TyThings defined by the user, in reverse order of - -- definition (ie most recent at the front) - -- See Note [ic_tythings] - ic_instances :: ([ClsInst], [FamInst]), -- ^ All instances and family instances created during -- this session. These are grabbed en masse after each @@ -1122,10 +1242,6 @@ data InteractiveContext ic_fix_env :: FixityEnv, -- ^ Fixities declared in let statements - ic_int_print :: Name, - -- ^ The function that is used for printing results - -- of expressions in ghci and -e mode. - ic_default :: Maybe [Type], -- ^ The current default types, set by a 'default' declaration @@ -1134,49 +1250,50 @@ data InteractiveContext -- ^ The stack of breakpoint contexts #endif - ic_cwd :: Maybe FilePath + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath -- virtual CWD of the program } -{- -Note [ic_tythings] -~~~~~~~~~~~~~~~~~~ -The ic_tythings field contains - * The TyThings declared by the user at the command prompt - (eg Ids, TyCons, Classes) - - * The user-visible Ids that arise from such things, which - *don't* come from 'implicitTyThings', notably: - - record selectors - - class ops - The implicitTyThings are readily obtained from the TyThings - but record selectors etc are not +data InteractiveImport + = IIDecl (ImportDecl RdrName) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope -It does *not* contain - * DFunIds (they can be gotten from ic_instances) - * CoAxioms (ditto) + | IIModule ModuleName + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. -See also Note [Interactively-bound Ids in GHCi] in TcRnDriver --} -- | Constructs an empty InteractiveContext. emptyInteractiveContext :: DynFlags -> InteractiveContext emptyInteractiveContext dflags - = InteractiveContext { ic_dflags = dflags, - -- IO monad by default - ic_monad = ioTyConName, - ic_imports = [], - ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_tythings = [], - ic_instances = ([],[]), - ic_fix_env = emptyNameEnv, - -- System.IO.print by default - ic_int_print = printName, - ic_default = Nothing, + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = Nothing, #ifdef GHCI - ic_resume = [], + ic_resume = [], #endif - ic_cwd = Nothing } + ic_cwd = Nothing } + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule index -- | This function returns the list of visible TyThings (useful for -- e.g. showBindings) @@ -1196,7 +1313,11 @@ icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = -- not clear whether removing them is even the appropriate behavior. extendInteractiveContext :: InteractiveContext -> [TyThing] -> InteractiveContext extendInteractiveContext ictxt new_tythings - = ictxt { ic_tythings = new_tythings ++ old_tythings + | null new_tythings + = ictxt + | otherwise + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ old_tythings , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } where @@ -1207,6 +1328,11 @@ extendInteractiveContext ictxt new_tythings new_names = [ nameOccName (getName id) | AnId id <- new_tythings ] +setInteractivePackage :: HscEnv -> HscEnv +-- Set the 'thisPackage' DynFlag to 'interactive' +setInteractivePackage hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageId } } + setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -1231,16 +1357,6 @@ substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id) subst_ty tt = tt -data InteractiveImport - = IIDecl (ImportDecl RdrName) - -- ^ Bring the exports of a particular module - -- (filtered by an import decl) into scope - - | IIModule ModuleName - -- ^ Bring into scope the entire top-level envt of - -- of this module, including the things imported - -- into it. - instance Outputable InteractiveImport where ppr (IIModule m) = char '*' <> ppr m ppr (IIDecl d) = ppr d @@ -1288,30 +1404,26 @@ the (ppr mod) of case (3), in Name.pprModulePrefix mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified dflags env = (qual_name, qual_mod) where - qual_name name - | [gre] <- unqual_gres, right_name gre = NameUnqual + qual_name mod occ + | [gre] <- unqual_gres + , right_name gre + = NameUnqual -- If there's a unique entity that's in scope unqualified with 'occ' -- AND that entity is the right one, then we can use the unqualified name - | [gre] <- qual_gres = NameQual (get_qual_mod (gre_prov gre)) + | [gre] <- qual_gres + = NameQual (get_qual_mod (gre_prov gre)) - | null qual_gres = - if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) - then NameNotInScope1 - else NameNotInScope2 + | null qual_gres + = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 - | otherwise = NameNotInScope1 -- Can happen if 'f' is bound twice in the module - -- Eg f = True; g = 0; f = False + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False where - mod = nameModule name - occ = nameOccName name - - is_rdr_orig = nameUnique name == mkUniqueGrimily 0 - -- Note [Outputable Orig RdrName] - - right_name gre - | is_rdr_orig = nameModule_maybe (gre_name gre) == Just mod - | otherwise = gre_name gre == name + right_name gre = nameModule_maybe (gre_name gre) == Just mod unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env qual_gres = filter right_name (lookupGlobalRdrEnv env occ) @@ -1335,25 +1447,6 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) | otherwise = True where lookup = lookupModuleInAllPackages dflags (moduleName mod) - --- Note [Outputable Orig RdrName] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- This is a Grotesque Hack. The Outputable instance for RdrEnv wants --- to print Orig names, which are just pairs of (Module,OccName). But --- we want to use full Names here, because in GHCi we might have Ids --- that have the same (Module,OccName) pair but a different Unique --- (this happens when you shadow a TyCon or Class in GHCi). --- --- So in Outputable RdrName we just use a dummy Unique (0), and check --- for it here. --- --- Arguably GHCi is invalidating the assumption that (Module,OccName) --- uniquely identifies an entity. But we do want to be able to shadow --- old declarations with new ones in GHCi, and it would be hard to --- delete all references to the old declaration when that happened. --- See also Note [interactive name cache] in IfaceEnv for somewhere --- else that this broken assumption bites. --- \end{code} @@ -1578,16 +1671,14 @@ lookupType :: DynFlags -> Maybe TyThing lookupType dflags hpt pte name - -- in one-shot, we don't use the HPT - | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg - = do hm <- lookupUFM hpt (moduleName mod) -- Maybe monad - x <- lookupNameEnv (md_types (hm_details hm)) name - return x - | otherwise + | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT = lookupNameEnv pte name + | otherwise + = case lookupHptByModule hpt mod of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name where mod = ASSERT2( isExternalName name, ppr name ) nameModule name - this_pkg = thisPackage dflags -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 53cf25117a..3f00c6242c 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -432,12 +432,9 @@ mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation - -- The ':xxx' makes a module name that the user can never - -- use himself. The z-encoding for ':' is "ZC", so the z-encoded - -- module name still starts with a capital letter, which keeps - -- the z-encoded version consistent. -iNTERACTIVE :: Module -iNTERACTIVE = mkMainModule (fsLit ":Interactive") +mkInteractiveModule :: Int -> Module +-- (mkInteractiveMoudule 9) makes module 'interactive:M9' +mkInteractiveModule n = mkModule interactivePackageId (mkModuleName ("Ghci" ++ show n)) pRELUDE_NAME, mAIN_NAME :: ModuleName pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c11cca0f1e..d29c3f3b9a 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -64,7 +64,7 @@ import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) import ErrUtils ( MsgDoc ) -import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence ) +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity ) import SrcLoc import Outputable import Util @@ -1136,17 +1136,18 @@ lookupFixityRn name -- where 'foo' is not in scope, should not give an error (Trac #7937) | otherwise - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name - then lookup_local - else lookup_imported } + = do { local_fix_env <- getFixityEnv + ; case lookupNameEnv local_fix_env name of { + Just (FixItem _ fix) -> return fix ; + Nothing -> + + do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name || isInteractiveModule (nameModule name) + -- Interactive modules are all in the fixity env, + -- and don't have entries in the HPT + then return defaultFixity + else lookup_imported } } } where - lookup_local -- It's defined in this module - = do { local_fix_env <- getFixityEnv - ; traceRn (text "lookupFixityRn: looking up name in local environment:" <+> - vcat [ppr name, ppr local_fix_env]) - ; return (lookupFixity local_fix_env name) } - lookup_imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 783823bd11..823123309b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -347,7 +347,7 @@ created by its bindings. Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in TcRnDriver +See also: Note [Interactively-bound Ids in GHCi] in HscTypes Consider a Template Haskell declaration quotation like this: module M where diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 62e45e02ec..3f895080a6 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -257,7 +257,7 @@ lintInteractiveExpr what hsc_env expr interactiveInScope :: HscEnv -> [Var] -- In GHCi we may lint expressions, or bindings arising from 'deriving' -- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in TcRnDriver). +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes). -- So we have to tell Lint about them, lest it reports them as out of scope. -- -- We do this by find local-named things that may appear free in interactive diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index ef47667dfe..88212415c4 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -244,10 +244,10 @@ tcExtendLocalFamInstEnv fam_insts thing_inside fam_insts ; let env' = env { tcg_fam_insts = fam_insts' , tcg_fam_inst_env = inst_env' } - ; setGblEnv env' thing_inside + ; setGblEnv env' thing_inside } --- Check that the proposed new instance is OK, +-- Check that the proposed new instance is OK, -- and then add it to the home inst env -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] -- in FamInstEnv.lhs @@ -258,10 +258,13 @@ addLocalFamInst (home_fie, my_fis) fam_inst = do { traceTc "addLocalFamInst" (ppr fam_inst) ; isGHCi <- getIsGHCi - + ; mod <- getModule + ; traceTc "alfi" (ppr mod $$ ppr isGHCi) + -- In GHCi, we *override* any identical instances -- that are also defined in the interactive context - ; let (home_fie', my_fis') + -- Trac #7102 + ; let (home_fie', my_fis') | isGHCi = ( deleteFromFamInstEnv home_fie fam_inst , filterOut (identicalFamInst fam_inst) my_fis) | otherwise = (home_fie, my_fis) @@ -276,9 +279,8 @@ addLocalFamInst (home_fie, my_fis) fam_inst ; no_conflict <- checkForConflicts inst_envs fam_inst ; if no_conflict then return (home_fie'', fam_inst : my_fis') - else + else return (home_fie, my_fis) } - \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 6be4772ab8..1ac649b77e 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -116,27 +116,24 @@ tcLookupGlobal :: Name -> TcM TyThing tcLookupGlobal name = do { -- Try local envt env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of { + ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; Nothing -> - - -- Should it have been in the local envt? - case nameModule_maybe name of { - Nothing -> notFound name ; -- Internal names can happen in GHCi - Just mod | mod == tcg_mod env -- Names from this module - -> notFound name -- should be in tcg_type_env - | otherwise -> do + -- Should it have been in the local envt? + if nameIsLocalOrFrom (tcg_mod env) name + then notFound name -- Internal names can happen in GHCi + else -- Try home package table and external package table - { mb_thing <- tcLookupImported_maybe name + do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing Failed msg -> failWithTc msg - }}}} + }}} tcLookupField :: Name -> TcM Id -- Returns the selector Id -tcLookupField name +tcLookupField name = tcLookupId name -- Note [Record field lookup] {- Note [Record field lookup] diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index e1ea4d32c5..59dc17501d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -124,34 +124,35 @@ tcRnModule hsc_env hsc_src save_rn_syntax parsedModule@HsParsedModule {hpm_module=L loc this_module} = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - let { this_pkg = thisPackage (hsc_dflags hsc_env) ; - pair@(this_mod,_) - = case hsmodName this_module of - Nothing -- 'module M where' is omitted - -> (mAIN, srcLocSpan (srcSpanStart loc)) + ; let { this_pkg = thisPackage (hsc_dflags hsc_env) + ; pair@(this_mod,_) + = case hsmodName this_module of + Nothing -- 'module M where' is omitted + -> (mAIN, srcLocSpan (srcSpanStart loc)) - Just (L mod_loc mod) -- The normal case - -> (mkModule this_pkg mod, mod_loc) } ; + Just (L mod_loc mod) -- The normal case + -> (mkModule this_pkg mod, mod_loc) } ; - initTc hsc_env hsc_src save_rn_syntax this_mod $ - tcRnModuleTcRnM hsc_env hsc_src parsedModule pair } + ; initTc hsc_env hsc_src save_rn_syntax this_mod $ + tcRnModuleTcRnM hsc_env hsc_src parsedModule pair } tcRnModuleTcRnM :: HscEnv -> HscSource -> HsParsedModule -> (Module, SrcSpan) -> TcRn TcGblEnv +-- Factored out separately so that a Core plugin can +-- call the type checker directly tcRnModuleTcRnM hsc_env hsc_src - (HsParsedModule { - hpm_module = - (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec - maybe_doc_hdr)), - hpm_src_files = - src_files - }) - (this_mod, prel_imp_loc) = - setSrcSpan loc $ + (HsParsedModule { + hpm_module = + (L loc (HsModule maybe_mod export_ies + import_decls local_decls mod_deprec + maybe_doc_hdr)), + hpm_src_files = src_files + }) + (this_mod, prel_imp_loc) + = setSrcSpan loc $ do { -- Deal with imports; first add implicit prelude implicit_prelude <- xoptM Opt_ImplicitPrelude; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc @@ -161,7 +162,7 @@ tcRnModuleTcRnM hsc_env hsc_src when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; + tcRnImports hsc_env (prel_imports ++ import_decls) ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add @@ -239,11 +240,11 @@ implicitPreludeWarn %************************************************************************ \begin{code} -tcRnImports :: HscEnv -> Module - -> [LImportDecl RdrName] -> TcM TcGblEnv -tcRnImports hsc_env this_mod import_decls +tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv +tcRnImports hsc_env import_decls = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; + ; this_mod <- getModule ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -269,7 +270,7 @@ tcRnImports hsc_env this_mod import_decls -- Update the gbl env ; updGblEnv ( \ gbl -> gbl { - tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, + tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, @@ -1439,24 +1440,11 @@ get two defns for 'main' in the interface file! %********************************************************* \begin{code} -setInteractiveContext :: HscEnv -> TcRn a -> TcRn a -setInteractiveContext hsc_env thing_inside - = let -- Initialise the tcg_inst_env with instances from all home modules. - -- This mimics the more selective call to hptInstances in tcRnImports - icxt = hsc_IC hsc_env - (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) - (ic_insts, ic_finsts) = ic_instances icxt - ty_things = ic_tythings icxt - - type_env1 = mkTypeEnvWithImplicits ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) - -- Putting the dfuns in the type_env is just - -- to keep Core Lint happy - - con_fields = [ (dataConName c, dataConFieldLabels c) - | ATyCon t <- ic_tythings icxt - , c <- tyConDataCons t ] - in +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a) +-- Initialise the tcg_inst_env with instances from all home modules. +-- This mimics the more selective call to hptInstances in tcRnImports +runTcInteractive hsc_env thing_inside + = initTcInteractive hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) @@ -1487,6 +1475,22 @@ setInteractiveContext hsc_env thing_inside ; setGblEnv gbl_env' $ tcExtendGhciIdEnv ty_things $ -- See Note [Initialising the type environment for GHCi] thing_inside } -- in TcEnv + where + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) + + icxt = hsc_IC hsc_env + (ic_insts, ic_finsts) = ic_instances icxt + ty_things = ic_tythings icxt + + type_env1 = mkTypeEnvWithImplicits ty_things + type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) + -- Putting the dfuns in the type_env + -- is just to keep Core Lint happy + + con_fields = [ (dataConName c, dataConFieldLabels c) + | ATyCon t <- ty_things + , c <- tyConDataCons t ] + #ifdef GHCI -- | The returned [Id] is the list of new Ids bound by this statement. It can @@ -1497,8 +1501,7 @@ setInteractiveContext hsc_env thing_inside tcRnStmt :: HscEnv -> GhciLStmt RdrName -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) tcRnStmt hsc_env rdr_stmt - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ do { + = runTcInteractive hsc_env $ do { -- The real work is done here ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; @@ -1511,7 +1514,7 @@ tcRnStmt hsc_env rdr_stmt traceTc "tcs 1" empty ; let { global_ids = map globaliseAndTidyId zonked_ids } ; - -- Note [Interactively-bound Ids in GHCi] + -- Note [Interactively-bound Ids in GHCi] in HscTypes {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; @@ -1543,29 +1546,6 @@ tcRnStmt hsc_env rdr_stmt nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) \end{code} -Note [Interactively-bound Ids in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Ids bound by previous Stmts in GHCi are currently - a) GlobalIds - b) with an Internal Name (not External) - c) and a tidied type - - (a) They must be GlobalIds (not LocalIds) otherwise when we come to - compile an expression using these ids later, the byte code - generator will consider the occurrences to be free rather than - global. - - (b) They retain their Internal names because we don't have a suitable - Module to name them with. We could revisit this choice. - - (c) Their types are tidied. This is important, because :info may ask - to look at them, and :info expects the things it looks up to have - tidy types - -However note that TyCons, Classes, and even Ids bound by other top-level -declarations in GHCi (eg foreign import, record selectors) currently get -External Names, with :INTERACTIVE as the module name. This seems -totally inconsistent to me. -------------------------------------------------------------------------- Typechecking Stmts in GHCi @@ -1605,11 +1585,11 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the -- GHCi 'environemnt'. -- --- By 'lift' and 'environment we mean that the code is changed to execute --- properly in an IO monad. See Note [Interactively-bound Ids in GHCi] above --- for more details. We do this lifting by trying different ways ('plans') of --- lifting the code into the IO monad and type checking each plan until one --- succeeds. +-- By 'lift' and 'environment we mean that the code is changed to +-- execute properly in an IO monad. See Note [Interactively-bound Ids +-- in GHCi] in HscTypes for more details. We do this lifting by trying +-- different ways ('plans') of lifting the code into the IO monad and +-- type checking each plan until one succeeds. tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially @@ -1776,8 +1756,7 @@ getGhciStepIO = do isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) isGHCiMonad hsc_env ty - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ do + = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) case occIO of @@ -1802,8 +1781,7 @@ tcRnExpr :: HscEnv -> IO (Messages, Maybe Type) -- Type checks the expression and returns its most general type tcRnExpr hsc_env rdr_expr - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ do { + = runTcInteractive hsc_env $ do { (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; @@ -1830,10 +1808,15 @@ tcRnExpr hsc_env rdr_expr tcRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO (Messages, Maybe GlobalRdrEnv) +-- Find the new chunk of GlobalRdrEnv created by this list of import +-- decls. In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls - = initTcPrintErrors hsc_env iNTERACTIVE $ - do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls + = runTcInteractive hsc_env $ + do { gbl_env <- updGblEnv zap_rdr_env $ + tcRnImports hsc_env import_decls ; return (tcg_rdr_env gbl_env) } + where + zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } \end{code} tcRnType just finds the kind of a type @@ -1844,8 +1827,7 @@ tcRnType :: HscEnv -> LHsType RdrName -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env normalise rdr_type - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ + = runTcInteractive hsc_env $ setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType] do { (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ; failIfErrsM @@ -1889,8 +1871,7 @@ tcRnDeclsi :: HscEnv -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = - initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ do + runTcInteractive hsc_env $ do ((tcg_env, tclcl_env), lie) <- captureConstraints $ tc_rn_src_decls emptyModDetails local_decls @@ -1940,13 +1921,12 @@ tcRnDeclsi hsc_env local_decls = -- could not be found. getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) getModuleInterface hsc_env mod - = initTc hsc_env HsSrcFile False iNTERACTIVE $ + = runTcInteractive hsc_env $ loadModuleInterface (ptext (sLit "getModuleInterface")) mod tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ + = runTcInteractive hsc_env $ lookup_rdr_name rdr_name lookup_rdr_name :: RdrName -> TcM [Name] @@ -1981,8 +1961,7 @@ lookup_rdr_name rdr_name = do tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ + = runTcInteractive hsc_env $ tcRnLookupName' name -- To look up a name we have to look in the local environment (tcl_lcl) @@ -2009,19 +1988,17 @@ tcRnGetInfo :: HscEnv -- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env name - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env $ do - - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) - loadUnqualIfaces hsc_env (hsc_IC hsc_env) - - thing <- tcRnLookupName' name - fixity <- lookupFixityRn name - (cls_insts, fam_insts) <- lookupInsts thing - return (thing, fixity, cls_insts, fam_insts) + = runTcInteractive hsc_env $ + do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + + ; thing <- tcRnLookupName' name + ; fixity <- lookupFixityRn name + ; (cls_insts, fam_insts) <- lookupInsts thing + ; return (thing, fixity, cls_insts, fam_insts) } lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) lookupInsts (ATyCon tc) @@ -2057,13 +2034,16 @@ loadUnqualIfaces hsc_env ictxt where this_pkg = thisPackage (hsc_dflags hsc_env) - unqual_mods = filter ((/= this_pkg) . modulePackageId) - [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), - let name = gre_name gre, - not (isInternalName name), - isTcOcc (nameOccName name), -- Types and classes only - unQualOK gre ] -- In scope unqualified + unqual_mods = [ mod + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt) + , let name = gre_name gre + , not (isInternalName name) + , let mod = nameModule name + , not (modulePackageId mod == this_pkg || isInteractiveModule mod) + -- Don't attempt to load an interface for stuff + -- from the command line, or from the home package + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index d5a9383d56..c5c1c30e3d 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -199,17 +199,21 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this return (msgs, final_res) } -initTcPrintErrors -- Used from the interactive loop only - :: HscEnv - -> Module - -> TcM r - -> IO (Messages, Maybe r) -initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo +initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a) +-- Initialise the type checker monad for use in GHCi +initTcInteractive hsc_env thing_inside + = initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) + thing_inside initTcForLookup :: HscEnv -> TcM a -> IO a -initTcForLookup hsc_env tcm - = do (msgs, m) <- initTc hsc_env HsSrcFile False iNTERACTIVE tcm +-- The thing_inside is just going to look up something +-- in the environment, so we don't need much setup +initTcForLookup hsc_env thing_inside + = do (msgs, m) <- initTc hsc_env HsSrcFile False + (icInteractiveModule (hsc_IC hsc_env)) -- Irrelevant really + thing_inside case m of Nothing -> throwIO $ mkSrcErr $ snd msgs Just x -> return x @@ -518,7 +522,8 @@ setModule :: Module -> TcRn a -> TcRn a setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside getIsGHCi :: TcRn Bool -getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } +getIsGHCi = do { mod <- getModule + ; return (isInteractiveModule mod) } getGHCiMonad :: TcRn Name getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 1ad567eaa2..052403c675 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -216,6 +216,7 @@ data TcGblEnv tcg_fix_env :: FixityEnv, -- ^ Just for things in this module tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module + -- See Note [The interactive package] in HscTypes tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All @@ -224,6 +225,9 @@ data TcGblEnv -- -- (Ids defined in this module start in the local envt, though they -- move to the global envt during zonking) + -- + -- NB: for what "things in this module" means, see + -- Note [The interactive package] in HscTypes tcg_type_env_var :: TcRef TypeEnv, -- Used only to initialise the interface-file diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 100ed341be..b6186b8d6f 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1110,15 +1110,18 @@ tcLookupTh name = do { (gbl_env, lcl_env) <- getEnvs ; case lookupNameEnv (tcl_env lcl_env) name of { Just thing -> return thing; - Nothing -> do - { if nameIsLocalOrFrom (tcg_mod gbl_env) name + Nothing -> + + case lookupNameEnv (tcg_type_env gbl_env) name of { + Just thing -> return (AGlobal thing); + Nothing -> + + if nameIsLocalOrFrom (tcg_mod gbl_env) name then -- It's defined in this module - case lookupNameEnv (tcg_type_env gbl_env) name of - Just thing -> return (AGlobal thing) - Nothing -> failWithTc (notInEnv name) + failWithTc (notInEnv name) - else do -- It's imported - { mb_thing <- tcLookupImported_maybe name + else + do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) Failed msg -> failWithTc msg diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index adf75bc92a..01375a3b90 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -47,6 +47,7 @@ import Coercion import CoAxiom import VarSet import VarEnv +import Module( isInteractiveModule ) import Name import UniqFM import Outputable @@ -353,6 +354,7 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) add (FamIE items) _ = FamIE (ins_item:items) deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +-- Used only for overriding in GHCi deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) = adjustUFM adjust inst_env fam_nm where @@ -361,13 +363,14 @@ deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) = FamIE (filterOut (identicalFamInst fam_inst) items) identicalFamInst :: FamInst -> FamInst -> Bool --- Same LHS, *and* the instance is defined in the same module +-- Same LHS, *and* both instances are on the interactive command line -- Used for overriding in GHCi identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) - = nameModule (coAxiomName ax1) == nameModule (coAxiomName ax2) - && coAxiomTyCon ax1 == coAxiomTyCon ax2 - && brListLength brs1 == brListLength brs2 - && and (brListZipWith identical_ax_branch brs1 brs2) + = isInteractiveModule (nameModule (coAxiomName ax1)) + && isInteractiveModule (nameModule (coAxiomName ax2)) + && coAxiomTyCon ax1 == coAxiomTyCon ax2 + && brListLength brs1 == brListLength brs2 + && and (brListZipWith identical_ax_branch brs1 brs2) where brs1 = coAxiomBranches ax1 brs2 = coAxiomBranches ax2 identical_ax_branch br1 br2 diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index f357208077..9cf8c33d46 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -53,7 +53,9 @@ module Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, + PprStyle, CodeStyle(..), PrintUnqualified, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, QualifyName(..), sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, @@ -75,7 +77,7 @@ import {-# SOURCE #-} DynFlags( DynFlags, useUnicodeQuotes, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) -import {-# SOURCE #-} Name( Name, nameModule ) +import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) import FastString @@ -145,13 +147,20 @@ data Depth = AllTheWay -- purpose of the pair of functions that gets passed around -- when rendering 'SDoc'. +type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) + -- | given an /original/ name, this function tells you which module -- name it should be qualified with when printing for the user, if -- any. For example, given @Control.Exception.catch@, which is in scope -- as @Exception.catch@, this fuction will return @Just "Exception"@. -- Note that the return value is a ModuleName, not a Module, because -- in source code, names are qualified by ModuleNames. -type QueryQualifyName = Name -> QualifyName +type QueryQualifyName = Module -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + -- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T @@ -164,18 +173,11 @@ data QualifyName -- given P:M.T -- it is not in scope at all, and M.T is already bound in the -- current scope, so we must refer to it as "P:M.T" - --- | For a given module, we need to know whether to print it with --- a package name to disambiguate it. -type QueryQualifyModule = Module -> Bool - -type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) - alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames n = NameQual (moduleName (nameModule n)) +alwaysQualifyNames m _ = NameQual (moduleName m) neverQualifyNames :: QueryQualifyName -neverQualifyNames _ = NameUnqual +neverQualifyNames _ _ = NameUnqual alwaysQualifyModules :: QueryQualifyModule alwaysQualifyModules _ = True @@ -296,8 +298,8 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \begin{code} qualName :: PprStyle -> QueryQualifyName -qualName (PprUser (qual_name,_) _) n = qual_name n -qualName _other n = NameQual (moduleName (nameModule n)) +qualName (PprUser (qual_name,_) _) mod occ = qual_name mod occ +qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser (_,qual_mod) _) m = qual_mod m |