Fixed warnings in types/TypeRep

[ghc-hetmet.git] / compiler / types / Type.lhs

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 8c96922..c36893b 100644 (file)
--- 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
@@ -456,6 +468,31 @@ The reason is that we then get better (shorter) type signatures in
 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 
 
+Note [Expanding newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+When expanding a type to expose a data-type constructor, we need to be
+careful about newtypes, lest we fall into an infinite loop. Here are
+the key examples:
+
+  newtype Id  x = MkId x
+  newtype Fix f = MkFix (f (Fix f))
+  newtype T     = MkT (T -> T) 
+  
+  Type          Expansion
+ --------------------------
+  T             T -> T
+  Fix Maybe      Maybe (Fix Maybe)
+  Id (Id Int)    Int
+  Fix Id         NO NO NO
+
+Notice that we can expand T, even though it's recursive.
+And we can expand Id (Id Int), even though the Id shows up
+twice at the outer level.  
+
+So, when expanding, we keep track of when we've seen a recursive
+newtype at outermost level; and bale out if we see it again.
+
+
                Representation types
                ~~~~~~~~~~~~~~~~~~~~
 repType looks through 
@@ -469,28 +506,27 @@ It's useful in the back end.
 \begin{code}
 repType :: Type -> Type
 -- Only applied to types of kind *; hence tycons are saturated
-repType ty | Just ty' <- coreView ty = repType ty'
-repType (ForAllTy _ ty)  = repType ty
-repType (TyConApp tc tys)
-  | isNewTyCon tc
-  , (tvs, rep_ty) <- newTyConRep tc
-  = -- Recursive newtypes are opaque to coreView
-    -- but we must expand them here.  Sure to
-    -- be saturated because repType is only applied
-    -- to types of kind *
-    ASSERT( tys `lengthIs` tyConArity tc )
-    repType (substTyWith tvs tys rep_ty)
-
-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
+repType ty
+  = go [] ty
+  where
+    go :: [TyCon] -> Type -> Type
+    go rec_nts ty | Just ty' <- coreView ty    -- Expand synonyms
+       = go rec_nts ty'        
+
+    go rec_nts (ForAllTy _ ty)                 -- Look through foralls
+       = go rec_nts ty
+
+    go rec_nts ty@(TyConApp tc tys)            -- Expand newtypes
+       | Just co_con <- newTyConCo_maybe tc    -- See Note [Expanding newtypes]
+       = if tc `elem` rec_nts                  --  in Type.lhs
+         then ty
+         else go rec_nts' nt_rhs
+       where
+         nt_rhs = newTyConInstRhs tc tys
+         rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+                  | otherwise           = rec_nts
+
+    go rec_nts ty = ty
 
 
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
@@ -861,10 +897,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