X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=de668a882f9cceacdd244f8acb4ecd5bfc145be8;hb=b28e7f858c020e23abc5cdd5b064837458d48f13;hp=2726ef27c9093ac5b77d48ec60a8a948910d8481;hpb=aa44169c3c01243cdbf38f50f58e80477586552c;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 2726ef2..de668a8 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,25 +43,12 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - RdrNameClassOpPragmas, - RdrNameClassPragmas, - RdrNameDataPragmas, - RdrNameGenPragmas, - RdrNameInstancePragmas, - extractHsTyRdrNames, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractPatsTyVars, + extractHsTyRdrNames, extractHsTyRdrTyVars, extractRuleBndrsTyVars, 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, @@ -74,19 +60,14 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it -import CmdLineOpts ( opt_NoImplicitPrelude ) -import HsPat ( collectSigTysFromPats ) import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, - mkGenOcc2, varName, dataName, tcName + mkGenOcc2, ) -import PrelNames ( pRELUDE_Name, mkTupNameStr ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, - mkUnqual, 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} @@ -105,7 +86,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 @@ -124,18 +104,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} @@ -149,14 +124,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)) +extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] +extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName] extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs)) @@ -171,8 +143,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 @@ -181,8 +153,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 @@ -196,13 +166,6 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty) where locals = hsTyVarNames tvs - -extractPatsTyVars :: [RdrNamePat] -> [RdrName] -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 @@ -231,10 +194,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 new_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 @@ -250,22 +217,21 @@ 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!) - new_names = toClassDeclNameList (tname, dname, dwname, sc_sel_names) + new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names) -- mkTyData :: ?? -mkTyData new_or_data context tname list_var list_con i maybe pragmas src = - let t_occ = rdrNameOcc tname +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 pragmas 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 @@ -292,19 +258,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 @@ -314,31 +268,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 = mkUnqual 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} @@ -390,7 +329,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}