[project @ 2005-01-27 15:55:38 by simonpj]

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

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 96e1046..7fdf2e3 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -16,7 +16,7 @@ module TyCon(
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
        isEnumerationTyCon, 
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
-       isRecursiveTyCon, newTyConRep, newTyConRhs, isHiBootTyCon,
+       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon,
 
        mkForeignTyCon, isForeignTyCon,
 
@@ -33,7 +33,7 @@ module TyCon(
        tyConUnique,
        tyConTyVars,
        tyConArgVrcs,
-       algTcRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
+       algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
        tyConFields, tyConSelIds,
        tyConStupidTheta,
        tyConArity,
@@ -63,6 +63,7 @@ import BasicTypes     ( Arity, RecFlag(..), Boxity(..), isBoxed )
 import Name            ( Name, nameUnique, NamedThing(getName) )
 import PrelNames       ( Unique, Uniquable(..) )
 import Maybes          ( orElse )
+import Util            ( equalLength )
 import Outputable
 import FastString
 \end{code}
@@ -90,8 +91,8 @@ data TyCon
        tyConKind   :: Kind,
        tyConArity  :: Arity,
        
-       tyConTyVars :: [TyVar],         -- Scopes over (a) the [PredType] in DataTyCon
-                                       --             (b) the cached types in NewTyCon
+       tyConTyVars :: [TyVar],         -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon
+                                       --             (b) the cached types in AlgTyConRhs.NewTyCon
                                        --             (c) the types in algTcFields
                                        -- But not over the data constructors
        argVrcs     :: ArgVrcs,
@@ -176,6 +177,8 @@ data AlgTyConRhs
                                --      e.g. data T a where { ... }
        [DataCon]       -- The constructors; can be empty if the user declares
                        --   the type to have no constructors
+                       -- INVARIANT: Kept in order of increasing tag
+                       --            (see the tag assignment in DataCon.mkDataCon)
        Bool            -- Cached: True <=> an enumeration type
 
   | NewTyCon           -- Newtypes always have exactly one constructor
@@ -489,15 +492,36 @@ tyConFields other_tycon                     = []
 
 tyConSelIds :: TyCon -> [Id]
 tyConSelIds tc = [id | (_,_,id) <- tyConFields tc]
+
+algTyConRhs :: TyCon -> AlgTyConRhs
+algTyConRhs (AlgTyCon {algTcRhs = rhs})  = rhs
+algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon (Just []) [con] False
+algTyConRhs other = pprPanic "algTyConRhs" (ppr other)
 \end{code}
 
 \begin{code}
-newTyConRep :: TyCon -> ([TyVar], Type)
-newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep)
-
 newTyConRhs :: TyCon -> ([TyVar], Type)
 newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs)
 
+newTyConRhs_maybe :: TyCon 
+                 -> [Type]                     -- Args to tycon
+                 -> Maybe ([(TyVar,Type)],     -- Substitution
+                           Type)               -- Body type (not yet substituted)
+-- Non-recursive newtypes are transparent to Core; 
+-- Given an application to some types, return Just (tenv, ty)
+-- if it's a saturated, non-recursive newtype.
+newTyConRhs_maybe (AlgTyCon {tyConTyVars = tvs, 
+                            algTcRec = NonRecursive,   -- Not recursive
+                            algTcRhs = NewTyCon _ rhs _}) tys
+   | tvs `equalLength` tys     -- Saturated
+   = Just (tvs `zip` tys, rhs)
+       
+newTyConRhs_maybe other_tycon tys = Nothing
+
+
+newTyConRep :: TyCon -> ([TyVar], Type)
+newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep)
+
 tyConPrimRep :: TyCon -> PrimRep
 tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
 tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep