X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=a9982a630a7437863dd3bf28e4645fc6b7bf1ee8;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hp=cb42ba5625a37e422a9722be88bfc5405e5aa011;hpb=61bfd5dd3b9d70404d6f93c030a9bb1c402b9d31;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index cb42ba5..a9982a6 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -9,11 +9,6 @@ therefore, is almost nothing but re-exporting. \begin{code} module HsSyn ( - - -- NB: don't reexport HsCore - -- this module tells about "real Haskell" - - module HsSyn, module HsBinds, module HsDecls, module HsExpr, @@ -21,12 +16,10 @@ module HsSyn ( module HsLit, module HsPat, module HsTypes, - Fixity, NewOrData, + module HsUtils, + Fixity, - collectHsBinders, collectLocatedHsBinders, - collectMonoBinders, collectLocatedMonoBinders, - collectSigTysFromMonoBinds, - hsModuleName, hsModuleImports + HsModule(..), HsExtCore(..) ) where #include "HsVersions.h" @@ -39,46 +32,56 @@ import HsImpExp import HsLit import HsPat import HsTypes -import BasicTypes ( Fixity, Version, NewOrData ) +import HscTypes ( DeprecTxt ) +import BasicTypes ( Fixity ) +import HsUtils -- others: -import Name ( NamedThing ) +import IfaceSyn ( IfaceBinding ) import Outputable -import SrcLoc ( SrcLoc ) -import Module ( ModuleName ) +import SrcLoc ( Located(..) ) +import Module ( Module ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} -data HsModule name pat +data HsModule name = HsModule - ModuleName -- module name - (Maybe Version) -- source interface version number - (Maybe [IE name]) -- export list; Nothing => export everything - -- Just [] => export *nothing* (???) + (Maybe (Located Module))-- Nothing => "module X where" is omitted + -- (in which case the next field is Nothing too) + (Maybe [LIE name]) -- Export list; Nothing => export list omitted, so export everything + -- Just [] => export *nothing* -- Just [...] => as you would expect... - [ImportDecl name] -- We snaffle interesting stuff out of the + [LImportDecl name] -- We snaffle interesting stuff out of the -- imported interfaces early on, adding that -- info to TyDecls/etc; so this list is -- often empty, downstream. - [HsDecl name pat] -- Type, class, value, and interface signature decls + [LHsDecl name] -- Type, class, value, and interface signature decls (Maybe DeprecTxt) -- reason/explanation for deprecation of this module - SrcLoc + +data HsExtCore name -- Read from Foo.hcr + = HsExtCore + Module + [TyClDecl name] -- Type declarations only; just as in Haskell source, + -- so that we can infer kinds etc + [IfaceBinding] -- And the bindings \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) - => Outputable (HsModule name pat) where +instance (OutputableBndr name) + => Outputable (HsModule name) where - ppr (HsModule name iface_version exports imports - decls deprec src_loc) + ppr (HsModule Nothing _ imports decls _) + = pp_nonnull imports $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec) = vcat [ case exports of Nothing -> pp_header (ptext SLIT("where")) Just es -> vcat [ - pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr es))), - nest 4 (ptext SLIT(") where")) + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr es))), + nest 4 (ptext SLIT(") where")) ], pp_nonnull imports, pp_nonnull decls @@ -90,90 +93,6 @@ instance (NamedThing name, Outputable name, Outputable pat) pp_modname = ptext SLIT("module") <+> ppr name - pp_nonnull [] = empty - pp_nonnull xs = vcat (map ppr xs) - -hsModuleName (HsModule mod_name _ _ _ _ _ _) = mod_name -hsModuleImports (HsModule mod_name vers exports imports decls deprec src_loc) = imports +pp_nonnull [] = empty +pp_nonnull xs = vcat (map ppr xs) \end{code} - - -%************************************************************************ -%* * -\subsection{Collecting binders from @HsBinds@} -%* * -%************************************************************************ - -Get all the binders in some @MonoBinds@, IN THE ORDER OF APPEARANCE. - -These functions are here, rather than in HsBinds, to avoid a loop between HsPat and HsBinds. - -\begin{verbatim} -... -where - (x, y) = ... - f i j = ... - [a, b] = ... -\end{verbatim} -it should return @[x, y, f, a, b]@ (remember, order important). - -\begin{code} -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} - -%************************************************************************ -%* * -\subsection{Getting patterns out of bindings} -%* * -%************************************************************************ - -Get all the pattern type signatures out of a bunch of bindings - -\begin{code} -collectSigTysFromMonoBinds :: MonoBinds name (InPat name) -> [HsType name] -collectSigTysFromMonoBinds bind - = go bind [] - where - go EmptyMonoBinds acc = acc - go (PatMonoBind pat _ loc) acc = collectSigTysFromPat pat ++ acc - go (FunMonoBind f _ ms loc) acc = go_matches ms acc - go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) - - -- A binding like x :: a = f y - -- is parsed as FunMonoBind, but for this purpose we - -- want to treat it as a pattern binding - go_matches [] acc = acc - go_matches (Match [] (Just sig) _ : matches) acc = sig : go_matches matches acc - go_matches (match : matches) acc = go_matches matches acc -\end{code} -