[project @ 2000-06-22 16:18:10 by panne]

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

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 32085d4..0884f54 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -36,7 +36,9 @@ module RdrHsSyn (
        RdrNameTyClDecl,
        RdrNameRuleDecl,
        RdrNameRuleBndr,
+       RdrNameDeprecation,
        RdrNameHsRecordBinds,
+       RdrNameFixitySig,
 
        RdrBinding(..),
        RdrMatch(..),
@@ -51,8 +53,9 @@ module RdrHsSyn (
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
        extractPatsTyVars, 
        extractRuleBndrsTyVars,
+       extractHsCtxtRdrTyVars,
  
-       mkOpApp, mkClassDecl, mkClassOpSig,
+       mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
 
        cvBinds,
        cvMonoBindsAndSigs,
@@ -64,7 +67,7 @@ module RdrHsSyn (
 
 import HsSyn
 import Name            ( mkClassTyConOcc, mkClassDataConOcc )
-import OccName         ( mkClassTyConOcc, mkClassDataConOcc, 
+import OccName         ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
                           mkSuperDictSelOcc, mkDefaultMethodOcc
                        )
 import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
@@ -105,12 +108,14 @@ type RdrNameMatch         = Match                 RdrName RdrNamePat
 type RdrNameMonoBinds          = MonoBinds             RdrName RdrNamePat
 type RdrNamePat                        = InPat                 RdrName
 type RdrNameHsType             = HsType                RdrName
-type RdrNameHsTyVar            = HsTyVar               RdrName
+type RdrNameHsTyVar            = HsTyVarBndr           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 RdrNameDeprecation         = DeprecDecl            RdrName
+type RdrNameFixitySig          = FixitySig             RdrName
 
 type RdrNameHsRecordBinds      = HsRecordBinds         RdrName RdrNamePat
 
@@ -149,6 +154,8 @@ extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
 
 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
+extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
+extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
 
 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 
@@ -157,14 +164,14 @@ extract_pred (HsPIParam n ty) acc = extract_ty ty acc
 
 extract_tys tys acc = foldr extract_ty 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 (cls : acc) tys
-extract_ty (MonoUsgTy usg ty)           acc = extract_ty ty acc
-extract_ty (MonoUsgForAllTy uv ty)      acc = extract_ty ty acc
-extract_ty (MonoTyVar tv)               acc = tv : acc
+extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsListTy ty)              acc = extract_ty ty acc
+extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
+extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsPredTy p)                      acc = extract_pred p acc
+extract_ty (HsUsgTy usg ty)           acc = extract_ty ty acc
+extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
+extract_ty (HsTyVar tv)               acc = tv : acc
 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
                                 acc = acc ++
@@ -199,15 +206,17 @@ 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 good).
 
-Similarly for mkClassOpSig and default-method names.
+Similarly for mkConDecl, mkClassOpSig and default-method names.
   
 \begin{code}
 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
-  = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname sc_sel_names loc
+  = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
   where
-    cls_occ = rdrNameOcc cname
-    dname   = mkRdrUnqual (mkClassDataConOcc cls_occ)
-    tname   = mkRdrUnqual (mkClassTyConOcc   cls_occ)
+    cls_occ  = rdrNameOcc cname
+    data_occ = mkClassDataConOcc cls_occ
+    dname    = mkRdrUnqual data_occ
+    dwname   = mkRdrUnqual (mkWorkerOcc data_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 
@@ -222,6 +231,11 @@ mkClassOpSig has_default_method op ty loc
   = ClassOpSig op dm_rn has_default_method ty loc
   where
     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+
+mkConDecl cname ex_vars cxt details loc
+  = ConDecl cname wkr_name ex_vars cxt details loc
+  where
+    wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 \end{code}
 
 A useful function for building @OpApps@.  The operator is always a variable,
@@ -283,7 +297,7 @@ cvValSig      sig = sig
 cvInstDeclSig sig = sig
 
 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
-                                                       (panic "cvClassOpSig:dm_present")
+                                                       False
                                                        poly_ty src_loc
 cvClassOpSig sig                      = sig
 \end{code}