X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FRdrHsSyn.lhs;h=fc1fde5fe3c3efa4f6665cded3891564d78a7df6;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=e884ce0de9eaecebcdf8acc637e90a663ba14d65;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index e884ce0..fc1fde5 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} @@ -7,83 +7,94 @@ they are used somewhat later on in the compiler...) \begin{code} -#include "HsVersions.h" - module RdrHsSyn ( - RdrNameArithSeqInfo(..), - RdrNameBangType(..), - RdrNameBind(..), - RdrNameClassDecl(..), - RdrNameClassOpSig(..), - RdrNameConDecl(..), - RdrNameContext(..), - RdrNameSpecDataSig(..), - RdrNameDefaultDecl(..), - RdrNameFixityDecl(..), - RdrNameGRHS(..), - RdrNameGRHSsAndBinds(..), - RdrNameHsBinds(..), - RdrNameHsExpr(..), - RdrNameHsModule(..), - RdrNameIE(..), - RdrNameImportDecl(..), - RdrNameInstDecl(..), - RdrNameMatch(..), - RdrNameMonoBinds(..), - RdrNameMonoType(..), - RdrNamePat(..), - RdrNamePolyType(..), - RdrNameQual(..), - RdrNameSig(..), - RdrNameSpecInstSig(..), - RdrNameStmt(..), - RdrNameTyDecl(..), - - RdrNameClassOpPragmas(..), - RdrNameClassPragmas(..), - RdrNameDataPragmas(..), - RdrNameGenPragmas(..), - RdrNameInstancePragmas(..), - RdrNameCoreExpr(..), - - getRawImportees, - getRawExportees + RdrNameArithSeqInfo, + RdrNameBangType, + RdrNameClassDecl, + RdrNameClassOpSig, + RdrNameConDecl, + RdrNameContext, + RdrNameSpecDataSig, + RdrNameDefaultDecl, + RdrNameForeignDecl, + RdrNameFixityDecl, + RdrNameGRHS, + RdrNameGRHSsAndBinds, + RdrNameHsBinds, + RdrNameHsDecl, + RdrNameHsExpr, + RdrNameHsModule, + RdrNameIE, + RdrNameImportDecl, + RdrNameInstDecl, + RdrNameMatch, + RdrNameMonoBinds, + RdrNamePat, + RdrNameHsType, + RdrNameSig, + RdrNameStmt, + RdrNameTyDecl, + + RdrNameClassOpPragmas, + RdrNameClassPragmas, + RdrNameDataPragmas, + RdrNameGenPragmas, + RdrNameInstancePragmas, + extractHsTyVars, extractHsCtxtTyVars, + + RdrName(..), + qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual, + mkTupConRdrName, mkUbxTupConRdrName, + dummyRdrVarName, dummyRdrTcName, + isUnqual, isQual, + rdrNameOcc, rdrNameModule, ieOcc, + cmpRdr, prefixRdrName, + mkOpApp, mkClassDecl, isClassDataConRdrName + ) where -import Ubiq +#include "HsVersions.h" import HsSyn -import Name ( ExportFlag(..) ) +import BasicTypes ( Module, IfaceFlavour(..), Unused ) +import Name ( pprModule, OccName(..), pprOccName, + mkTupNameStr, mkUbxTupNameStr, + prefixOccName, NamedThing(..), + mkClassTyConStr, mkClassDataConStr ) +import Util ( thenCmp ) +import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas ) +import List ( nub ) +import Outputable + +import Char ( isUpper ) \end{code} \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat +type RdrNameArithSeqInfo = ArithSeqInfo Unused RdrName RdrNamePat type RdrNameBangType = BangType RdrName -type RdrNameBind = Bind Fake Fake RdrName RdrNamePat -type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat +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 RdrNameSpecDataSig = SpecDataSig RdrName type RdrNameDefaultDecl = DefaultDecl RdrName +type RdrNameForeignDecl = ForeignDecl RdrName type RdrNameFixityDecl = FixityDecl RdrName -type RdrNameGRHS = GRHS Fake Fake RdrName RdrNamePat -type RdrNameGRHSsAndBinds = GRHSsAndBinds Fake Fake RdrName RdrNamePat -type RdrNameHsBinds = HsBinds Fake Fake RdrName RdrNamePat -type RdrNameHsExpr = HsExpr Fake Fake RdrName RdrNamePat -type RdrNameHsModule = HsModule Fake Fake RdrName RdrNamePat +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 RdrNameIE = IE RdrName type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat -type RdrNameMatch = Match Fake Fake RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat -type RdrNameMonoType = MonoType RdrName +type RdrNameInstDecl = InstDecl Unused RdrName RdrNamePat +type RdrNameMatch = Match Unused RdrName RdrNamePat +type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat type RdrNamePat = InPat RdrName -type RdrNamePolyType = PolyType RdrName -type RdrNameQual = Qual Fake Fake RdrName RdrNamePat +type RdrNameHsType = HsType RdrName type RdrNameSig = Sig RdrName -type RdrNameSpecInstSig = SpecInstSig RdrName -type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat +type RdrNameStmt = Stmt Unused RdrName RdrNamePat type RdrNameTyDecl = TyDecl RdrName type RdrNameClassOpPragmas = ClassOpPragmas RdrName @@ -91,34 +102,166 @@ type RdrNameClassPragmas = ClassPragmas RdrName type RdrNameDataPragmas = DataPragmas RdrName type RdrNameGenPragmas = GenPragmas RdrName type RdrNameInstancePragmas = InstancePragmas RdrName -type RdrNameCoreExpr = UnfoldingCoreExpr 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 acc ctxt + where + extract_ass (cls, tys) acc = foldr extract_ty 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 acc tys +extract_ty (MonoTyVar tv) acc = insert tv acc +extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++ + (filter (`notElem` locals) $ + extract_ctxt ctxt (extract_ty ty [])) + where + locals = map getTyVarName tvs + +insert (Qual _ _ _) acc = acc +insert (Unqual (TCOcc _)) acc = acc +insert other acc = other : acc +\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. + +\begin{code} +mkClassDecl cxt cname tyvars sigs mbinds prags loc + = ClassDecl cxt cname tyvars sigs mbinds prags tname dname 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 = mkClassTyConStr s + + Unqual (TCOcc s) -> (Unqual (VarOcc s1), Unqual (TCOcc s1)) + where + s1 = mkClassDataConStr 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{Grabbing importees and exportees} +\subsection[RdrName]{The @RdrName@ datatype; names read from files} %* * %************************************************************************ \begin{code} -getRawImportees :: [RdrNameIE] -> [RdrName] -getRawExportees :: Maybe [RdrNameIE] -> ([(RdrName, ExportFlag)], [Module]) +data RdrName + = Unqual OccName + | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only), + -- HiFile for the common M.t -getRawImportees imps - = foldr do_imp [] imps - where - do_imp (IEVar n) acc = n:acc - do_imp (IEThingAbs n) acc = n:acc - do_imp (IEThingWith n _) acc = n:acc - do_imp (IEThingAll n) acc = n:acc - -getRawExportees Nothing = ([], []) -getRawExportees (Just exps) - = foldr do_exp ([],[]) exps - where - do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods) - do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods) - do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods) - do_exp (IEThingWith n _) (prs, mods) = ((n, ExportAll):prs, mods) - do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods) +qual (m,n) = Qual m n HiFile +tcQual (m,n) = Qual m (TCOcc n) HiFile +varQual (m,n) = Qual m (VarOcc n) HiFile + +mkTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor + -- Hence VarOcc +mkTupConRdrName arity = case mkTupNameStr arity of + (mod, occ) -> Qual mod (VarOcc occ) HiFile + +mkUbxTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor + -- Hence VarOcc +mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of + (mod, occ) -> Qual mod (VarOcc occ) 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 Show RdrName where -- debugging + showsPrec p rn = showsPrecSDoc p (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" \end{code} +