[project @ 2000-11-01 17:15:28 by simonpj]
[ghc-hetmet.git] / ghc / compiler / parser / RdrHsSyn.lhs
index 75fa293..b76c269 100644 (file)
@@ -14,7 +14,6 @@ module RdrHsSyn (
        RdrNameConDecl,
        RdrNameConDetails,
        RdrNameContext,
-       RdrNameSpecDataSig,
        RdrNameDefaultDecl,
        RdrNameForeignDecl,
        RdrNameGRHS,
@@ -44,48 +43,36 @@ module RdrHsSyn (
        RdrMatch(..),
        SigConverter,
 
-       RdrNameClassOpPragmas,
-       RdrNameClassPragmas,
-       RdrNameDataPragmas,
-       RdrNameGenPragmas,
-       RdrNameInstancePragmas,
        extractHsTyRdrNames, 
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
        extractPatsTyVars, 
        extractRuleBndrsTyVars,
-       extractHsCtxtRdrTyVars,
+       extractHsCtxtRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
-       mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn,
-
-       
-       -- some built-in names (all :: RdrName)
-       unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR,
-       tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR,
-       funTyCon_RDR,
+       mkHsNegApp, 
 
        cvBinds,
        cvMonoBindsAndSigs,
        cvTopDecls,
-       cvValSig, cvClassOpSig, cvInstDeclSig
+       cvValSig, cvClassOpSig, cvInstDeclSig,
+        mkTyData
     ) where
 
 #include "HsVersions.h"
 
 import HsSyn           -- Lots of it
-import CmdLineOpts     ( opt_NoImplicitPrelude )
 import HsPat           ( collectSigTysFromPats )
 import OccName         ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
-                          mkSuperDictSelOcc, mkDefaultMethodOcc,
-                         varName, dataName, tcName
+                          mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
+                         mkGenOcc2, 
                        )
-import PrelNames       ( pRELUDE_Name, mkTupNameStr )
+import PrelNames       ( negate_RDR )
 import RdrName         ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
-                         mkSrcUnqual, mkPreludeQual
                        )
-import HsPragmas       
 import List            ( nub )
-import BasicTypes      ( Boxity(..), RecFlag(..) )
+import BasicTypes      ( RecFlag(..) )
+import Class            ( DefMeth (..) )
 \end{code}
 
  
@@ -103,7 +90,6 @@ type RdrNameConDecl          = ConDecl               RdrName
 type RdrNameConDetails         = ConDetails            RdrName
 type RdrNameContext            = HsContext             RdrName
 type RdrNameHsDecl             = HsDecl                RdrName RdrNamePat
-type RdrNameSpecDataSig                = SpecDataSig           RdrName
 type RdrNameDefaultDecl                = DefaultDecl           RdrName
 type RdrNameForeignDecl                = ForeignDecl           RdrName
 type RdrNameGRHS               = GRHS                  RdrName RdrNamePat
@@ -128,12 +114,6 @@ type RdrNameDeprecation         = DeprecDecl            RdrName
 type RdrNameFixitySig          = FixitySig             RdrName
 
 type RdrNameHsRecordBinds      = HsRecordBinds         RdrName RdrNamePat
-
-type RdrNameClassOpPragmas     = ClassOpPragmas        RdrName
-type RdrNameClassPragmas       = ClassPragmas          RdrName
-type RdrNameDataPragmas                = DataPragmas           RdrName
-type RdrNameGenPragmas         = GenPragmas            RdrName
-type RdrNameInstancePragmas    = InstancePragmas       RdrName
 \end{code}
 
 
@@ -183,6 +163,10 @@ 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
+extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsNumTy num)              acc = acc
+-- Generics
 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
                                 acc = acc ++
                                       (filter (`notElem` locals) $
@@ -196,6 +180,19 @@ extractPatsTyVars = filter isRdrTyVar .
                    nub . 
                    extract_tys .
                    collectSigTysFromPats
+
+extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
+-- Get the type variables out of the type patterns in a bunch of
+-- possibly-generic bindings in a class declaration
+extractGenericPatTyVars binds
+  = filter isRdrTyVar (nub (get binds []))
+  where
+    get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
+    get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
+    get other                 acc = acc
+
+    get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
+    get_m other                                   acc = acc
 \end{code}
 
 
@@ -214,8 +211,8 @@ file (which would be equally good).
 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 dwname sc_sel_names loc
+mkClassDecl cxt cname tyvars fds sigs mbinds loc
+  = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc
   where
     cls_occ  = rdrNameOcc cname
     data_occ = mkClassDataConOcc cls_occ
@@ -231,11 +228,22 @@ mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
       --      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
-  = ClassOpSig op (Just (dm_rn, has_default_method)) ty loc
+    new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
+
+-- mkTyData :: ??
+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
+
+mkClassOpSig (DefMeth x) op ty loc
+  = ClassOpSig op (Just (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
@@ -262,19 +270,7 @@ 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 (prelQual varName SLIT("negate"))
-\end{code}
-
-\begin{code}
-mkHsIntegralLit :: Integer -> HsOverLit RdrName
-mkHsIntegralLit i = HsIntegral i (prelQual varName SLIT("fromInteger"))
-
-mkHsFractionalLit :: Rational -> HsOverLit RdrName
-mkHsFractionalLit f = HsFractional f (prelQual varName SLIT("fromRational"))
-
-mkNPlusKPatIn :: RdrName -> HsOverLit RdrName -> RdrNamePat
-mkNPlusKPatIn n k = NPlusKPatIn n k (prelQual varName SLIT("-"))
+mkHsNegApp expr                          = NegApp expr negate_RDR
 \end{code}
 
 A useful function for building @OpApps@.  The operator is always a
@@ -284,30 +280,6 @@ variable, and we don't know the fixity yet.
 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 \end{code}
 
-\begin{code}
------------------------------------------------------------------------------
--- Built-in names
--- Qualified Prelude names are always in scope; so we can just say Prelude.[]
--- for the list type constructor, say.   But it's not so easy when we say
--- -fno-implicit-prelude.   Then you just get whatever "[]" happens to be in scope.
-
-unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
-tupleCon_RDR, tupleTyCon_RDR           :: Int -> RdrName
-ubxTupleCon_RDR, ubxTupleTyCon_RDR     :: Int -> RdrName
-
-unitCon_RDR            = prelQual dataName SLIT("()")
-unitTyCon_RDR          = prelQual tcName   SLIT("()")
-nilCon_RDR             = prelQual dataName SLIT("[]")
-listTyCon_RDR          = prelQual tcName   SLIT("[]")
-funTyCon_RDR           = prelQual tcName   SLIT("(->)")
-tupleCon_RDR arity      = prelQual dataName (snd (mkTupNameStr Boxed arity))
-tupleTyCon_RDR arity    = prelQual tcName   (snd (mkTupNameStr Boxed arity))
-ubxTupleCon_RDR arity   = prelQual dataName (snd (mkTupNameStr Unboxed arity))
-ubxTupleTyCon_RDR arity = prelQual tcName   (snd (mkTupNameStr Unboxed arity))
-
-prelQual ns occ | opt_NoImplicitPrelude = mkSrcUnqual   ns occ
-               | otherwise             = mkPreludeQual ns pRELUDE_Name occ
-\end{code}
 
 %************************************************************************
 %*                                                                     *