X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=7255d1b7f681a08d2ec596d57b9293eee9bb0e6f;hb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;hp=0647ba232944a4b3ad994ac3c80b5f483f8e927b;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 0647ba2..7255d1b 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,107 +8,187 @@ 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 ( + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsTypes, + module HsUtils, + Fixity, NewOrData, - -- NB: don't reexport HsCore or HsPragmas; - -- 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), - NewOrData(..) + HsModule(..), HsExtCore(..), + collectStmtsBinders, collectStmtBinders, collectLStmtBinders, + collectGroupBinders, collectHsBindLocatedBinders, + collectHsBindBinders, + collectSigTysFromHsBind, collectSigTysFromHsBinds ) 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 TyCon ( NewOrData(..) ) +import HscTypes ( DeprecTxt ) +import BasicTypes ( Fixity, NewOrData ) +import HsUtils -- others: -import FiniteMap ( FiniteMap ) -import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) ) -import Pretty -import SrcLoc ( SrcLoc ) -#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 IfaceSyn ( IfaceBinding ) +import Outputable +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 tyvar uvar name pat +data HsModule name = HsModule - Module -- 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. - [FixityDecl name] - [HsDecl tyvar uvar name pat] -- Type, class, value, and interface signature decls - SrcLoc + [LHsDecl name] -- Type, class, value, and interface signature decls + (Maybe DeprecTxt) -- reason/explanation for deprecation of this module + +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, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => Outputable (HsModule tyvar uvar name pat) where +instance (OutputableBndr name) + => Outputable (HsModule name) where - ppr sty (HsModule name iface_version exports imports fixities - decls src_loc) + ppr (HsModule Nothing _ imports decls _) + = pp_nonnull imports $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec) = 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), - 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 fixities, pp_nonnull decls ] where - pp_nonnull [] = empty - pp_nonnull xs = vcat (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} +collectGroupBinders :: [HsBindGroup name] -> [Located name] +collectGroupBinders groups = foldr collect_group [] groups + where + collect_group (HsBindGroup bag sigs is_rec) acc + = foldrBag (collectAcc . unLoc) acc bag + collect_group (HsIPBinds _) acc = acc + + +collectAcc :: HsBind name -> [Located name] -> [Located name] +collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc +collectAcc (FunBind f _ _) acc = f : acc +collectAcc (VarBind f _) acc = noLoc f : acc +collectAcc (AbsBinds _ _ dbinds _ binds) acc + = [noLoc dp | (_,dp,_) <- dbinds] ++ acc + -- ++ foldr collectAcc acc binds + -- I don't think we want the binders from the nested binds + -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn + +collectHsBindBinders :: Bag (LHsBind name) -> [name] +collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) + +collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] +collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds +\end{code} + + +%************************************************************************ +%* * +\subsection{Getting patterns out of bindings} +%* * +%************************************************************************ + +Get all the pattern type signatures out of a bunch of bindings + +\begin{code} +collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name] +collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds) + +collectSigTysFromHsBind :: LHsBind name -> [LHsType name] +collectSigTysFromHsBind bind + = go (unLoc bind) + where + go (PatBind pat _) = collectSigTysFromPat pat + go (FunBind f _ ms) = go_matches (map unLoc ms) + + -- 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 [] = [] + go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches + go_matches (match : matches) = go_matches matches +\end{code} + +\begin{code} +collectStmtsBinders :: [LStmt id] -> [Located id] +collectStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders = collectStmtBinders . unLoc - pp_iface_version Nothing = empty - pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"] +collectStmtBinders :: Stmt id -> [Located id] + -- Id Binders for a Stmt... [but what about pattern-sig type vars]? +collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat +collectStmtBinders (LetStmt binds) = collectGroupBinders binds +collectStmtBinders (ExprStmt _ _) = [] +collectStmtBinders (ResultStmt _) = [] +collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss +collectStmtBinders other = panic "collectStmtBinders" \end{code}