[project @ 1999-05-18 15:03:54 by simonpj]

[ghc-hetmet.git] / ghc / compiler / reader / RdrHsSyn.lhs

diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 4964c42..266cb94 100644 (file)
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -32,21 +32,26 @@ module RdrHsSyn (
        RdrNameSig,
        RdrNameStmt,
        RdrNameTyClDecl,
+       RdrNameRuleBndr,
+       RdrNameRuleDecl,
 
        RdrNameClassOpPragmas,
        RdrNameClassPragmas,
        RdrNameDataPragmas,
        RdrNameGenPragmas,
        RdrNameInstancePragmas,
-       extractHsTyVars, extractHsCtxtTyVars, extractPatsTyVars,
+       extractHsTyRdrNames, 
+       extractPatsTyVars, extractRuleBndrsTyVars,
 
-       mkOpApp, mkClassDecl
+       mkOpApp, mkClassDecl, mkClassOpSig
     ) where
 
 #include "HsVersions.h"
 
 import HsSyn
-import Name            ( mkClassTyConOcc, mkClassDataConOcc )
+import OccName         ( mkClassTyConOcc, mkClassDataConOcc, 
+                         mkSuperDictSelOcc, mkDefaultMethodOcc
+                       )
 import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
 import Util            ( thenCmp )
 import HsPragmas       ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
@@ -86,6 +91,8 @@ type RdrNameHsType            = HsType                RdrName
 type RdrNameSig                        = Sig                   RdrName
 type RdrNameStmt               = Stmt                  RdrName RdrNamePat
 type RdrNameTyClDecl           = TyClDecl              RdrName RdrNamePat
+type RdrNameRuleBndr           = RuleBndr              RdrName
+type RdrNameRuleDecl           = RuleDecl              RdrName RdrNamePat
 
 type RdrNameClassOpPragmas     = ClassOpPragmas        RdrName
 type RdrNameClassPragmas       = ClassPragmas          RdrName
@@ -101,27 +108,33 @@ type RdrNameInstancePragmas       = InstancePragmas       RdrName
 %*                                                                     *
 %************************************************************************
 
-@extractHsTyVars@ looks just for things that could be type variables.
+@extractHsTyRdrNames@ finds the free variables of a HsType
 It's used when making the for-alls explicit.
 
 \begin{code}
-extractHsTyVars :: HsType RdrName -> [RdrName]
-extractHsTyVars ty = nub (extract_ty ty [])
+extractHsTyRdrNames :: HsType RdrName -> [RdrName]
+extractHsTyRdrNames ty = nub (extract_ty ty [])
 
-extractHsCtxtTyVars :: Context RdrName -> [RdrName]
-extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
+extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
+extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
+                            where
+                              go (RuleBndr _)       acc = acc
+                              go (RuleBndrSig _ ty) acc = extract_ty ty acc
+
+extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
+extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 
 extract_ctxt ctxt acc = foldr extract_ass acc ctxt
                      where
-                       extract_ass (cls, tys) acc = foldr extract_ty acc tys
+                       extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
 
 extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
 extract_ty (MonoListTy ty)     acc = extract_ty ty acc
 extract_ty (MonoTupleTy tys _)  acc = foldr extract_ty acc tys
 extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys)        acc = foldr extract_ty acc tys
+extract_ty (MonoDictTy cls tys)        acc = foldr extract_ty (cls : acc) tys
 extract_ty (MonoUsgTy usg ty)  acc = extract_ty ty acc
-extract_ty (MonoTyVar tv)       acc = insertTV tv acc
+extract_ty (MonoTyVar tv)       acc = tv : acc
 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
                                acc = acc ++
                                      (filter (`notElem` locals) $
@@ -129,8 +142,6 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty)
                                    where
                                      locals = map getTyVarName tvs
 
-insertTV name   acc | isRdrTyVar name = name : acc
-insertTV other  acc                  = acc
 
 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 extractPatsTyVars pats = nub (foldr extract_pat [] pats)
@@ -163,15 +174,29 @@ mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 by deriving them from the name of the class.  We fill in the names for the
 tycon and datacon corresponding to the class, by deriving them from the
 name of the class itself.  This saves recording the names in the interface
-file (which would be equally godd).
+file (which would be equally good).
+
+Similarly for mkClassOpSig and default-method names.
 
 \begin{code}
 mkClassDecl cxt cname tyvars sigs mbinds prags loc
-  = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
+  = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
   where
     cls_occ = rdrNameOcc cname
     dname   = mkRdrUnqual (mkClassDataConOcc cls_occ)
     tname   = mkRdrUnqual (mkClassTyConOcc   cls_occ)
+    sc_sel_names = [mkRdrUnqual (mkSuperDictSelOcc n cls_occ) | n <- [1..length cxt]]
+       -- We number off the superclass selectors, 1, 2, 3 etc so that we can construct
+       -- names for the selectors.  Thus
+       --      class (C a, C b) => D a b where ...
+       -- gives superclass selectors
+       --      D_sc1, D_sc2
+       -- (We used to call them D_C, but now we can have two different
+       --  superclasses both called C!)
+
+mkClassOpSig has_default_method op ty loc
+  | not has_default_method = ClassOpSig op Nothing     ty loc
+  | otherwise             = ClassOpSig op (Just dm_rn) ty loc
+  where
+    dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 \end{code}
-
-