[project @ 1998-12-02 13:17:09 by simonm]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsTypes.lhs

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index e2b1354..e64c34a 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsTypes]{Abstract syntax: user-defined types}
 
@@ -15,16 +15,16 @@ module HsTypes (
        , mkHsForAllTy
        , getTyVarName, replaceTyVarName
        , pprParendHsType
-       , pprContext, pprClassAssertion
+       , pprForAll, pprContext, pprClassAssertion
        , cmpHsType, cmpHsTypes, cmpContext
     ) where
 
 #include "HsVersions.h"
 
+import Type            ( Kind )
+import PprType         ( {- instance Outputable Kind -} )
 import Outputable
-import Kind            ( Kind {- instance Outputable -} )
 import Util            ( thenCmp, cmpList, panic )
-import GlaExts         ( Int#, (<#) )
 \end{code}
 
 This is the syntax for types as seen in type signatures.
@@ -37,16 +37,7 @@ type ClassAssertion name = (name, [HsType name])
        -- doesn't have to be when reading interface files
 
 data HsType name
-  = HsPreForAllTy      (Context name)
-                       (HsType name)
-
-       -- The renamer turns HsPreForAllTys into HsForAllTys when they
-       -- occur in signatures, to make the binding of variables
-       -- explicit.  This distinction is made visible for
-       -- non-COMPILING_GHC code, because you probably want to do the
-       -- same thing.
-
-  | HsForAllTy         [HsTyVar name]
+  = HsForAllTy         [HsTyVar name]
                        (Context name)
                        (HsType name)
 
@@ -58,11 +49,10 @@ data HsType name
   | MonoFunTy          (HsType name) -- function type
                        (HsType name)
 
-  | MonoListTy         name            -- The list TyCon name
-                       (HsType name)   -- Element type
+  | MonoListTy         (HsType name)   -- Element type
 
-  | MonoTupleTy                name            -- The tuple TyCon name
-                       [HsType name]   -- Element types (length gives arity)
+  | MonoTupleTy                [HsType name]   -- Element types (length gives arity)
+                       Bool            -- boxed?
 
   -- these next two are only used in unfoldings in interfaces
   | MonoDictTy         name    -- Class
@@ -102,17 +92,12 @@ instance (Outputable name) => Outputable (HsTyVar name) where
     ppr (UserTyVar name)       = ppr name
     ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
 
-ppr_forall ctxt_prec [] [] ty
-   = ppr_mono_ty ctxt_prec ty
-ppr_forall ctxt_prec tvs ctxt ty
-   = maybeParen (ctxt_prec >= pREC_FUN) $
-     sep [ptext SLIT("_forall_"), brackets (interppSP tvs),
-           pprContext ctxt,  ptext SLIT("=>"),
-           pprHsType ty]
+pprForAll []  = empty
+pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
 
 pprContext :: (Outputable name) => Context name -> SDoc
 pprContext []     = empty
-pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context)))
+pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
 
 pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
 pprClassAssertion (clas, tys) 
@@ -135,10 +120,12 @@ pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
 pprHsType ty       = ppr_mono_ty pREC_TOP ty
 pprParendHsType ty = ppr_mono_ty pREC_CON ty
 
-ppr_mono_ty ctxt_prec (HsPreForAllTy ctxt ty)     = ppr_forall ctxt_prec [] ctxt ty
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)    = ppr_forall ctxt_prec tvs ctxt ty
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
+  = maybeParen (ctxt_prec >= pREC_FUN) $
+    sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
 
-ppr_mono_ty ctxt_prec (MonoTyVar name) = ppr name
+ppr_mono_ty ctxt_prec (MonoTyVar name)
+  = ppr name
 
 ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
   = let p1 = ppr_mono_ty pREC_FUN ty1
@@ -147,10 +134,12 @@ ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
     maybeParen (ctxt_prec >= pREC_FUN)
               (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 
-ppr_mono_ty ctxt_prec (MonoTupleTy _ tys)
+ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
  = parens (sep (punctuate comma (map ppr tys)))
+ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
+ = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
 
-ppr_mono_ty ctxt_prec (MonoListTy _ ty)
+ppr_mono_ty ctxt_prec (MonoListTy ty)
  = brackets (ppr_mono_ty pREC_TOP ty)
 
 ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
@@ -189,12 +178,6 @@ cmpHsTypes cmp [] tys2 = LT
 cmpHsTypes cmp tys1 [] = GT
 cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
 
--- We assume that HsPreForAllTys have been smashed by now.
-# ifdef DEBUG
-cmpHsType _ (HsPreForAllTy _ _) _ = panic "cmpHsType:HsPreForAllTy:1st arg"
-cmpHsType _ _ (HsPreForAllTy _ _) = panic "cmpHsType:HsPreForAllTy:2nd arg"
-# endif
-
 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
   = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
     cmpContext cmp c1 c2               `thenCmp`
@@ -203,9 +186,10 @@ cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
   = cmp n1 n2
 
-cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2)
-  = cmpList (cmpHsType cmp) tys1 tys2
-cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
+cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
+  = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
+
+cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
   = cmpHsType cmp ty1 ty2
 
 cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
@@ -223,14 +207,13 @@ cmpHsType cmp ty1 ty2 -- tags must be different
     in
     if tag1 _LT_ tag2 then LT else GT
   where
-    tag (MonoTyVar n1)         = (ILIT(1) :: FAST_INT)
-    tag (MonoTupleTy _ tys1)   = ILIT(2)
-    tag (MonoListTy _ ty1)     = ILIT(3)
-    tag (MonoTyApp tc1 tys1)   = ILIT(4)
-    tag (MonoFunTy a1 b1)      = ILIT(5)
-    tag (MonoDictTy c1 tys1)   = ILIT(7)
-    tag (HsForAllTy _ _ _)     = ILIT(8)
-    tag (HsPreForAllTy _ _)    = ILIT(9)
+    tag (MonoTyVar n1)                 = (ILIT(1) :: FAST_INT)
+    tag (MonoTupleTy tys1 _)           = ILIT(2)
+    tag (MonoListTy ty1)               = ILIT(3)
+    tag (MonoTyApp tc1 tys1)           = ILIT(4)
+    tag (MonoFunTy a1 b1)              = ILIT(5)
+    tag (MonoDictTy c1 tys1)           = ILIT(7)
+    tag (HsForAllTy _ _ _)             = ILIT(8)
 
 -------------------
 cmpContext cmp a b