X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FRdrHsSyn.lhs;fp=ghc%2Fcompiler%2Freader%2FRdrHsSyn.lhs;h=0000000000000000000000000000000000000000;hb=904f158f9fe208b8154029dff655a6eab4b2828e;hp=266cb949de08c025da4cc6e60563217714693bdb;hpb=6ee2f67e582427f931c21c1fc58f62f8619d40b7;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs deleted file mode 100644 index 266cb94..0000000 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ /dev/null @@ -1,202 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader} - -(Well, really, for specialisations involving @RdrName@s, even if -they are used somewhat later on in the compiler...) - -\begin{code} -module RdrHsSyn ( - RdrNameArithSeqInfo, - RdrNameBangType, - RdrNameClassOpSig, - RdrNameConDecl, - RdrNameContext, - RdrNameSpecDataSig, - RdrNameDefaultDecl, - RdrNameForeignDecl, - RdrNameGRHS, - RdrNameGRHSs, - RdrNameHsBinds, - RdrNameHsDecl, - RdrNameHsExpr, - RdrNameHsModule, - RdrNameIE, - RdrNameImportDecl, - RdrNameInstDecl, - RdrNameMatch, - RdrNameMonoBinds, - RdrNamePat, - RdrNameHsType, - RdrNameSig, - RdrNameStmt, - RdrNameTyClDecl, - RdrNameRuleBndr, - RdrNameRuleDecl, - - RdrNameClassOpPragmas, - RdrNameClassPragmas, - RdrNameDataPragmas, - RdrNameGenPragmas, - RdrNameInstancePragmas, - extractHsTyRdrNames, - extractPatsTyVars, extractRuleBndrsTyVars, - - mkOpApp, mkClassDecl, mkClassOpSig - ) where - -#include "HsVersions.h" - -import HsSyn -import OccName ( mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc - ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc ) -import Util ( thenCmp ) -import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas ) -import List ( nub ) -import Outputable -\end{code} - - -%************************************************************************ -%* * -\subsection{Type synonyms} -%* * -%************************************************************************ - -\begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat -type RdrNameBangType = BangType RdrName -type RdrNameClassOpSig = Sig RdrName -type RdrNameConDecl = ConDecl RdrName -type RdrNameContext = Context RdrName -type RdrNameHsDecl = HsDecl RdrName RdrNamePat -type RdrNameSpecDataSig = SpecDataSig 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 RdrNameIE = IE RdrName -type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl RdrName RdrNamePat -type RdrNameMatch = Match RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat -type RdrNamePat = InPat RdrName -type RdrNameHsType = HsType 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 RdrNameClassOpPragmas = ClassOpPragmas RdrName -type RdrNameClassPragmas = ClassPragmas RdrName -type RdrNameDataPragmas = DataPragmas RdrName -type RdrNameGenPragmas = GenPragmas RdrName -type RdrNameInstancePragmas = InstancePragmas RdrName -\end{code} - - -%************************************************************************ -%* * -\subsection{A few functions over HsSyn at RdrName} -%* * -%************************************************************************ - -@extractHsTyRdrNames@ finds the free variables of a HsType -It's used when making the for-alls explicit. - -\begin{code} -extractHsTyRdrNames :: HsType RdrName -> [RdrName] -extractHsTyRdrNames ty = nub (extract_ty ty []) - -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 - -extractHsCtxtRdrNames :: Context RdrName -> [RdrName] -extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) - -extract_ctxt ctxt acc = foldr extract_ass acc ctxt - where - extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys - -extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoListTy ty) acc = extract_ty ty acc -extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys -extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys -extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc -extract_ty (MonoTyVar tv) acc = tv : acc -extract_ty (HsForAllTy (Just tvs) ctxt ty) - acc = acc ++ - (filter (`notElem` locals) $ - extract_ctxt ctxt (extract_ty ty [])) - where - locals = map getTyVarName tvs - - -extractPatsTyVars :: [RdrNamePat] -> [RdrName] -extractPatsTyVars pats = nub (foldr extract_pat [] pats) - -extract_pat (SigPatIn pat ty) acc = extract_ty ty acc -extract_pat WildPatIn acc = acc -extract_pat (VarPatIn var) acc = acc -extract_pat (LitPatIn _) acc = acc -extract_pat (LazyPatIn pat) acc = extract_pat pat acc -extract_pat (AsPatIn a pat) acc = extract_pat pat acc -extract_pat (NPlusKPatIn n _) acc = acc -extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats -extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc) -extract_pat (NegPatIn pat) acc = extract_pat pat acc -extract_pat (ParPatIn pat) acc = extract_pat pat acc -extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats -extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats -extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields -\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 -\end{code} - -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 -name of the class itself. This saves recording the names in the interface -file (which would be equally good). - -Similarly for mkClassOpSig and default-method names. - -\begin{code} -mkClassDecl cxt cname tyvars sigs mbinds prags loc - = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc - where - cls_occ = rdrNameOcc cname - dname = mkRdrUnqual (mkClassDataConOcc cls_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!) - -mkClassOpSig has_default_method op ty loc - | not has_default_method = ClassOpSig op Nothing ty loc - | otherwise = ClassOpSig op (Just dm_rn) ty loc - where - dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) -\end{code}