[project @ 2001-01-30 13:38:22 by simonmar]

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

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index cc6f64c..57eb5a8 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -49,7 +49,7 @@ module RdrHsSyn (
        extractRuleBndrsTyVars,
        extractHsCtxtRdrTyVars, extractGenericPatTyVars,
  
-       mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
+       mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
        mkHsNegApp, 
 
        cvBinds,
@@ -68,7 +68,7 @@ import OccName                ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
                          mkGenOcc2, 
                        )
 import PrelNames       ( negate_RDR )
-import RdrName         ( RdrName, isRdrTyVar, mkRdrIfaceUnqual, rdrNameOcc,
+import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
                        )
 import List            ( nub )
 import BasicTypes      ( RecFlag(..) )
@@ -108,6 +108,7 @@ 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
@@ -159,8 +160,6 @@ 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)
 -- Generics
@@ -209,17 +208,21 @@ name of the class itself.  This saves recording the names in the interface
 file (which would be equally good).
 
 Similarly for mkConDecl, mkClassOpSig and default-method names.
+
+       *** See "THE NAMING STORY" in HsDecls ****
   
 \begin{code}
 mkClassDecl cxt cname tyvars fds sigs mbinds loc
-  = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc
+  = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
+               tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
+               tcdSysNames = new_names, tcdLoc = loc }
   where
     cls_occ  = rdrNameOcc cname
     data_occ = mkClassDataConOcc cls_occ
-    dname    = mkRdrIfaceUnqual data_occ
-    dwname   = mkRdrIfaceUnqual (mkWorkerOcc data_occ)
-    tname    = mkRdrIfaceUnqual (mkClassTyConOcc   cls_occ)
-    sc_sel_names = [ mkRdrIfaceUnqual (mkSuperDictSelOcc n 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 
       -- can construct names for the selectors.  Thus
@@ -233,22 +236,21 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc
 -- mkTyData :: ??
 mkTyData new_or_data context tname list_var list_con i maybe src
   = let t_occ  = rdrNameOcc tname
-        name1 = mkRdrIfaceUnqual (mkGenOcc1 t_occ) 
-       name2 = mkRdrIfaceUnqual (mkGenOcc2 t_occ) 
-    in TyData new_or_data context 
-              tname list_var list_con i maybe src name1 name2
-
-mkClassOpSig (DefMeth x) op ty loc
-  = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
+        name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
+       name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
+    in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
+               tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
+               tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
+
+mkClassOpSigDM op ty loc
+  = ClassOpSig op (DefMeth dm_rn) ty loc
   where
-    dm_rn = mkRdrIfaceUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-mkClassOpSig x op ty loc =
-    ClassOpSig op (Just x) ty loc
+    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 = mkRdrIfaceUnqual (mkWorkerOcc (rdrNameOcc cname))
+    wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 \end{code}
 
 \begin{code}
@@ -332,7 +334,7 @@ cvValSig      sig = sig
 
 cvInstDeclSig sig = sig
 
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
+cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
 cvClassOpSig sig                      = sig
 \end{code}