[project @ 1996-05-01 18:36:59 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 13292e2..884ee9f 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
 
@@ -163,7 +169,7 @@ ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
 #ifdef COMPILING_GHC
 
 extractCtxtTyNames :: Eq name => Context  name -> [name]
-extractMonoTyNames :: Eq name => MonoType name -> [name]
+extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name]
 
 extractCtxtTyNames ctxt
   = foldr get [] ctxt
@@ -174,10 +180,15 @@ extractCtxtTyNames ctxt
 
     is_elem = isIn "extractCtxtTyNames"
 
-extractMonoTyNames ty
+extractMonoTyNames is_tyvar_name ty
   = get ty []
   where
-    get (MonoTyApp con tys) acc = foldr get acc tys
+    get (MonoTyApp con tys) acc = let
+                                    rest = foldr get acc tys
+                                 in
+                                 if is_tyvar_name con && not (con `is_elem` rest)
+                                 then con : rest
+                                 else rest
     get (MonoListTy ty)            acc = get ty acc
     get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
     get (MonoDictTy _ ty)   acc = get ty acc