X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FRdrHsSyn.lhs;h=266cb949de08c025da4cc6e60563217714693bdb;hb=6ee2f67e582427f931c21c1fc58f62f8619d40b7;hp=338e025c43dedc62cc8e4be1a67fe9644e3ff01e;hpb=b2bcd65847b48f62fd72497ccf43d867901ecf26;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 338e025..266cb94 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader} @@ -10,15 +10,14 @@ they are used somewhat later on in the compiler...) module RdrHsSyn ( RdrNameArithSeqInfo, RdrNameBangType, - RdrNameClassDecl, RdrNameClassOpSig, RdrNameConDecl, RdrNameContext, RdrNameSpecDataSig, RdrNameDefaultDecl, - RdrNameFixityDecl, + RdrNameForeignDecl, RdrNameGRHS, - RdrNameGRHSsAndBinds, + RdrNameGRHSs, RdrNameHsBinds, RdrNameHsDecl, RdrNameHsExpr, @@ -32,66 +31,68 @@ module RdrHsSyn ( RdrNameHsType, RdrNameSig, RdrNameStmt, - RdrNameTyDecl, + RdrNameTyClDecl, + RdrNameRuleBndr, + RdrNameRuleDecl, RdrNameClassOpPragmas, RdrNameClassPragmas, RdrNameDataPragmas, RdrNameGenPragmas, RdrNameInstancePragmas, - extractHsTyVars, extractHsCtxtTyVars, - - RdrName(..), - qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual, - dummyRdrVarName, dummyRdrTcName, - isUnqual, isQual, - showRdr, rdrNameOcc, rdrNameModule, ieOcc, - cmpRdr, prefixRdrName, - mkOpApp, mkClassDecl, isClassDataConRdrName + extractHsTyRdrNames, + extractPatsTyVars, extractRuleBndrsTyVars, + mkOpApp, mkClassDecl, mkClassOpSig ) where #include "HsVersions.h" import HsSyn -import Lex -import BasicTypes ( Module, IfaceFlavour(..), Unused ) -import Name ( pprModule, OccName(..), pprOccName, - prefixOccName, NamedThing(..) ) +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 - -import Char ( isUpper ) \end{code} + +%************************************************************************ +%* * +\subsection{Type synonyms} +%* * +%************************************************************************ + \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo Unused RdrName RdrNamePat +type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat type RdrNameBangType = BangType RdrName -type RdrNameClassDecl = ClassDecl Unused RdrName RdrNamePat type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName type RdrNameContext = Context RdrName -type RdrNameHsDecl = HsDecl Unused RdrName RdrNamePat +type RdrNameHsDecl = HsDecl RdrName RdrNamePat type RdrNameSpecDataSig = SpecDataSig RdrName type RdrNameDefaultDecl = DefaultDecl RdrName -type RdrNameFixityDecl = FixityDecl RdrName -type RdrNameGRHS = GRHS Unused RdrName RdrNamePat -type RdrNameGRHSsAndBinds = GRHSsAndBinds Unused RdrName RdrNamePat -type RdrNameHsBinds = HsBinds Unused RdrName RdrNamePat -type RdrNameHsExpr = HsExpr Unused RdrName RdrNamePat -type RdrNameHsModule = HsModule Unused RdrName RdrNamePat +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 Unused RdrName RdrNamePat -type RdrNameMatch = Match Unused RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat +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 Unused RdrName RdrNamePat -type RdrNameTyDecl = TyDecl 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 @@ -100,44 +101,65 @@ type RdrNameGenPragmas = GenPragmas RdrName type RdrNameInstancePragmas = InstancePragmas RdrName \end{code} -@extractHsTyVars@ looks just for things that could be type variables. -It's used when making the for-alls explicit. - -\begin{code} -extractHsTyVars :: HsType RdrName -> [RdrName] -extractHsTyVars ty = nub (extract_ty ty []) -extractHsCtxtTyVars :: Context RdrName -> [RdrName] -extractHsCtxtTyVars ty = nub (extract_ctxt ty []) - -extract_ctxt ctxt acc = foldr extract_ass [] ctxt - where - extract_ass (cls, tys) acc = foldr extract_ty acc tys +%************************************************************************ +%* * +\subsection{A few functions over HsSyn at RdrName} +%* * +%************************************************************************ -extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoListTy tc ty) acc = extract_ty ty acc -extract_ty (MonoTupleTy tc 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 acc tys -extract_ty (MonoTyVar tv) acc = insert tv acc +@extractHsTyRdrNames@ finds the free variables of a HsType +It's used when making the for-alls explicit. - -- In (All a => a -> a) -> Int, there are no free tyvars - -- We just assume that we quantify over all type variables mentioned in the context. -extract_ty (HsPreForAllTy ctxt ty) acc = filter (`notElem` locals) (extract_ty ty []) - ++ acc - where - locals = extract_ctxt ctxt [] +\begin{code} +extractHsTyRdrNames :: HsType RdrName -> [RdrName] +extractHsTyRdrNames ty = nub (extract_ty ty []) -extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++ - (filter (`notElem` locals) $ - extract_ctxt ctxt (extract_ty ty [])) - where - locals = map getTyVarName tvs +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 []) -insert (Qual _ _ _) acc = acc -insert (Unqual (TCOcc _)) acc = acc -insert other acc = other : acc +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} @@ -149,115 +171,32 @@ 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. +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 loc + = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc where - -- The datacon and tycon are called ":C" where the class is C - -- This prevents name clashes with user-defined tycons or datacons C - (dname, tname) = case cname of - Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif) - where - s1 = SLIT(":") _APPEND_ s - - Unqual (TCOcc s) -> (Unqual (VarOcc s1), Unqual (TCOcc s1)) - where - s1 = SLIT(":") _APPEND_ s - --- This nasty little function tests for whether a RdrName was --- constructed by the above process. It's used only for filtering --- out duff error messages. Maybe there's a tidier way of doing this --- but I can't work up the energy to find it. - -isClassDataConRdrName rdr_name - = case rdrNameOcc rdr_name of - TCOcc s -> case _UNPK_ s of - ':' : c : _ -> isUpper c - other -> False - other -> False -\end{code} - -%************************************************************************ -%* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} -%* * -%************************************************************************ - -\begin{code} -data RdrName - = Unqual OccName - | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only), - -- HiFile for the common M.t - -qual (m,n) = Qual m n HiFile -tcQual (m,n) = Qual m (TCOcc n) HiFile -varQual (m,n) = Qual m (VarOcc n) HiFile - -lexTcQual (m,n,hif) = Qual m (TCOcc n) hif -lexVarQual (m,n,hif) = Qual m (VarOcc n) hif - - -- This guy is used by the reader when HsSyn has a slot for - -- an implicit name that's going to be filled in by - -- the renamer. We can't just put "error..." because - -- we sometimes want to print out stuff after reading but - -- before renaming -dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY")) -dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY")) - - -varUnqual n = Unqual (VarOcc n) - -isUnqual (Unqual _) = True -isUnqual (Qual _ _ _) = False - -isQual (Unqual _) = False -isQual (Qual _ _ _) = True - - -- Used for adding a prefix to a RdrName -prefixRdrName :: FAST_STRING -> RdrName -> RdrName -prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif -prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n) - -cmpRdr (Unqual n1) (Unqual n2) = n1 `compare` n2 -cmpRdr (Unqual n1) (Qual m2 n2 _) = LT -cmpRdr (Qual m1 n1 _) (Unqual n2) = GT -cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2) - -- always compare module-names *second* - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Qual _ occ _) = occ - -rdrNameModule :: RdrName -> Module -rdrNameModule (Qual m _ _) = m - -ieOcc :: RdrNameIE -> OccName -ieOcc ie = rdrNameOcc (ieName ie) - -instance Text RdrName where -- debugging - showsPrec _ rn = showString (showSDoc (ppr rn)) - -instance Eq RdrName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpRdr a b - -instance Outputable RdrName where - ppr (Unqual n) = pprOccName n - ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n] - -instance NamedThing RdrName where -- Just so that pretty-printing of expressions works - getOccName = rdrNameOcc - getName = panic "no getName for RdrNames" - -showRdr rdr = showSDoc (ppr rdr) + 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} -