[project @ 1999-06-01 16:40:41 by simonmar]

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

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index e64c34a..f57cbe8 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -21,10 +21,10 @@ module HsTypes (
 
 #include "HsVersions.h"
 
-import Type            ( Kind )
+import Type            ( Kind, UsageAnn(..) )
 import PprType         ( {- instance Outputable Kind -} )
 import Outputable
-import Util            ( thenCmp, cmpList, panic )
+import Util            ( thenCmp, cmpList )
 \end{code}
 
 This is the syntax for types as seen in type signatures.
@@ -37,7 +37,7 @@ type ClassAssertion name = (name, [HsType name])
        -- doesn't have to be when reading interface files
 
 data HsType name
-  = HsForAllTy         [HsTyVar name]
+  = HsForAllTy         (Maybe [HsTyVar name])  -- Nothing for implicitly quantified signatures
                        (Context name)
                        (HsType name)
 
@@ -54,12 +54,15 @@ data HsType name
   | MonoTupleTy                [HsType name]   -- Element types (length gives arity)
                        Bool            -- boxed?
 
-  -- these next two are only used in unfoldings in interfaces
+  -- these next two are only used in interfaces
   | MonoDictTy         name    -- Class
                        [HsType name]
 
+  | MonoUsgTy           UsageAnn
+                        (HsType name)
+
 mkHsForAllTy []  []   ty = ty
-mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
+mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
 
 data HsTyVar name
   = UserTyVar name
@@ -90,7 +93,7 @@ instance (Outputable name) => Outputable (HsType name) where
 
 instance (Outputable name) => Outputable (HsTyVar name) where
     ppr (UserTyVar name)       = ppr name
-    ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
+    ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
 
 pprForAll []  = empty
 pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
@@ -101,7 +104,7 @@ pprContext context = parens (hsep (punctuate comma (map pprClassAssertion contex
 
 pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
 pprClassAssertion (clas, tys) 
-  = ppr clas <+> hsep (map ppr tys)
+  = ppr clas <+> hsep (map pprParendHsType tys)
 \end{code}
 
 \begin{code}
@@ -120,9 +123,13 @@ 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 (HsForAllTy tvs ctxt ty)
+ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
   = maybeParen (ctxt_prec >= pREC_FUN) $
     sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
+  where
+    tvs = case maybe_tvs of
+               Just tvs -> tvs
+               Nothing  -> []
 
 ppr_mono_ty ctxt_prec (MonoTyVar name)
   = ppr name
@@ -148,6 +155,10 @@ ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
 
 ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
   = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
+
+ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
+  = maybeParen (ctxt_prec >= pREC_CON) $
+    ppr u <+> ppr_mono_ty pREC_CON ty
 \end{code}
 
 
@@ -179,8 +190,8 @@ cmpHsTypes cmp tys1 [] = GT
 cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
 
 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
-  = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
-    cmpContext cmp c1 c2               `thenCmp`
+  = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2      `thenCmp`
+    cmpContext cmp c1 c2                               `thenCmp`
     cmpHsType cmp t1 t2
 
 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
@@ -201,6 +212,9 @@ cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
 cmpHsType cmp (MonoDictTy c1 tys1)   (MonoDictTy c2 tys2)
   = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 
+cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
+  = cmpUsg u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
+
 cmpHsType cmp ty1 ty2 -- tags must be different
   = let tag1 = tag ty1
        tag2 = tag ty2
@@ -213,6 +227,7 @@ cmpHsType cmp ty1 ty2 -- tags must be different
     tag (MonoTyApp tc1 tys1)           = ILIT(4)
     tag (MonoFunTy a1 b1)              = ILIT(5)
     tag (MonoDictTy c1 tys1)           = ILIT(7)
+    tag (MonoUsgTy c1 tys1)            = ILIT(6)
     tag (HsForAllTy _ _ _)             = ILIT(8)
 
 -------------------
@@ -221,4 +236,18 @@ cmpContext cmp a b
   where
     cmp_ctxt (c1, tys1) (c2, tys2)
       = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+
+-- Should be in Type, perhaps
+cmpUsg UsOnce UsOnce = EQ
+cmpUsg UsOnce UsMany = LT
+cmpUsg UsMany UsOnce = GT
+cmpUsg UsMany UsMany = EQ
+cmpUsg u1     u2     = pprPanic "cmpUsg:" $
+                         ppr u1 <+> ppr u2
+
+-- Should be in Maybes, I guess
+cmpMaybe cmp Nothing  Nothing  = EQ
+cmpMaybe cmp Nothing  (Just x) = LT
+cmpMaybe cmp (Just x)  Nothing = GT
+cmpMaybe cmp (Just x) (Just y) = x `cmp` y
 \end{code}