X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=b00d84d30850d83ccd5a1ee11b219df0560e2ec5;hb=9af77fa423926fbda946b31e174173d0ec5ebac8;hp=b76c269fd1ae1e60a48b6ae03c48ab317542e649;hpb=2ffefc1bfca0c8924825cd15750e7ced457f3c81;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index b76c269..b00d84d 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -16,6 +16,7 @@ module RdrHsSyn ( RdrNameContext, RdrNameDefaultDecl, RdrNameForeignDecl, + RdrNameCoreDecl, RdrNameGRHS, RdrNameGRHSs, RdrNameHsBinds, @@ -43,14 +44,12 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - extractHsTyRdrNames, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractPatsTyVars, - extractRuleBndrsTyVars, + extractHsTyRdrNames, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl, - mkHsNegApp, + mkHsOpApp, mkClassDecl, mkClassOpSigDM, + mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, + mkHsDo, mkHsSplice, cvBinds, cvMonoBindsAndSigs, @@ -62,16 +61,10 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it -import HsPat ( collectSigTysFromPats ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, - mkGenOcc2, - ) -import PrelNames ( negate_RDR ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, - ) +import OccName ( mkDefaultMethodOcc, mkVarOcc ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) import List ( nub ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), FixitySig ) import Class ( DefMeth (..) ) \end{code} @@ -83,37 +76,39 @@ import Class ( DefMeth (..) ) %************************************************************************ \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat +type RdrNameArithSeqInfo = ArithSeqInfo RdrName type RdrNameBangType = BangType RdrName type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName -type RdrNameConDetails = ConDetails RdrName +type RdrNameConDetails = HsConDetails RdrName RdrNameBangType type RdrNameContext = HsContext RdrName -type RdrNameHsDecl = HsDecl RdrName RdrNamePat +type RdrNameHsDecl = HsDecl RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameGRHS = GRHS RdrName RdrNamePat -type RdrNameGRHSs = GRHSs RdrName RdrNamePat -type RdrNameHsBinds = HsBinds RdrName RdrNamePat -type RdrNameHsExpr = HsExpr RdrName RdrNamePat -type RdrNameHsModule = HsModule RdrName RdrNamePat +type RdrNameCoreDecl = CoreDecl RdrName +type RdrNameGRHS = GRHS RdrName +type RdrNameGRHSs = GRHSs RdrName +type RdrNameHsBinds = HsBinds RdrName +type RdrNameHsExpr = HsExpr RdrName +type RdrNameHsModule = HsModule RdrName type RdrNameIE = IE RdrName type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl RdrName RdrNamePat -type RdrNameMatch = Match RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat +type RdrNameInstDecl = InstDecl RdrName +type RdrNameMatch = Match RdrName +type RdrNameMonoBinds = MonoBinds RdrName type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName type RdrNameHsTyVar = HsTyVarBndr RdrName type RdrNameSig = Sig RdrName -type RdrNameStmt = Stmt RdrName RdrNamePat -type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat +type RdrNameStmt = Stmt RdrName +type RdrNameTyClDecl = TyClDecl RdrName + type RdrNameRuleBndr = RuleBndr RdrName -type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat +type RdrNameRuleDecl = RuleDecl RdrName type RdrNameDeprecation = DeprecDecl RdrName type RdrNameFixitySig = FixitySig RdrName -type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat +type RdrNameHsRecordBinds = HsRecordBinds RdrName \end{code} @@ -127,20 +122,11 @@ type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat 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 []) @@ -149,24 +135,24 @@ 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 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsPArrTy 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) +extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc) +extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsParTy ty) acc = 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 (HsKindSig ty k) acc = extract_ty ty acc extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ (filter (`notElem` locals) $ @@ -174,13 +160,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 @@ -191,8 +170,8 @@ extractGenericPatTyVars binds 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 + get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc + get_m other acc = acc \end{code} @@ -209,46 +188,24 @@ 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 - where - cls_occ = rdrNameOcc cname - data_occ = mkClassDataConOcc 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 - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - 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 +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc + = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, + tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, + tcdLoc = loc } + +mkTyData new_or_data (context, tname, tyvars) data_cons maybe src + = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, + tcdTyVars = tyvars, tcdCons = data_cons, + tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } + +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 - where - wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname)) \end{code} \begin{code} @@ -256,21 +213,11 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr -- If the type checker sees (negate 3#) it will barf, because negate -- can't take an unboxed arg. But that is exactly what it will see when -- we write "-3#". So we have to do the negation right now! --- --- We also do the same service for boxed literals, because this function --- is also used for patterns (which, remember, are parsed as expressions) --- and pattern don't have negation in them. --- --- Finally, it's important to represent minBound as minBound, and not --- as (negate (-minBound)), becuase the latter is out of range. 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 expr = NegApp expr placeHolderName \end{code} A useful function for building @OpApps@. The operator is always a @@ -280,6 +227,23 @@ 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} +mkHsIntegral i = HsIntegral i placeHolderName +mkHsFractional f = HsFractional f placeHolderName +mkNPlusKPat n k = NPlusKPatIn n k placeHolderName +mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc +\end{code} + +\begin{code} +mkHsSplice e = HsSplice unqualSplice e + +unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) + -- A name (uniquified later) to + -- identify the splice +\end{code} %************************************************************************ %* * @@ -332,7 +296,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}