X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=7629070b5862d6aca00b2b22b41182358ced5533;hb=91c750cbd18e3d610b0db498ded38d5b3c5adfac;hp=75fa2934ef962b4393610f9a72f7c839212a543b;hpb=1bba522f5ec82c43abd2ba4e84127b9c915dd020;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 75fa293..7629070 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -14,7 +14,6 @@ module RdrHsSyn ( RdrNameConDecl, RdrNameConDetails, RdrNameContext, - RdrNameSpecDataSig, RdrNameDefaultDecl, RdrNameForeignDecl, RdrNameGRHS, @@ -44,48 +43,31 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - RdrNameClassOpPragmas, - RdrNameClassPragmas, - RdrNameDataPragmas, - RdrNameGenPragmas, - RdrNameInstancePragmas, - extractHsTyRdrNames, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractPatsTyVars, - extractRuleBndrsTyVars, - extractHsCtxtRdrTyVars, + extractHsTyRdrNames, extractHsTyRdrTyVars, + 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, + mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, + mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, 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 RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, - mkSrcUnqual, mkPreludeQual - ) -import HsPragmas +import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) import List ( nub ) -import BasicTypes ( Boxity(..), RecFlag(..) ) +import BasicTypes ( RecFlag(..) ) +import Class ( DefMeth (..) ) \end{code} @@ -103,7 +85,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 @@ -122,18 +103,13 @@ 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 - -type RdrNameClassOpPragmas = ClassOpPragmas RdrName -type RdrNameClassPragmas = ClassPragmas RdrName -type RdrNameDataPragmas = DataPragmas RdrName -type RdrNameGenPragmas = GenPragmas RdrName -type RdrNameInstancePragmas = InstancePragmas RdrName \end{code} @@ -147,20 +123,11 @@ type RdrNameInstancePragmas = InstancePragmas RdrName It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrNames :: HsType RdrName -> [RdrName] +extractHsTyRdrNames :: RdrNameHsType -> [RdrName] extractHsTyRdrNames ty = nub (extract_ty ty []) -extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] -extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty) - -extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName] -extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys)) - -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 +extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] +extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) @@ -169,8 +136,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 @@ -179,10 +146,12 @@ 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 +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) $ @@ -190,12 +159,18 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty) where locals = hsTyVarNames tvs +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 -extractPatsTyVars :: [RdrNamePat] -> [RdrName] -extractPatsTyVars = filter isRdrTyVar . - nub . - extract_tys . - collectSigTysFromPats + get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc + get_m other acc = acc \end{code} @@ -212,10 +187,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 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 { 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 @@ -231,9 +210,18 @@ 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 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 { 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 = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) @@ -262,19 +250,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 negateName \end{code} A useful function for building @OpApps@. The operator is always a @@ -284,31 +260,16 @@ variable, and we don't know the fixity yet. mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 \end{code} +These are the bits of syntax that contain rebindable names +See RnEnv.lookupSyntaxName + \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 +mkHsIntegral i = HsIntegral i fromIntegerName +mkHsFractional f = HsFractional f fromRationalName +mkNPlusKPat n k = NPlusKPatIn n k minusName \end{code} + %************************************************************************ %* * \subsection[rdrBinding]{Bindings straight out of the parser} @@ -360,7 +321,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}