[project @ 1996-04-20 10:37:06 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..9c29e81 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -163,7 +163,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 +174,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