From 28122dd6e891a440493edef9795d68d3f3c2af46 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 29 Apr 2005 23:39:13 +0000 Subject: [PATCH] [project @ 2005-04-29 23:39:12 by simonpj] Wibbles to new hs-boot instance story --- ghc/compiler/basicTypes/SrcLoc.lhs | 8 +++++++- ghc/compiler/ghci/InteractiveUI.hs | 7 ++----- ghc/compiler/main/HscMain.lhs | 7 +------ ghc/compiler/typecheck/TcRnDriver.lhs | 18 +++++++++++------- ghc/compiler/types/InstEnv.lhs | 3 ++- 5 files changed, 23 insertions(+), 20 deletions(-) diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 1fc1172..a8d037c 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -23,7 +23,7 @@ module SrcLoc ( srcLocFile, -- return the file name part srcLocLine, -- return the line part srcLocCol, -- return the column part - + pprDefnLoc, SrcSpan, -- Abstract noSrcSpan, @@ -304,6 +304,12 @@ combineSrcSpans start end col2 = srcSpanEndCol end file = srcSpanFile start +pprDefnLoc :: SrcLoc -> SDoc +-- "defined at ..." or "imported from ..." +pprDefnLoc loc + | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc + | otherwise = ppr loc + instance Outputable SrcSpan where ppr span = getPprStyle $ \ sty -> diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index eac04fe..6040404 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -27,7 +27,7 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart, pprIfaceType ) import FunDeps ( pprFundeps ) -import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import SrcLoc ( SrcLoc, pprDefnLoc ) import OccName ( OccName, parenSymOcc, occNameUserString ) import BasicTypes ( StrictnessMark(..), defaultFixity ) @@ -538,12 +538,9 @@ showThing exts (wanted_str, thing, fixity, src_loc, insts) showWithLoc :: SrcLoc -> SDoc -> SDoc showWithLoc loc doc - = hang doc 2 (char '\t' <> show_loc loc) + = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc) -- The tab tries to make them line up a bit where - show_loc loc -- The ppr function for SrcLocs is a bit wonky - | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc - | otherwise = comment <+> ppr loc comment = ptext SLIT("--") diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 13af006..4e826e1 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -364,15 +364,10 @@ hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change - ; let { final_details = ModDetails { md_types = mg_types ds_result, - md_exports = mg_exports ds_result, - md_insts = mg_insts ds_result, - md_rules = mg_rules ds_result } } -- And the answer is ... ; dumpIfaceStats hsc_env - ; return (HscRecomp final_details - new_iface + ; return (HscRecomp details new_iface False False Nothing) } diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index b7ea93e..44964ec 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -63,7 +63,7 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) +import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv ) import OccName ( mkVarOcc ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName ) import NameSet @@ -109,6 +109,7 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), import IfaceType ( IfaceType, toIfaceType, interactiveExtNameFun ) import IfaceEnv ( lookupOrig, ifaceExportNames ) +import Module ( lookupModuleEnv ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( isImplicitId, setIdType, globalIdDetails, mkExportedLocalId ) import MkId ( unsafeCoerceId ) @@ -176,11 +177,14 @@ tcRnModule hsc_env hsc_src save_rn_decls let { dep_mods :: ModuleEnv (Module, IsBootInterface) ; dep_mods = imp_dep_mods imports - ; is_dep_mod :: Module -> Bool - ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of - Nothing -> False - Just (_, is_boot) -> not is_boot - ; home_insts = hptInstances hsc_env is_dep_mod + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file + ; want_instances :: Module -> Bool + ; want_instances mod = mod `elemModuleEnv` dep_mods + && mod /= this_mod + ; home_insts = hptInstances hsc_env want_instances } ; -- Record boot-file info in the EPS, so that it's @@ -587,7 +591,7 @@ missingBootThing thing bootMisMatch thing = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") instMisMatch inst - = hang (ptext SLIT("instance") <+> ppr inst) + = hang (ppr inst) 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) \end{code} diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index cd06611..2ed8309 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -37,6 +37,7 @@ import Unify ( tcMatchTys, tcUnifyTys, BindFlag(..) ) import Outputable import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) import Id ( idType, idName ) +import SrcLoc ( pprDefnLoc ) import Maybe ( isJust, isNothing ) \end{code} @@ -154,7 +155,7 @@ pprInstance :: Instance -> SDoc pprInstance ispec@(Instance { is_flag = flag }) = hang (ptext SLIT("instance") <+> ppr flag <+> sep [pprThetaArrow theta, pprClassPred clas tys]) - 2 (ppr (getSrcLoc ispec)) + 2 (parens (pprDefnLoc (getSrcLoc ispec))) where (_, theta, clas, tys) = instanceHead ispec -- Print without the for-all, which the programmer doesn't write -- 1.7.10.4