X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=96379a5e2835f292f605a9cb9d8fbaba7c4ea739;hb=626b9cd2cca1b05e94d8937ccf176d3e74562f87;hp=373a240a335b100c3c92a6d2f0edd3e31705aed6;hpb=38ef36af81c7fe05f12ead2bb3613cff208d81fe;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 373a240..96379a5 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -9,9 +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 HsBinds, module HsDecls, module HsExpr, @@ -19,13 +16,10 @@ module HsSyn ( module HsLit, module HsPat, module HsTypes, + module HsUtils, Fixity, NewOrData, - HsModule(..), - collectStmtsBinders, collectStmtBinders, - collectHsBinders, collectLocatedHsBinders, - collectMonoBinders, collectLocatedMonoBinders, - collectSigTysFromHsBinds, collectSigTysFromMonoBinds + HsModule(..), HsExtCore(..) ) where #include "HsVersions.h" @@ -38,48 +32,57 @@ import HsImpExp import HsLit import HsPat import HsTypes -import BasicTypes ( Fixity, Version, NewOrData ) +import HscTypes ( DeprecTxt ) +import BasicTypes ( Fixity, NewOrData ) +import HsUtils -- others: -import Name ( NamedThing ) +import IfaceSyn ( IfaceBinding ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) import Module ( Module ) +import Bag ( Bag, foldrBag ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} data HsModule name = HsModule - (Maybe Module) -- Nothing => "module X where" is omitted + (Maybe (Located Module))-- Nothing => "module X where" is omitted -- (in which case the next field is Nothing too) - (Maybe [IE name]) -- Export list; Nothing => export list omitted, so export everything + (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] -- 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, OutputableBndr name) +instance (OutputableBndr name) => Outputable (HsModule name) where - ppr (HsModule Nothing _ imports decls _ src_loc) + ppr (HsModule Nothing _ imports decls _) = pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule (Just name) exports imports decls deprec src_loc) + 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 @@ -94,111 +97,3 @@ instance (NamedThing name, OutputableBndr name) 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 -> [(name,SrcLoc)] --- Used at top level only; so no need for an IPBinds case -collectLocatedHsBinders EmptyBinds = [] -collectLocatedHsBinders (MonoBind b _ _) - = collectLocatedMonoBinders b -collectLocatedHsBinders (ThenBinds b1 b2) - = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 - -collectHsBinders :: HsBinds name -> [name] -collectHsBinders EmptyBinds = [] -collectHsBinders (IPBinds _) = [] -- Implicit parameters don't create - -- ordinary bindings -collectHsBinders (MonoBind b _ _) = collectMonoBinders b -collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2 - -collectLocatedMonoBinders :: MonoBinds 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 -> [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) - go (VarMonoBind v _) acc = v : acc - go (AbsBinds _ _ dbinds _ binds) acc - = [dp | (_,dp,_) <- dbinds] ++ go binds acc -\end{code} - - -%************************************************************************ -%* * -\subsection{Getting patterns out of bindings} -%* * -%************************************************************************ - -Get all the pattern type signatures out of a bunch of bindings - -\begin{code} -collectSigTysFromHsBinds :: HsBinds name -> [HsType name] -collectSigTysFromHsBinds EmptyBinds = [] -collectSigTysFromHsBinds (IPBinds _) = [] -collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b -collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++ - collectSigTysFromHsBinds b2 - - -collectSigTysFromMonoBinds :: MonoBinds 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} - -\begin{code} -collectStmtsBinders :: [Stmt id] -> [id] -collectStmtsBinders = concatMap collectStmtBinders - -collectStmtBinders :: Stmt id -> [id] - -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _) = collectPatBinders pat -collectStmtBinders (LetStmt binds) = collectHsBinders binds -collectStmtBinders (ExprStmt _ _ _) = [] -collectStmtBinders (ResultStmt _ _) = [] -collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss -collectStmtBinders other = panic "collectStmtBinders" -\end{code} -