X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FRdrHsSyn.lhs;h=2f16a89feb2ff9111e5626f84f836633e809a535;hb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;hp=d1b0e0ed02df70d1997c2662e94840c76f86fa2f;hpb=fe69f3c1d6062b90635963aa414c33951bf18427;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index d1b0e0e..2f16a89 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,39 +43,31 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - RdrNameClassOpPragmas, - RdrNameClassPragmas, - RdrNameDataPragmas, - RdrNameGenPragmas, - RdrNameInstancePragmas, - extractHsTyRdrNames, - extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractPatsTyVars, - extractRuleBndrsTyVars, - extractHsCtxtRdrTyVars, + extractHsTyRdrNames, extractHsTyRdrTyVars, + extractHsCtxtRdrTyVars, extractGenericPatTyVars, - mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl, + mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, + mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, + mkHsDo, cvBinds, cvMonoBindsAndSigs, cvTopDecls, - cvValSig, cvClassOpSig, cvInstDeclSig + cvValSig, cvClassOpSig, cvInstDeclSig, + mkTyData ) where #include "HsVersions.h" -import HsSyn -import HsPat ( collectSigTysFromPats ) -import Name ( mkClassTyConOcc, mkClassDataConOcc ) +import HsSyn -- Lots of it import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc + mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, + mkGenOcc2 ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc ) -import Util ( thenCmp ) -import HsPragmas +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) import List ( nub ) import BasicTypes ( RecFlag(..) ) -import Outputable +import Class ( DefMeth (..) ) \end{code} @@ -94,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 @@ -113,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} @@ -138,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 []) @@ -160,20 +136,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 (HsNumTy num) acc = acc +extract_ty (HsKindSig ty k) acc = extract_ty ty acc extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ (filter (`notElem` locals) $ @@ -181,14 +161,27 @@ 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} + +%************************************************************************ +%* * +\subsection{Construction functions for Rdr stuff} +%* * +%************************************************************************ + mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon by deriving them from the name of the class. We fill in the names for the tycon and datacon corresponding to the class, by deriving them from the @@ -196,10 +189,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 @@ -215,9 +212,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, 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 = tyvars, tcdCons = data_cons, + 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)) @@ -227,13 +233,36 @@ mkConDecl cname ex_vars cxt details loc wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname)) \end{code} -A useful function for building @OpApps@. The operator is always a variable, -and we don't know the fixity yet. +\begin{code} +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! + +mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) +mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) +mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) +mkHsNegApp expr = NegApp expr placeHolderName +\end{code} + +A useful function for building @OpApps@. The operator is always a +variable, and we don't know the fixity yet. \begin{code} -mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 +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} + + %************************************************************************ %* * \subsection[rdrBinding]{Bindings straight out of the parser} @@ -285,7 +314,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}