X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=7f5ca52b8e3dde4a855e464687c8edc8a7cc8a3d;hb=7f82f577d34b201b7345794ece8b9dbb680a0257;hp=fb656a2002680ce219b2278882faf70c8a540877;hpb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index fb656a2..7f5ca52 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -9,22 +9,23 @@ therefore, is almost nothing but re-exporting. \begin{code} module HsSyn ( - - -- NB: don't reexport HsCore or HsPragmas; + -- NB: don't reexport HsCore -- this module tells about "real Haskell" - module HsSyn, module HsBinds, module HsDecls, module HsExpr, module HsImpExp, - module HsBasic, - module HsMatches, + module HsLit, module HsPat, module HsTypes, Fixity, NewOrData, - collectTopBinders, collectMonoBinders + HsModule(..), hsModule, hsImports, + collectStmtsBinders, + collectHsBinders, collectLocatedHsBinders, + collectMonoBinders, collectLocatedMonoBinders, + collectSigTysFromHsBinds, collectSigTysFromMonoBinds ) where #include "HsVersions.h" @@ -34,25 +35,23 @@ import HsDecls import HsBinds import HsExpr import HsImpExp -import HsBasic -import HsMatches +import HsLit import HsPat import HsTypes -import HsCore import BasicTypes ( Fixity, Version, NewOrData ) -- others: +import Name ( NamedThing ) import Outputable import SrcLoc ( SrcLoc ) -import Bag -import OccName ( Module, pprModule ) +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 - Module -- module name + Module (Maybe Version) -- source interface version number (Maybe [IE name]) -- export list; Nothing => export everything -- Just [] => export *nothing* (???) @@ -61,33 +60,40 @@ data HsModule name pat -- 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 + [HsDecl name] -- Type, class, value, and interface signature decls + (Maybe DeprecTxt) -- reason/explanation for deprecation of this module SrcLoc \end{code} \begin{code} -instance (Outputable name, Outputable pat) - => Outputable (HsModule name pat) where +instance (NamedThing name, OutputableBndr name) + => Outputable (HsModule name) where ppr (HsModule name iface_version exports imports - decls src_loc) + decls deprec src_loc) = vcat [ case exports of - Nothing -> hsep [ptext SLIT("module"), pprModule name, ptext SLIT("where")] + Nothing -> pp_header (ptext SLIT("where")) Just es -> vcat [ - hsep [ptext SLIT("module"), pprModule name, lparen], - nest 8 (interpp'SP es), + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr es))), nest 4 (ptext SLIT(") where")) ], pp_nonnull imports, 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 xs) - pp_iface_version Nothing = empty - pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"] +hsModule (HsModule mod _ _ _ _ _ _) = mod +hsImports (HsModule mod vers exports imports decls deprec src_loc) = imports \end{code} @@ -111,19 +117,85 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectTopBinders :: HsBinds 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 name (InPat name) -> Bag (name,SrcLoc) -collectMonoBinders EmptyMonoBinds = emptyBag -collectMonoBinders (PatMonoBind pat _ 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 -> [(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}