X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=887bc699c105c6f8cd1bb61915210cdb2bd65cd9;hb=d28ba8c800901bea01f70c4719278c2a364cf9fc;hp=447027c8bd67fb49527a1e25bcffbb4e112e2d34;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 447027c..887bc69 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,106 +8,193 @@ 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" - HsSyn.. , - HsBinds.. , - HsDecls.. , - HsExpr.. , - HsImpExp.. , - HsLit.. , - HsMatches.. , - HsPat.. , - HsTypes.. + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsTypes, + Fixity, NewOrData, + HsModule(..), + collectStmtsBinders, + collectHsBinders, collectLocatedHsBinders, + collectMonoBinders, collectLocatedMonoBinders, + collectSigTysFromHsBinds, collectSigTysFromMonoBinds ) where -import Ubiq{-uitous-} +#include "HsVersions.h" -- friends: +import HsDecls import HsBinds -import HsDecls import HsExpr import HsImpExp import HsLit -import HsMatches import HsPat import HsTypes -import HsPragmas ( ClassPragmas, ClassOpPragmas, - DataPragmas, GenPragmas, InstancePragmas - ) --- others: -import FiniteMap ( FiniteMap ) -import Outputable ( ifPprShowAll, interpp'SP, Outputable(..){-instances-} ) -import Pretty -import SrcLoc ( SrcLoc{-instances-} ) -\end{code} +import BasicTypes ( Fixity, Version, NewOrData ) -@Fake@ is a placeholder type; for when tyvars and uvars aren't used. -\begin{code} -data Fake = Fake -instance Eq Fake -instance Outputable Fake +-- others: +import Name ( NamedThing ) +import Outputable +import SrcLoc ( SrcLoc ) +import Module ( Module ) \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 = HsModule - FAST_STRING -- module name - (Maybe [IE name]) -- export list; Nothing => export everything - -- Just [] => export *nothing* (???) + (Maybe 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 + -- Just [] => export *nothing* -- Just [...] => as you would expect... - [ImportedInterface tyvar uvar name pat] - -- We snaffle interesting stuff out of the + [ImportDecl 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. - [FixityDecl name] - [TyDecl name] - [SpecDataSig name] -- user pragmas that modify TyDecls - [ClassDecl tyvar uvar name pat] - [InstDecl tyvar uvar name pat] - [SpecInstSig name] -- user pragmas that modify InstDecls - [DefaultDecl name] - (HsBinds tyvar uvar name pat) -- the main stuff! - [Sig name] -- "Sigs" are folded into the "HsBinds" - -- pretty early on, so this list is - -- often either empty or just the - -- interface signatures. + [HsDecl name] -- 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 - - ppr sty (HsModule name exports imports fixities - typedecls typesigs classdecls instdecls instsigs - defdecls binds sigs src_loc) - = ppAboves [ - ifPprShowAll sty (ppr sty src_loc), +instance (NamedThing name, OutputableBndr name) + => Outputable (HsModule name) where + + ppr (HsModule Nothing _ imports decls _ src_loc) + = pp_nonnull imports $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec src_loc) + = vcat [ case exports of - Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")] - Just es -> ppAboves [ - ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen], - ppNest 8 (interpp'SP sty es), - ppNest 4 (ppPStr SLIT(") where")) + 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_nonnull imports, pp_nonnull fixities, - pp_nonnull typedecls, pp_nonnull typesigs, - pp_nonnull classdecls, - pp_nonnull instdecls, pp_nonnull instsigs, - pp_nonnull defdecls, - ppr sty binds, pp_nonnull sigs + pp_nonnull imports, + pp_nonnull decls ] where - pp_nonnull [] = ppNil - pp_nonnull xs = ppAboves (map (ppr sty) xs) + 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 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) +\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 other = panic "collectStmtBinders" +\end{code} +