[project @ 2001-04-07 22:31:11 by qrczak]

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

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index b76c269..ea34147 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,
@@ -67,7 +67,6 @@ import OccName                ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
                           mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
                          mkGenOcc2, 
                        )
-import PrelNames       ( negate_RDR )
 import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
                        )
 import List            ( nub )
@@ -108,6 +107,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
@@ -149,8 +149,8 @@ extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
 
 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 
-extract_pred (HsPClass cls tys) acc    = foldr extract_ty (cls : acc) tys
-extract_pred (HsPIParam n ty) acc      = extract_ty ty acc
+extract_pred (HsClassP cls tys) acc    = foldr extract_ty (cls : acc) tys
+extract_pred (HsIParam n ty) acc       = extract_ty ty acc
 
 extract_tys tys = foldr extract_ty [] tys
 
@@ -159,8 +159,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,10 +207,14 @@ 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
@@ -235,15 +237,14 @@ mkTyData new_or_data context tname list_var list_con i maybe src
   = let t_occ  = rdrNameOcc tname
         name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
        name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
-    in TyData new_or_data context 
-              tname list_var list_con i maybe src name1 name2
+    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] }
 
-mkClassOpSig (DefMeth x) op ty loc
-  = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
+mkClassOpSigDM op ty loc
+  = ClassOpSig op (DefMeth dm_rn) ty loc
   where
     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-mkClassOpSig x op ty loc =
-    ClassOpSig op (Just x) ty loc
 
 mkConDecl cname ex_vars cxt details loc
   = ConDecl cname wkr_name ex_vars cxt details loc
@@ -268,9 +269,9 @@ mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
 
-mkHsNegApp (HsOverLit (HsIntegral   i n)) = HsOverLit (HsIntegral   (-i) n)
-mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
-mkHsNegApp expr                          = NegApp expr negate_RDR
+mkHsNegApp (HsOverLit (HsIntegral   i)) = HsOverLit (HsIntegral   (-i))
+mkHsNegApp (HsOverLit (HsFractional f)) = HsOverLit (HsFractional (-f))
+mkHsNegApp expr                        = NegApp expr
 \end{code}
 
 A useful function for building @OpApps@.  The operator is always a
@@ -332,7 +333,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}