Basic set up for global family instance environment

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

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index a382808..94ea3f9 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -169,7 +169,8 @@ import Type         (       -- Re-exports
                          pprType, pprParendType, pprTyThingCategory,
                          pprPred, pprTheta, pprThetaArrow, pprClassPred
                        )
-import TyCon           ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
+import TyCon           ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon,
+                         synTyConDefn, tyConUnique )    
 import DataCon         ( DataCon, dataConStupidTheta, dataConResTys )
 import Class           ( Class )
 import Var             ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
@@ -343,6 +344,7 @@ data SkolemInfo
        -- The rest are for non-scoped skolems
   | ClsSkol Class      -- Bound at a class decl
   | InstSkol Id                -- Bound at an instance decl
+  | FamInstSkol TyCon  -- Bound at a family instance decl
   | PatSkol DataCon    -- An existential type variable bound by a pattern for
            SrcSpan     -- a data constructor with an existential type. E.g.
                        --      data T = forall a. Eq a => MkT a
@@ -485,8 +487,13 @@ pprSkolTvBinding tv
 pprSkolInfo :: SkolemInfo -> SDoc
 pprSkolInfo (SigSkol ctxt)   = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
 pprSkolInfo (ClsSkol cls)    = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo (InstSkol df)    = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
-pprSkolInfo (ArrowSkol loc)  = ptext SLIT("is bound by the arrow form at") <+> ppr loc
+pprSkolInfo (InstSkol df)    = 
+  ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
+pprSkolInfo (FamInstSkol tc) = 
+  ptext SLIT("is bound by the family instance declaration at") <+> 
+  ppr (getSrcLoc tc)
+pprSkolInfo (ArrowSkol loc)  = 
+  ptext SLIT("is bound by the arrow form at") <+> ppr loc
 pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
                                    nest 2 (ptext SLIT("at") <+> ppr loc)]
 pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), 
@@ -591,8 +598,9 @@ isTauTy other                 = False
 
 isTauTyCon :: TyCon -> Bool
 -- Returns False for type synonyms whose expansion is a polytype
-isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc))
-             | otherwise     = True
+isTauTyCon tc 
+  | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc))
+  | otherwise                             = True
 
 ---------------
 isBoxyTy :: TcType -> Bool