X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=cd4c4c71bc0feba06d15280771bd954bde0567fe;hb=4a8695c5772772ccf9a688d82a9ce4f772c2ad20;hp=a3828082e387d9bbdb048c678dfd0d792101d37d;hpb=0b86bc9b022a5965d2b35f143ff4b919f784e676;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index a382808..cd4c4c7 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -1,4 +1,4 @@
-
+%
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcType]{Types used in the typechecker}
@@ -10,7 +10,7 @@ compiler.  These parts
 		newtypes, and predicates are meaningful. 
 	* look through usage types
 
-The "tc" prefix is for "typechechecker", because the type checker
+The "tc" prefix is for "TypeChecker", because the type checker
 is the principal client.
 
 \begin{code}
@@ -68,7 +68,7 @@ module TcType (
   isClassPred, isTyVarClassPred, isEqPred, 
   mkDictTy, tcSplitPredTy_maybe, 
   isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, 
-  mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
+  mkClassPred, isInheritablePred, isIPPred, mkPredName, 
   dataConsStupidTheta, isRefineableTy,
 
   ---------------------------------
@@ -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 )
@@ -185,7 +186,7 @@ import VarEnv		( TidyEnv )
 import OccName		( OccName, mkDictOcc, mkOccName, tvName )
 import PrelNames	-- Lots (e.g. in isFFIArgumentTy)
 import TysWiredIn	( unitTyCon, charTyCon, listTyCon )
-import BasicTypes	( IPName(..), Arity, ipNameName )
+import BasicTypes	( Arity, ipNameName )
 import SrcLoc		( SrcLoc, SrcSpan )
 import Util		( equalLength )
 import Maybes		( maybeToBool, expectJust, mapCatMaybes )
@@ -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
@@ -397,6 +399,7 @@ mkKindName unique = mkSystemName unique kind_var_occ
 
 kindVarRef :: KindVar -> IORef MetaDetails
 kindVarRef tc = 
+  ASSERT ( isTcTyVar tc )
   case tcTyVarDetails tc of
     MetaTv TauTv ref -> ref
     other            -> pprPanic "kindVarRef" (ppr tc)
@@ -470,7 +473,8 @@ pprSkolTvBinding :: TcTyVar -> SDoc
 -- Print info about the binding of a skolem tyvar, 
 -- or nothing if we don't have anything useful to say
 pprSkolTvBinding tv
-  = ppr_details (tcTyVarDetails tv)
+  = ASSERT ( isTcTyVar tv )
+    ppr_details (tcTyVarDetails tv)
   where
     ppr_details (MetaTv TauTv _)   = quotes (ppr tv) <+> ptext SLIT("is a meta type variable")
     ppr_details (MetaTv BoxTv _)   = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable")
@@ -485,8 +489,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 +600,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
@@ -688,10 +698,14 @@ tcMultiSplitSigmaTy sigma
 
 -----------------------
 tcTyConAppTyCon :: Type -> TyCon
-tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
+tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
+			Just (tc, _) -> tc
+			Nothing	     -> pprPanic "tcTyConAppTyCon" (pprType ty)
 
 tcTyConAppArgs :: Type -> [Type]
-tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
+tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
+			Just (_, args) -> args
+			Nothing	       -> pprPanic "tcTyConAppArgs" (pprType ty)
 
 tcSplitTyConApp :: Type -> (TyCon, [Type])
 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
@@ -881,10 +895,6 @@ isInheritablePred :: PredType -> Bool
 -- which can be free in g's rhs, and shared by both calls to g
 isInheritablePred (ClassP _ _) = True
 isInheritablePred other	     = False
-
-isLinearPred :: TcPredType -> Bool
-isLinearPred (IParam (Linear n) _) = True
-isLinearPred other		   = False
 \end{code}
 
 --------------------- Equality predicates ---------------------------------