X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=662dd6f993d1e62e3407373baa05c2241013d1d5;hb=de7ec7f188c0abfde6d50d5e7501618cc3f715ff;hp=8c969226d8db098008a491c55e318c7bbc73eace;hpb=d831632bcfbee58a1951b1880ce1a07b70d21ecc;p=ghc-hetmet.git

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 8c96922..662dd6f 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -55,7 +55,7 @@ module Type (
 	splitTyConApp_maybe, splitTyConApp, 
         splitNewTyConApp_maybe, splitNewTyConApp,
 
-	repType, repType', typePrimRep, coreView, tcView, kindView,
+	repType, typePrimRep, coreView, tcView, kindView, rttiView,
 
 	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
 	applyTy, applyTys, isForAllTy, dropForAlls,
@@ -67,8 +67,8 @@ module Type (
 	newTyConInstRhs,
 
 	-- Lifting and boxity
-	isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
-	isStrictType, isStrictPred, 
+	isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
+	isPrimitiveType, isStrictType, isStrictPred, 
 
 	-- Free variables
 	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
@@ -190,6 +190,18 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
 tcView ty		 = Nothing
 
 -----------------------------------------------
+rttiView :: Type -> Type
+-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
+rttiView (ForAllTy _ ty) = rttiView ty
+rttiView (NoteTy   _ ty) = rttiView ty
+rttiView (FunTy PredTy{} ty) = rttiView ty
+rttiView (FunTy NoteTy{} ty) = rttiView ty
+rttiView ty@TyConApp{} | Just ty' <- coreView ty 
+                           = rttiView ty'
+rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys)
+rttiView ty = ty
+
+-----------------------------------------------
 {-# INLINE kindView #-}
 kindView :: Kind -> Maybe Kind
 -- C.f. coreView, tcView
@@ -483,16 +495,6 @@ repType (TyConApp tc tys)
 
 repType ty = ty
 
--- repType' aims to be a more thorough version of repType
--- For now it simply looks through the TyConApp args too
-repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
-            | otherwise = go1 ty 
- where 
-        go1 = go . repType
-        go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
-        go ty = ty
-
-
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 -- of inspecting the type directly.
 typePrimRep :: Type -> PrimRep
@@ -861,10 +863,19 @@ isUnboxedTupleType ty = case splitTyConApp_maybe ty of
 
 -- Should only be applied to *types*; hence the assert
 isAlgType :: Type -> Bool
-isAlgType ty = case splitTyConApp_maybe ty of
-			Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
-					      isAlgTyCon tc
-			other		   -> False
+isAlgType ty 
+  = case splitTyConApp_maybe ty of
+      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+			    isAlgTyCon tc
+      _other	         -> False
+
+-- Should only be applied to *types*; hence the assert
+isClosedAlgType :: Type -> Bool
+isClosedAlgType ty
+  = case splitTyConApp_maybe ty of
+      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+			    isAlgTyCon tc && not (isOpenTyCon tc)
+      _other	         -> False
 \end{code}
 
 @isStrictType@ computes whether an argument (or let RHS) should