[project @ 2001-03-20 12:30:46 by simonpj]

Fix orphan calculation (again)

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 27d6aef..45828c7 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -50,7 +50,7 @@ import TyCon          ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyCo
                        )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
-import Type            ( splitSigmaTy, tidyTopType, deNoteType, namesOfType )
+import Type            ( splitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
 import SrcLoc          ( noSrcLoc )
 import Outputable
 import Module          ( ModuleName )
@@ -131,15 +131,9 @@ write_diffs dflags new_iface (Just sdoc_diffs)
 isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
   = any orphan_inst insts || any orphan_rule rules
   where
-    orphan_inst dfun_id = no_locals (namesOfType (dfun_head_type dfun_id))
+    orphan_inst dfun_id = no_locals (namesOfDFunHead (idType dfun_id))
     orphan_rule rule    = no_locals (ruleLhsFreeNames rule)
     no_locals names     = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
-    dfun_head_type dfun        = case splitSigmaTy (idType dfun) of
-                               (_,_,head_ty) -> head_ty
-       -- The 'dfun_head_type' is because of
-       --      instance Foo a => Baz T where ...
-       -- The decl is an orphan if Baz and T are both not locally defined,
-       --      even if Foo *is* locally defined
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index d4c14a9..643d558 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -68,6 +68,7 @@ module Type (
        -- Free variables
        tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
        namesOfType, usageAnnOfType, typeKind, addFreeTyVars,
+       namesOfDFunHead,
 
        -- Tidying up for printing
        tidyType,     tidyTypes,
@@ -767,6 +768,17 @@ splitDFunTy ty
     case splitDictTy tau of { (clas, tys) ->
     (tvs, theta, clas, tys) }}
 
+namesOfDFunHead :: Type -> NameSet
+-- Find the free type constructors and classes 
+-- of the head of the dfun instance type
+-- The 'dfun_head_type' is because of
+--     instance Foo a => Baz T where ...
+-- The decl is an orphan if Baz and T are both not locally defined,
+--     even if Foo *is* locally defined
+namesOfDFunHead dfun_ty = case splitSigmaTy dfun_ty of
+                               (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
+                                                                     (map getName tvs)
+
 mkPredName :: Unique -> SrcLoc -> PredType -> Name
 mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
 mkPredName uniq loc (IParam name ty) = name