Tidy up SigTv

[ghc-hetmet.git] / compiler / typecheck / TcType.lhs

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 3ea53e8..d9166d1 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -61,7 +61,7 @@ module TcType (
   ---------------------------------
   -- Misc type manipulators
   deNoteType,
   ---------------------------------
   -- Misc type manipulators
   deNoteType,

-  tyClsNamesOfType, tyClsNamesOfDFunHead, 
+  orphNamesOfType, orphNamesOfDFunHead, 

   getDFunTyKey,
 
   ---------------------------------
   getDFunTyKey,
 
   ---------------------------------

@@ -306,14 +306,12 @@ data MetaInfo
                   -- A TauTv is always filled in with a tau-type, which
                   -- never contains any ForAlls 
 
                   -- 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
                   -- 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"
 
    | 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
 \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)
 
 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
        -- 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 )
        
 isSkolemTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )

@@ -583,8 +581,8 @@ isSigTyVar :: Var -> Bool
 isSigTyVar tv 
   = ASSERT( isTcTyVar tv )
     case tcTyVarDetails tv of
 isSigTyVar tv 
   = ASSERT( isTcTyVar tv )
     case tcTyVarDetails tv of

-       MetaTv (SigTv _) _ -> True
-       _                  -> False
+       MetaTv SigTv _ -> True
+       _              -> False

 
 metaTvRef :: TyVar -> IORef MetaDetails
 metaTvRef tv 
 
 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 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
 
     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}
 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
 -- 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
   = case tcSplitSigmaTy dfun_ty of

-       (_, _, head_ty) -> tyClsNamesOfType head_ty
+       (_, _, head_ty) -> orphNamesOfType head_ty

 \end{code}
 
 
 \end{code}