[project @ 2001-11-26 10:26:59 by simonpj]

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

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 375a35d..a54f5e3 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -17,8 +17,9 @@ module HsDecls (
        hsDeclName, instDeclName, 
        tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
        isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
-       mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
-       getClassDeclSysNames, conDetailsTys
+       mkClassDeclSysNames, isIfaceRuleDecl, isIfaceInstDecl, ifaceRuleDeclName,
+       getClassDeclSysNames, conDetailsTys,
+       collectRuleBndrSigTys
     ) where
 
 #include "HsVersions.h"
@@ -42,11 +43,11 @@ import FunDeps              ( pprFundeps )
 import Class           ( FunDep, DefMeth(..) )
 import CStrings                ( CLabelString )
 import Outputable      
-import Util            ( eqListBy )
+import Util            ( eqListBy, count )
 import SrcLoc          ( SrcLoc )
 import FastString
 
-import Maybe           ( isNothing, fromJust ) 
+import Maybe           ( isNothing, isJust, fromJust ) 
 \end{code}
 
 
@@ -445,11 +446,17 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
 countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
        -- class, data, newtype, synonym decls
 countTyClDecls decls 
- = (length [() | ClassDecl {} <- decls],
-    length [() | TySynonym {} <- decls],
-    length [() | IfaceSig  {} <- decls],
-    length [() | TyData {tcdND = DataType} <- decls],
-    length [() | TyData {tcdND = NewType} <- decls])
+ = (count isClassDecl     decls,
+    count isSynDecl       decls,
+    count isIfaceSigDecl  decls,
+    count isDataTy        decls,
+    count isNewTy         decls) 
+ where
+   isDataTy TyData{tcdND=DataType} = True
+   isDataTy _                      = False
+   
+   isNewTy TyData{tcdND=NewType} = True
+   isNewTy _                     = False
 \end{code}
 
 \begin{code}
@@ -611,7 +618,7 @@ instance (Outputable name) => Outputable (ConDecl name) where
 ppr_con_details con (InfixCon ty1 ty2)
   = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
 
--- ConDecls generated by MkIface.ifaceTyCls always have a VanillaCon, even
+-- ConDecls generated by MkIface.ifaceTyThing always have a VanillaCon, even
 -- if the constructor is an infix one.  This is because in an interface file
 -- we don't distinguish between the two.  Hence when printing these for the
 -- user, we need to parenthesise infix constructor names.
@@ -654,6 +661,9 @@ data InstDecl name pat
                                        -- Nothing for source-file instance decls
 
                SrcLoc
+
+isIfaceInstDecl :: InstDecl name pat -> Bool
+isIfaceInstDecl (InstDecl _ _ _ maybe_dfun _) = isJust maybe_dfun
 \end{code}
 
 \begin{code}
@@ -762,9 +772,7 @@ data RuleDecl name pat
   = HsRule                     -- Source rule
        RuleName                -- Rule name
        Activation
-       [name]                  -- Forall'd tyvars, filled in by the renamer with
-                               -- tyvars mentioned in sigs; then filled out by typechecker
-       [RuleBndr name]         -- Forall'd term vars
+       [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
        (HsExpr name pat)       -- LHS
        (HsExpr name pat)       -- RHS
        SrcLoc          
@@ -783,18 +791,21 @@ data RuleDecl name pat
        CoreRule
 
 isIfaceRuleDecl :: RuleDecl name pat -> Bool
-isIfaceRuleDecl (HsRule _ _ _ _ _ _ _) = False
-isIfaceRuleDecl other                 = True
+isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
+isIfaceRuleDecl other               = True
 
 ifaceRuleDeclName :: RuleDecl name pat -> name
 ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
 ifaceRuleDeclName (IfaceRuleOut n r)       = n
-ifaceRuleDeclName (HsRule fs _ _ _ _ _ _)   = pprPanic "ifaceRuleDeclName" (ppr fs)
+ifaceRuleDeclName (HsRule fs _ _ _ _ _)     = pprPanic "ifaceRuleDeclName" (ppr fs)
 
 data RuleBndr name
   = RuleBndr name
   | RuleBndrSig name (HsType name)
 
+collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
+
 instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
   -- Works for IfaceRules only; used when comparing interface file versions
   (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _)
@@ -804,15 +815,13 @@ instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
 
 instance (NamedThing name, Outputable name, Outputable pat)
              => Outputable (RuleDecl name pat) where
-  ppr (HsRule name act tvs ns lhs rhs loc)
+  ppr (HsRule name act ns lhs rhs loc)
        = sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act,
               pp_forall, ppr lhs, equals <+> ppr rhs,
                text "#-}" ]
        where
-         pp_forall | null tvs && null ns = empty
-                   | otherwise           = text "forall" <+> 
-                                           fsep (map ppr tvs ++ map ppr ns)
-                                           <> dot
+         pp_forall | null ns   = empty
+                   | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
 
   ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) 
     = hsep [ doubleQuotes (ptext name), ppr act,