X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=945ae656b8129f3b72bc7a4e58c5b8e4735305b3;hb=5cf27e8f1731c52fe63a5b9615f927484164c61b;hp=9c29e8111790f9d471ee3a2d011449dd5750ea53;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 9c29e81..945ae65 100644
--- 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}