X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=2f16a89feb2ff9111e5626f84f836633e809a535;hb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;hp=ea3414769ee299f43d50847bc18a777d4c8b0e1b;hpb=788faebb40b51d37e73ed94dfc99460d39a1a811;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index ea34147..2f16a89 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -43,14 +43,12 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - extractHsTyRdrNames, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractPatsTyVars, - extractRuleBndrsTyVars, + extractHsTyRdrNames, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, - mkHsNegApp, + mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, + mkHsDo, cvBinds, cvMonoBindsAndSigs, @@ -62,13 +60,11 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it -import HsPat ( collectSigTysFromPats ) import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, - mkGenOcc2, + mkGenOcc2 ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, - ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) import List ( nub ) import BasicTypes ( RecFlag(..) ) import Class ( DefMeth (..) ) @@ -127,20 +123,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 []) @@ -156,15 +143,17 @@ 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 (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) $ @@ -172,13 +161,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 @@ -189,8 +171,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 (TypePatIn ty : _) _ _) acc = extract_ty ty acc + get_m other acc = acc \end{code} @@ -211,7 +193,7 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl cxt cname tyvars fds sigs mbinds 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 } @@ -232,13 +214,12 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc -- 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 +mkTyData new_or_data (context, tname, tyvars) data_cons 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, + tcdTyVars = tyvars, tcdCons = data_cons, tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] } mkClassOpSigDM op ty loc @@ -257,21 +238,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)) = HsOverLit (HsIntegral (-i)) -mkHsNegApp (HsOverLit (HsFractional f)) = HsOverLit (HsFractional (-f)) -mkHsNegApp expr = NegApp expr +mkHsNegApp expr = NegApp expr placeHolderName \end{code} A useful function for building @OpApps@. The operator is always a @@ -281,6 +252,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} +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} + %************************************************************************ %* *