[project @ 2004-12-20 17:16:24 by simonpj]

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

diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs
index 0e0f88f..a3487a4 100644 (file)
--- a/ghc/compiler/types/TypeRep.lhs
+++ b/ghc/compiler/types/TypeRep.lhs
@@ -10,12 +10,11 @@ module TypeRep (
        PredType(..),                   -- to friends
        
        Kind, ThetaType,                -- Synonyms
-       TyVarSubst,
 
        funTyCon,
 
        -- Pretty-printing
-       pprType, pprParendType,
+       pprType, pprParendType, pprTyThingCategory,
        pprPred, pprTheta, pprThetaArrow, pprClassPred,
 
        -- Re-export fromKind
@@ -31,17 +30,16 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName )
 
 -- friends:
 import Kind
-import Var       ( Id, TyVar, tyVarKind )
-import VarEnv     ( TyVarEnv )
+import Var       ( Var, Id, TyVar, tyVarKind )
 import VarSet     ( TyVarSet )
-import Name      ( Name, NamedThing(..), mkWiredInName )
+import Name      ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
 import OccName   ( mkOccFS, tcName )
 import BasicTypes ( IPName, tupleParens )
-import TyCon     ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon )
+import TyCon     ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon )
 import Class     ( Class )
 
 -- others
-import PrelNames       ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey )
+import PrelNames  ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey )
 import Outputable
 \end{code}
 
@@ -116,7 +114,7 @@ Similarly splitForAllTys and splitFunTys can get into a loop.
 
 Solution: 
 
-* Newtypes are always represented using NewTcApp, never as TyConApp.
+* Newtypes are always represented using TyConApp.
 
 * For non-recursive newtypes, P, treat P just like a type synonym after 
   type-checking is done; i.e. it's opaque during type checking (functions
@@ -146,31 +144,20 @@ to cut all loops.  The other members of the loop may be marked 'non-recursive'.
 
 
 \begin{code}
-type TyVarSubst = TyVarEnv Type
-
 data Type
   = TyVarTy TyVar      
 
   | AppTy
        Type            -- Function is *not* a TyConApp
-       Type
+       Type            -- It must be another AppTy, or TyVarTy
+                       -- (or NoteTy of these)
 
-  | TyConApp           -- Application of a TyCon
+  | TyConApp           -- Application of a TyCon, including newtypes
        TyCon           -- *Invariant* saturated appliations of FunTyCon and
                        --      synonyms have their own constructors, below.
-       [Type]          -- Might not be saturated.
-
-  | NewTcApp           -- Application of a NewType TyCon.   All newtype applications
-       TyCon           -- show up like this until they are fed through newTypeRep,
-                       -- which returns 
-                       --      * an ordinary TyConApp for non-saturated, 
-                       --       or recursive newtypes
-                       --
-                       --      * the representation type of the newtype for satuarted, 
-                       --        non-recursive ones
-                       -- [But the result of a call to newTypeRep is always consumed
-                       --  immediately; it never lives on in another type.  So in any
-                       --  type, newtypes are always represented with NewTcApp.]
+                       -- However, *unsaturated* type synonyms, and FunTyCons
+                       --      do appear as TyConApps.  (Unsaturated type synonyms
+                       --      can appear as the RHS of a type synonym, for exmaple.)
        [Type]          -- Might not be saturated.
 
   | FunTy              -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
@@ -254,10 +241,13 @@ data TyThing = AnId     Id
             | AClass   Class
 
 instance Outputable TyThing where
-  ppr (AnId   id)   = ptext SLIT("AnId")     <+> ppr id
-  ppr (ATyCon tc)   = ptext SLIT("ATyCon")   <+> ppr tc
-  ppr (AClass cl)   = ptext SLIT("AClass")   <+> ppr cl
-  ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr (dataConName dc)
+  ppr thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
+
+pprTyThingCategory :: TyThing -> SDoc
+pprTyThingCategory (ATyCon _)  = ptext SLIT("Type constructor")
+pprTyThingCategory (AClass _)   = ptext SLIT("Class")
+pprTyThingCategory (AnId   _)   = ptext SLIT("Identifier")
+pprTyThingCategory (ADataCon _) = ptext SLIT("Data constructor")
 
 instance NamedThing TyThing where      -- Can't put this with the type
   getName (AnId id)     = getName id   -- decl, because the DataCon instance
@@ -290,6 +280,7 @@ funTyConName = mkWiredInName gHC_PRIM
                        funTyConKey
                        Nothing                 -- No parent object
                        (ATyCon funTyCon)       -- Relevant TyCon
+                       BuiltInSyntax
 \end{code}
 
 
@@ -356,15 +347,13 @@ ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1
 ppr_type p (NoteTy other         ty2) = ppr_type p ty2
 
 ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
-ppr_type p (NewTcApp tc tys) = ifPprDebug (if isRecursiveTyCon tc 
-                                          then ptext SLIT("<recnt>")
-                                          else ptext SLIT("<nt>")
-                                 ) <> 
-                              ppr_tc_app p tc tys
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
                           pprType t1 <+> ppr_type TyConPrec t2
 
+ppr_type p ty@(ForAllTy _ _)       = ppr_forall_type p ty
+ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
+
 ppr_type p (FunTy ty1 ty2)
   = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
     maybeParen p FunPrec $
@@ -373,7 +362,8 @@ ppr_type p (FunTy ty1 ty2)
     ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
     ppr_fun_tail other_ty        = [arrow <+> pprType other_ty]
 
-ppr_type p ty@(ForAllTy _ _)  
+ppr_forall_type :: Prec -> Type -> SDoc
+ppr_forall_type p ty
   = maybeParen p FunPrec $
     sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
   where
@@ -392,7 +382,7 @@ ppr_type p ty@(ForAllTy _ _)
 
 ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
 ppr_tc_app p tc [] 
-  = ppr tc
+  = ppr_tc tc
 ppr_tc_app p tc [ty] 
   | tc `hasKey` listTyConKey = brackets (pprType ty)
   | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
@@ -401,9 +391,18 @@ ppr_tc_app p tc tys
   = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
   | otherwise
   = maybeParen p TyConPrec $
-    ppr tc <+> sep (map (ppr_type TyConPrec) tys)
-
+    ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys)
+
+ppr_tc :: TyCon -> SDoc
+ppr_tc tc
+  | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 
+                               then ptext SLIT("<recnt>")
+                               else ptext SLIT("<nt>")
+                   ) <> ppr tc
+  | otherwise = ppr tc
+                              
 -------------------
+pprForAll []  = empty
 pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
 
 pprTvBndr tv | isLiftedTypeKind kind = ppr tv