X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=d9166d1c58c68c2c588f90d72b681f36d218942e;hp=3ea53e81fde31f7fdce90d462bc6f3d12555e6bc;hb=35a1ec430a5e44a9bc79d385b997422c20cb427b;hpb=27310213397bb89555bb03585e057ba1b017e895

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 3ea53e8..d9166d1 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -61,7 +61,7 @@ module TcType (
   ---------------------------------
   -- Misc type manipulators
   deNoteType,
-  tyClsNamesOfType, tyClsNamesOfDFunHead, 
+  orphNamesOfType, orphNamesOfDFunHead, 
   getDFunTyKey,
 
   ---------------------------------
@@ -306,14 +306,12 @@ data MetaInfo
      		   -- A TauTv is always filled in with a tau-type, which
 		   -- never contains any ForAlls 
 
-   | SigTv Name	   -- A variant of TauTv, except that it should not be
+   | SigTv 	   -- A variant of TauTv, except that it should not be
 		   -- unified with a type, only with a type variable
 		   -- SigTvs are only distinguished to improve error messages
 		   --      see Note [Signature skolems]        
 		   --      The MetaDetails, if filled in, will 
 		   --      always be another SigTv or a SkolemTv
-		   -- The Name is the name of the function from whose
-		   -- type signature we got this skolem
 
    | TcsTv	   -- A MetaTv allocated by the constraint solver
      		   -- Its particular property is that it is always "touchable"
@@ -392,12 +390,12 @@ kind_var_occ = mkOccName tvName "k"
 \begin{code}
 pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 -- For debugging
-pprTcTyVarDetails (SkolemTv {})        = ptext (sLit "sk")
-pprTcTyVarDetails (RuntimeUnk {})      = ptext (sLit "rt")
-pprTcTyVarDetails (FlatSkol {})        = ptext (sLit "fsk")
-pprTcTyVarDetails (MetaTv TauTv _)     = ptext (sLit "tau")
-pprTcTyVarDetails (MetaTv TcsTv _)     = ptext (sLit "tcs")
-pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
+pprTcTyVarDetails (SkolemTv {})    = ptext (sLit "sk")
+pprTcTyVarDetails (RuntimeUnk {})  = ptext (sLit "rt")
+pprTcTyVarDetails (FlatSkol {})    = ptext (sLit "fsk")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
+pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
 
 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 pprUserTypeCtxt (FunSigCtxt n)  = ptext (sLit "the type signature for") <+> quotes (ppr n)
@@ -552,8 +550,8 @@ isTyConableTyVar tv
 	-- not a SigTv
   = ASSERT( isTcTyVar tv) 
     case tcTyVarDetails tv of
-	MetaTv (SigTv _) _ -> False
-	_                  -> True
+	MetaTv SigTv _ -> False
+	_              -> True
 	
 isSkolemTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )
@@ -583,8 +581,8 @@ isSigTyVar :: Var -> Bool
 isSigTyVar tv 
   = ASSERT( isTcTyVar tv )
     case tcTyVarDetails tv of
-	MetaTv (SigTv _) _ -> True
-	_                  -> False
+	MetaTv SigTv _ -> True
+	_              -> False
 
 metaTvRef :: TyVar -> IORef MetaDetails
 metaTvRef tv 
@@ -1162,13 +1160,13 @@ exactTyVarsOfType ty
   = go ty
   where
     go ty | Just ty' <- tcView ty = go ty'	-- This is the key line
-    go (TyVarTy tv)         	  = unitVarSet tv
-    go (TyConApp _ tys)     	  = exactTyVarsOfTypes tys
-    go (PredTy ty)	    	  = go_pred ty
-    go (FunTy arg res)	    	  = go arg `unionVarSet` go res
-    go (AppTy fun arg)	    	  = go fun `unionVarSet` go arg
-    go (ForAllTy tyvar ty)  	  = delVarSet (go ty) tyvar
-                                    `unionVarSet` go_tv tyvar
+    go (TyVarTy tv)         = unitVarSet tv
+    go (TyConApp _ tys)     = exactTyVarsOfTypes tys
+    go (PredTy ty)	    = go_pred ty
+    go (FunTy arg res)	    = go arg `unionVarSet` go res
+    go (AppTy fun arg)	    = go fun `unionVarSet` go arg
+    go (ForAllTy tyvar ty)  = delVarSet (go ty) tyvar
+                              `unionVarSet` go_tv tyvar
 
     go_pred (IParam _ ty)    = go ty
     go_pred (ClassP _ tys)   = exactTyVarsOfTypes tys
@@ -1185,29 +1183,34 @@ Find the free tycons and classes of a type.  This is used in the front
 end of the compiler.
 
 \begin{code}
-tyClsNamesOfType :: Type -> NameSet
-tyClsNamesOfType (TyVarTy _)		    = emptyNameSet
-tyClsNamesOfType (TyConApp tycon tys)	    = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (PredTy (IParam _ ty))     = tyClsNamesOfType ty
-tyClsNamesOfType (PredTy (ClassP cl tys))   = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (PredTy (EqPred ty1 ty2))  = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
-tyClsNamesOfType (FunTy arg res)	    = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
-tyClsNamesOfType (AppTy fun arg)	    = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
-tyClsNamesOfType (ForAllTy _ ty)	    = tyClsNamesOfType ty
-
-tyClsNamesOfTypes :: [Type] -> NameSet
-tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
-
-tyClsNamesOfDFunHead :: Type -> NameSet
+orphNamesOfType :: Type -> NameSet
+orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
+		-- Look through type synonyms (Trac #4912)
+orphNamesOfType (TyVarTy _)		   = emptyNameSet
+orphNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) 
+                                             `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (IParam _ ty))    = orphNamesOfType ty
+orphNamesOfType (PredTy (ClassP cl tys))  = unitNameSet (getName cl) 
+                                            `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1 
+                                            `unionNameSets` orphNamesOfType ty2
+orphNamesOfType (FunTy arg res)	    = orphNamesOfType arg `unionNameSets` orphNamesOfType res
+orphNamesOfType (AppTy fun arg)	    = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
+orphNamesOfType (ForAllTy _ ty)	    = orphNamesOfType ty
+
+orphNamesOfTypes :: [Type] -> NameSet
+orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
+
+orphNamesOfDFunHead :: 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
-tyClsNamesOfDFunHead dfun_ty 
+orphNamesOfDFunHead dfun_ty 
   = case tcSplitSigmaTy dfun_ty of
-	(_, _, head_ty) -> tyClsNamesOfType head_ty
+	(_, _, head_ty) -> orphNamesOfType head_ty
 \end{code}