X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=c2feb2af26a4ce2d4782cba58d55b739e0d20686;hb=f8d8ea662828a295e27a2f5f52ce38d68fd3dee2;hp=3f949aafecee17c6257655bad0e4b0f5c0800e58;hpb=fda89b29c748c6cd2fe1fdb477d5c0e8f7d32b90;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 3f949aa..c2feb2a 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{Haskell abstract syntax definition} @@ -8,72 +8,50 @@ which is declared in the various \tr{Hs*} modules. This module, therefore, is almost nothing but re-exporting. \begin{code} -#include "HsVersions.h" - module HsSyn ( - -- NB: don't reexport HsCore or HsPragmas; + -- NB: don't reexport HsCore -- this module tells about "real Haskell" - EXP_MODULE(HsSyn) , - EXP_MODULE(HsBinds) , - EXP_MODULE(HsDecls) , - EXP_MODULE(HsExpr) , - EXP_MODULE(HsImpExp) , - EXP_MODULE(HsBasic) , - EXP_MODULE(HsMatches) , - EXP_MODULE(HsPat) , - EXP_MODULE(HsTypes), - Fixity, NewOrData, IfaceFlavour, - - collectTopBinders, collectMonoBinders + module HsSyn, + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsTypes, + Fixity, NewOrData, + + collectHsBinders, collectLocatedHsBinders, + collectMonoBinders, collectLocatedMonoBinders, + hsModuleName, hsModuleImports ) where -IMP_Ubiq() +#include "HsVersions.h" -- friends: +import HsDecls import HsBinds -import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), - DefaultDecl(..), - FixityDecl(..), - ConDecl(..), ConDetails(..), BangType(..), - IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..), - hsDeclName - ) import HsExpr import HsImpExp -import HsBasic -import HsMatches +import HsLit import HsPat import HsTypes -import HsPragmas ( ClassPragmas, ClassOpPragmas, - DataPragmas, GenPragmas, InstancePragmas ) -import HsCore -import BasicTypes ( Fixity, SYN_IE(Version), NewOrData, IfaceFlavour ) +import BasicTypes ( Fixity, Version, NewOrData ) -- others: -import FiniteMap ( FiniteMap ) -import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) ) -import Pretty +import Name ( NamedThing ) +import Outputable import SrcLoc ( SrcLoc ) -import Bag -#if __GLASGOW_HASKELL__ >= 202 -import Name -#endif -\end{code} - -@Fake@ is a placeholder type; for when tyvars and uvars aren't used. -\begin{code} -data Fake = Fake -instance Eq Fake -instance Outputable Fake +import Module ( ModuleName ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} -data HsModule tyvar uvar name pat +data HsModule name pat = HsModule - Module -- module name + ModuleName -- module name (Maybe Version) -- source interface version number (Maybe [IE name]) -- export list; Nothing => export everything -- Just [] => export *nothing* (???) @@ -82,38 +60,40 @@ data HsModule tyvar uvar name pat -- imported interfaces early on, adding that -- info to TyDecls/etc; so this list is -- often empty, downstream. - [FixityDecl name] - [HsDecl tyvar uvar name pat] -- Type, class, value, and interface signature decls + [HsDecl name pat] -- Type, class, value, and interface signature decls + (Maybe DeprecTxt) -- reason/explanation for deprecation of this module SrcLoc \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => Outputable (HsModule tyvar uvar name pat) where +instance (NamedThing name, Outputable name, Outputable pat) + => Outputable (HsModule name pat) where - ppr sty (HsModule name iface_version exports imports fixities - decls src_loc) + ppr (HsModule name iface_version exports imports + decls deprec src_loc) = vcat [ - ifPprShowAll sty (ppr sty src_loc), - ifnotPprForUser sty (pp_iface_version iface_version), case exports of - Nothing -> hsep [ptext SLIT("module"), ptext name, ptext SLIT("where")] + Nothing -> pp_header (ptext SLIT("where")) Just es -> vcat [ - hsep [ptext SLIT("module"), ptext name, lparen], - nest 8 (interpp'SP sty es), + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr es))), nest 4 (ptext SLIT(") where")) ], pp_nonnull imports, - pp_nonnull fixities, pp_nonnull decls ] where + pp_header rest = case deprec of + Nothing -> pp_modname <+> rest + Just d -> vcat [ pp_modname, ppr d, rest ] + + pp_modname = ptext SLIT("module") <+> ppr name + pp_nonnull [] = empty - pp_nonnull xs = vcat (map (ppr sty) xs) + pp_nonnull xs = vcat (map ppr xs) - pp_iface_version Nothing = empty - pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"] +hsModuleName (HsModule mod_name _ _ _ _ _ _) = mod_name +hsModuleImports (HsModule mod_name vers exports imports decls deprec src_loc) = imports \end{code} @@ -137,19 +117,35 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectTopBinders EmptyBinds = emptyBag -collectTopBinders (MonoBind b _ _) = collectMonoBinders b -collectTopBinders (ThenBinds b1 b2) - = collectTopBinders b1 `unionBags` collectTopBinders b2 - -collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectMonoBinders EmptyMonoBinds = emptyBag -collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat)) -collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc) -collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders" -collectMonoBinders (AndMonoBinds bs1 bs2) - = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2 +collectLocatedHsBinders :: HsBinds name (InPat name) -> [(name,SrcLoc)] +collectLocatedHsBinders EmptyBinds = [] +collectLocatedHsBinders (MonoBind b _ _) + = collectLocatedMonoBinders b +collectLocatedHsBinders (ThenBinds b1 b2) + = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 + +collectHsBinders :: HsBinds name (InPat name) -> [name] +collectHsBinders EmptyBinds = [] +collectHsBinders (MonoBind b _ _) + = collectMonoBinders b +collectHsBinders (ThenBinds b1 b2) + = collectHsBinders b1 ++ collectHsBinders b2 + +collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)] +collectLocatedMonoBinders binds + = go binds [] + where + go EmptyMonoBinds acc = acc + go (PatMonoBind pat _ loc) acc = map (\v->(v,loc)) (collectPatBinders pat) ++ acc + go (FunMonoBind f _ _ loc) acc = (f,loc) : acc + go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) + +collectMonoBinders :: MonoBinds name (InPat name) -> [name] +collectMonoBinders binds + = go binds [] + where + go EmptyMonoBinds acc = acc + go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc + go (FunMonoBind f _ _ loc) acc = f : acc + go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) \end{code} -