[project @ 2005-04-29 23:39:12 by simonpj]

Wibbles to new hs-boot instance story

diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index 1fc1172..a8d037c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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