[project @ 1996-05-16 09:42:08 by partain]

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

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 9c29e81..945ae65 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -15,6 +15,7 @@ module HsTypes (
        Context(..), ClassAssertion(..)
 
 #ifdef COMPILING_GHC
+       , pprParendPolyType
        , pprParendMonoType, pprContext
        , extractMonoTyNames, extractCtxtTyNames
        , cmpPolyType, cmpMonoType, cmpContext
@@ -102,6 +103,8 @@ pprContext sty context
 instance (Outputable name) => Outputable (PolyType name) where
     ppr sty (HsPreForAllTy ctxt ty)
       = print_it sty ppNil ctxt ty
+    ppr sty (HsForAllTy [] ctxt ty)
+      = print_it sty ppNil ctxt ty
     ppr sty (HsForAllTy tvs ctxt ty)
       = print_it sty
            (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
@@ -111,6 +114,9 @@ print_it sty pp_forall ctxt ty
   = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
           pprContext sty ctxt, ppr sty ty]
 
+pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty
+pprParendPolyType sty ty = ppr sty ty -- ToDo: more later
+
 instance (Outputable name) => Outputable (MonoType name) where
     ppr = pprMonoType
 
@@ -213,15 +219,9 @@ cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
 # endif
 
 cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
-  = thenCmp (cmp_tvs tvs1 tvs2)
-           (thenCmp (cmpContext cmp c1 c2) (cmpMonoType cmp t1 t2))
-  where
-    cmp_tvs [] [] = EQ_
-    cmp_tvs [] _  = LT_
-    cmp_tvs _  [] = GT_
-    cmp_tvs (a:as) (b:bs)
-      = thenCmp (cmp a b) (cmp_tvs as bs)
-    cmp_tvs _ _ = panic# "cmp_tvs"
+  = cmpList cmp tvs1 tvs2   `thenCmp`
+    cmpContext cmp c1 c2    `thenCmp`
+    cmpMonoType cmp t1 t2
 
 -----------
 cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
@@ -233,13 +233,14 @@ cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
   = cmpMonoType cmp ty1 ty2
 
 cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
-  = thenCmp (cmp tc1 tc2) (cmpList (cmpMonoType cmp) tys1 tys2)
+  = cmp tc1 tc2 `thenCmp`
+    cmpList (cmpMonoType cmp) tys1 tys2
 
 cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
-  = thenCmp (cmpMonoType cmp a1 a2) (cmpMonoType cmp b1 b2)
+  = cmpMonoType cmp a1 a2 `thenCmp` cmpMonoType cmp b1 b2
 
 cmpMonoType cmp (MonoDictTy c1 ty1)   (MonoDictTy c2 ty2)
-  = thenCmp (cmp c1 c2) (cmpMonoType cmp ty1 ty2)
+  = cmp c1 c2 `thenCmp` cmpMonoType cmp ty1 ty2
 
 cmpMonoType cmp ty1 ty2 -- tags must be different
   = let tag1 = tag ty1
@@ -259,7 +260,7 @@ cmpContext cmp a b
   = cmpList cmp_ctxt a b
   where
     cmp_ctxt (c1, tv1) (c2, tv2)
-      = thenCmp (cmp c1 c2) (cmp tv1 tv2)
+      = cmp c1 c2 `thenCmp` cmp tv1 tv2
 
 #endif {- COMPILING_GHC -}
 \end{code}