From: sof Date: Mon, 26 May 1997 04:42:21 +0000 (+0000) Subject: [project @ 1997-05-26 04:42:21 by sof] X-Git-Tag: Approximately_1000_patches_recorded~493 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=115608941ac4ae5218b3d46ae934bf23e505b613;p=ghc-hetmet.git [project @ 1997-05-26 04:42:21 by sof] removed : collectTopBinders, collectMonoBinders (now in HsSyn); improved ppr; updated imports --- diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 1fe3a29..51f98c8 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -13,10 +13,9 @@ module HsBinds where IMP_Ubiq() -- friends: -IMPORT_DELOOPER(HsLoop) -import HsMatches ( pprMatches, pprGRHSsAndBinds, - Match, GRHSsAndBinds ) -import HsPat ( collectPatBinders, InPat ) +IMPORT_DELOOPER(HsLoop) ( pprMatches, pprGRHSsAndBinds, + Match, GRHSsAndBinds, + HsExpr, pprExpr ) import HsPragmas ( GenPragmas, ClassOpPragmas ) import HsTypes ( HsType ) import CoreSyn ( SYN_IE(CoreExpr) ) @@ -24,7 +23,7 @@ import CoreSyn ( SYN_IE(CoreExpr) ) --others: import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId ) import Name ( getOccName, OccName, NamedThing(..) ) -import Outputable ( interpp'SP, ifnotPprForUser, +import Outputable ( interpp'SP, ifnotPprForUser, pprQuote, Outputable(..){-instance * (,)-} ) import PprCore --( GenCoreExpr {- instance Outputable -} ) @@ -79,10 +78,12 @@ instance (Outputable pat, NamedThing id, Outputable id, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (HsBinds tyvar uvar id pat) where - ppr sty EmptyBinds = empty - ppr sty (ThenBinds binds1 binds2) - = ($$) (ppr sty binds1) (ppr sty binds2) - ppr sty (MonoBind bind sigs is_rec) + ppr sty binds = pprQuote sty (\ sty -> ppr_binds sty binds) + +ppr_binds sty EmptyBinds = empty +ppr_binds sty (ThenBinds binds1 binds2) + = ($$) (ppr_binds sty binds1) (ppr_binds sty binds2) +ppr_binds sty (MonoBind bind sigs is_rec) = vcat [ ifnotPprForUser sty (ptext rec_str), if null sigs @@ -178,28 +179,31 @@ andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (MonoBinds tyvar uvar id pat) where - ppr sty EmptyMonoBinds = empty - ppr sty (AndMonoBinds binds1 binds2) - = ($$) (ppr sty binds1) (ppr sty binds2) + ppr sty mbind = pprQuote sty (\ sty -> ppr_monobind sty mbind) + - ppr sty (PatMonoBind pat grhss_n_binds locn) +ppr_monobind sty EmptyMonoBinds = empty +ppr_monobind sty (AndMonoBinds binds1 binds2) + = ($$) (ppr_monobind sty binds1) (ppr_monobind sty binds2) + +ppr_monobind sty (PatMonoBind pat grhss_n_binds locn) = hang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) - ppr sty (FunMonoBind fun inf matches locn) +ppr_monobind sty (FunMonoBind fun inf matches locn) = pprMatches sty (False, ppr sty fun) matches -- ToDo: print infix if appropriate - ppr sty (VarMonoBind name expr) - = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr) +ppr_monobind sty (VarMonoBind name expr) + = hang (hsep [ppr sty name, equals]) 4 (pprExpr sty expr) - ppr sty (CoreMonoBind name expr) +ppr_monobind sty (CoreMonoBind name expr) = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr) - ppr sty (AbsBinds tyvars dictvars exports val_binds) +ppr_monobind sty (AbsBinds tyvars dictvars exports val_binds) = ($$) (sep [ptext SLIT("AbsBinds"), - brackets (interpp'SP sty tyvars), - brackets (interpp'SP sty dictvars), - brackets (interpp'SP sty exports)]) + brackets (interpp'SP sty tyvars), + brackets (interpp'SP sty dictvars), + brackets (interpp'SP sty exports)]) (nest 4 (ppr sty val_binds)) \end{code} @@ -244,19 +248,22 @@ data Sig name \begin{code} instance (NamedThing name, Outputable name) => Outputable (Sig name) where - ppr sty (Sig var ty _) + ppr sty sig = pprQuote sty (\ sty -> ppr_sig sty sig) + + +ppr_sig sty (Sig var ty _) = hang (hsep [ppr sty var, ptext SLIT("::")]) 4 (ppr sty ty) - ppr sty (ClassOpSig var _ ty _) +ppr_sig sty (ClassOpSig var _ ty _) = hang (hsep [ppr sty (getOccName var), ptext SLIT("::")]) 4 (ppr sty ty) - ppr sty (DeforestSig var _) +ppr_sig sty (DeforestSig var _) = hang (hsep [text "{-# DEFOREST", ppr sty var]) 4 (text "#-") - ppr sty (SpecSig var ty using _) +ppr_sig sty (SpecSig var ty using _) = hang (hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")]) 4 (hsep [ppr sty ty, pp_using using, text "#-}"]) @@ -264,44 +271,11 @@ instance (NamedThing name, Outputable name) => Outputable (Sig name) where pp_using Nothing = empty pp_using (Just me) = hsep [char '=', ppr sty me] - ppr sty (InlineSig var _) +ppr_sig sty (InlineSig var _) = hsep [text "{-# INLINE", ppr sty var, text "#-}"] - ppr sty (MagicUnfoldingSig var str _) +ppr_sig sty (MagicUnfoldingSig var str _) = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"] \end{code} -%************************************************************************ -%* * -\subsection{Collecting binders from @HsBinds@} -%* * -%************************************************************************ - -Get all the binders in some @MonoBinds@, IN THE ORDER OF -APPEARANCE; e.g., in: -\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} -collectTopBinders :: HsBinds tyvar uvar 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 tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectMonoBinders EmptyMonoBinds = emptyBag -collectMonoBinders (PatMonoBind pat grhss_w_binds 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 -\end{code}