[project @ 2000-11-20 16:07:12 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 54f993d..c464de5 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -14,10 +14,10 @@ module HsDecls (
        ConDecl(..), ConDetails(..), 
        BangType(..), getBangType,
        DeprecDecl(..), DeprecTxt,
-       hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
+       hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
        isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
-       mkClassDeclSysNames, isIfaceRuleDecl,
-       getClassDeclSysNames
+       mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
+       getClassDeclSysNames, conDetailsTys
     ) where
 
 #include "HsVersions.h"
@@ -35,8 +35,9 @@ import BasicTypes     ( NewOrData(..) )
 import CallConv                ( CallConv, pprCallConv )
 
 -- others:
+import Name            ( NamedThing )
 import FunDeps         ( pprFundeps )
-import Class           ( FunDep )
+import Class           ( FunDep, DefMeth(..) )
 import CStrings                ( CLabelString, pprCLabelString )
 import Outputable      
 import SrcLoc          ( SrcLoc )
@@ -76,7 +77,7 @@ data HsDecl name pat
 
 \begin{code}
 #ifdef DEBUG
-hsDeclName :: (Outputable name, Outputable pat)
+hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
           => HsDecl name pat -> name
 #endif
 hsDeclName (TyClD decl)                                    = tyClDeclName decl
@@ -95,7 +96,7 @@ instDeclName (InstDecl _ _ _ (Just name) _) = name
 \end{code}
 
 \begin{code}
-instance (Outputable name, Outputable pat)
+instance (NamedThing name, Outputable name, Outputable pat)
        => Outputable (HsDecl name pat) where
 
     ppr (TyClD dcl)  = ppr dcl
@@ -108,14 +109,6 @@ instance (Outputable name, Outputable pat)
     ppr (DeprecD dd) = ppr dd
 \end{code}
 
-\begin{code}
-instance Ord name => Eq (HsDecl name pat) where
-       -- Used only when comparing interfaces, 
-       -- at which time only signature and type/class decls
-   (TyClD d1) == (TyClD d2) = d1 == d2
-   _          == _          = False
-\end{code}
-
 
 %************************************************************************
 %*                                                                     *
@@ -222,6 +215,7 @@ isClassDecl other                    = False
 Dealing with names
 
 \begin{code}
+--------------------------------
 tyClDeclName :: TyClDecl name pat -> name
 tyClDeclName (IfaceSig name _ _ _)          = name
 tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
@@ -229,6 +223,7 @@ tyClDeclName (TySynonym name _ _ _)          = name
 tyClDeclName (ClassDecl _ name _ _ _ _ _ _)  = name
 
 
+--------------------------------
 tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
 -- Returns all the binding names of the decl, along with their SrcLocs
 -- The first one is guaranteed to be the name of the decl
@@ -246,6 +241,17 @@ tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _)
 
 tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)]
 
+--------------------------------
+tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
+-- Similar to tyClDeclNames, but returns the "implicit" 
+-- or "system" names of the declaration
+
+tyClDeclSysNames (ClassDecl _ _ _ _ _ _ names loc) = [(n,loc)        | n <- names]
+tyClDeclSysNames (TyData _ _ _ _ cons _ _ _ _ _)   = [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
+tyClDeclSysNames decl                             = []
+
+
+--------------------------------
 type ClassDeclSysNames name = [name]
        --      [tycon, datacon wrapper, datacon worker, 
        --       superclass selector 1, ..., superclass selector n]
@@ -259,7 +265,7 @@ getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
 \end{code}
 
 \begin{code}
-instance Ord name => Eq (TyClDecl name pat) where
+instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
        -- Used only when building interface files
   (==) (IfaceSig n1 t1 i1 _)
        (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
@@ -289,20 +295,23 @@ instance Ord name => Eq (TyClDecl name pat) where
 
   (==) _ _ = False     -- default case
 
-
 eq_hsFD env (ns1,ms1) (ns2,ms2)
   = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
 
 eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
   = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
   where
-       -- Ignore the name of the default method.
+       -- Ignore the name of the default method for (DefMeth id)
        -- This is used for comparing declarations before putting
        -- them into interface files, and the name of the default 
        -- method isn't relevant
-    (Just (explicit_dm1)) `eq_dm` (Just (explicit_dm2)) = explicit_dm1 == explicit_dm2
-    Nothing                `eq_dm` Nothing                 = True
-    dm1                            `eq_dm` dm2                     = False
+    Nothing           `eq_dm` Nothing            = True
+    (Just NoDefMeth)   `eq_dm` (Just NoDefMeth)   = True
+    (Just GenDefMeth)  `eq_dm` (Just GenDefMeth)  = True
+    (Just (DefMeth _)) `eq_dm` (Just (DefMeth _)) = True
+    dm1                       `eq_dm` dm2                = False
+
+    
 \end{code}
 
 \begin{code}
@@ -317,7 +326,7 @@ countTyClDecls decls
 \end{code}
 
 \begin{code}
-instance (Outputable name, Outputable pat)
+instance (NamedThing name, Outputable name, Outputable pat)
              => Outputable (TyClDecl name pat) where
 
     ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
@@ -421,10 +430,16 @@ conDeclsNames cons
 \end{code}
 
 \begin{code}
+conDetailsTys :: ConDetails name -> [HsType name]
+conDetailsTys (VanillaCon btys)    = map getBangType btys
+conDetailsTys (InfixCon bty1 bty2) = [getBangType bty1, getBangType bty2]
+conDetailsTys (RecCon fields)     = [getBangType bty | (_, bty) <- fields]
+
+
 eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
               (ConDecl n2 _ tvs2 cxt2 cds2 _)
   = n1 == n2 &&
-    (eqWithHsTyVars tvs1 tvs2  $ \ env ->
+    (eq_hsTyVars env tvs1 tvs2 $ \ env ->
      eq_hsContext env cxt1 cxt2        &&
      eq_ConDetails env cds1 cds2)
 
@@ -642,18 +657,23 @@ data RuleDecl name pat
 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)
+
 data RuleBndr name
   = RuleBndr name
   | RuleBndrSig name (HsType name)
 
-instance Ord name => Eq (RuleDecl name pat) where
+instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
   -- Works for IfaceRules only; used when comparing interface file versions
   (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _)
      = n1==n2 && f1 == f2 && 
        eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> 
        eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))
 
-instance (Outputable name, Outputable pat)
+instance (NamedThing name, Outputable name, Outputable pat)
              => Outputable (RuleDecl name pat) where
   ppr (HsRule name tvs ns lhs rhs loc)
        = sep [text "{-# RULES" <+> doubleQuotes (ptext name),