From: simonpj <unknown>
Date: Tue, 20 Mar 2001 12:30:46 +0000 (+0000)
Subject: [project @ 2001-03-20 12:30:46 by simonpj]
X-Git-Tag: Approximately_9120_patches~2364
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=77057e6adbe729f65ab827dbe238d3ac8c25a13a;p=ghc-hetmet.git

[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
--- 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
--- 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