X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=05880476954f3146f33ecc9465c24849f6850f29;hp=b5c21792af2fd82e925fa3f356857cf3fcd692ae;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index b5c2179..0588047 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -16,14 +16,16 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, import {-# SOURCE #-} HsPat ( LPat ) import HsTypes ( LHsType, PostTcType ) -import Type ( Type ) +import PprCore ( {- instances -} ) +import Coercion ( Coercion ) +import Type ( Type, pprParendType ) import Name ( Name ) import NameSet ( NameSet, elemNameSet ) import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity ) import Outputable import SrcLoc ( Located(..), SrcSpan, unLoc ) import Util ( sortLe ) -import Var ( TyVar, DictId, Id ) +import Var ( TyVar, DictId, Id, Var ) import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags ) \end{code} @@ -59,21 +61,22 @@ type LHsBind id = Located (HsBind id) data HsBind id = FunBind { -- FunBind is used for both functions f x = e -- and variables f = \x -> e --- Reason 1: the Match stuff lets us have an optional --- result type sig f :: a->a = ...mentions a... +-- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds -- --- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds --- --- Reason 3: instance decls can only have FunBinds, which is convenient +-- Reason 2: instance decls can only have FunBinds, which is convenient -- If you change this, you'll need tochange e.g. rnMethodBinds +-- But note that the form f :: a->a = ... +-- parses as a pattern binding, just like +-- (f :: a -> a) = ... + fun_id :: Located id, fun_infix :: Bool, -- True => infix declaration fun_matches :: MatchGroup id, -- The payload - fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of + fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of -- the Id. Example: -- f :: Int -> forall a. a -> a -- f x y = y @@ -81,9 +84,7 @@ data HsBind id -- (with a free type variable a'). The coercion will take -- a CoreExpr of this type and convert it to a CoreExpr of -- type Int -> forall a'. a' -> a' - -- Notice that the coercion captures the free a'. That's - -- why coercions are (CoreExpr -> CoreExpr), rather than - -- just CoreExpr (with a functional type) + -- Notice that the coercion captures the free a'. bind_fvs :: NameSet -- After the renamer, this contains a superset of the -- Names of the other binders in this binding group that @@ -156,6 +157,8 @@ instance OutputableBndr id => Outputable (HsValBinds id) where -- 'where' include a list of HsBindGroups and we don't want -- several groups of bindings each with braces around. -- Sort by location before printing +pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2) + => LHsBinds id1 -> [LSig id2] -> SDoc pprValBindsForUser binds sigs = vcat (map snd (sort_by_loc decls)) where @@ -293,27 +296,67 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \begin{code} --- A Coercion is an expression with a hole in it +-- A HsWrapper is an expression with a hole in it -- We need coercions to have concrete form so that we can zonk them -data ExprCoFn - = CoHole -- The identity coercion - | CoCompose ExprCoFn ExprCoFn - | CoApps ExprCoFn [Id] -- Non-empty list - | CoTyApps ExprCoFn [Type] -- in all of these - | CoLams [Id] ExprCoFn -- so that the identity coercion - | CoTyLams [TyVar] ExprCoFn -- is just Hole - | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. []) + -- = (\a1..an \x1..xn. []) + + | WpCo Coercion -- A cast: [] `cast` co + -- Guaranteedn not the identity coercion + + | WpApp Var -- [] x; the xi are dicts or coercions + | WpTyApp Type -- [] t + | WpLam Id -- \x. []; the xi are dicts or coercions + | WpTyLam TyVar -- \a. [] + + -- Non-empty bindings, so that the identity coercion + -- is always exactly WpHole + | WpLet (LHsBinds Id) -- let binds in [] + -- (would be nicer to be core bindings) + +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn + +pprHsWrapper :: SDoc -> HsWrapper -> SDoc +pprHsWrapper it WpHole = it +pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1 +pprHsWrapper it (WpCo co) = it <+> ptext SLIT("`cast`") <+> pprParendType co +pprHsWrapper it (WpApp id) = it <+> ppr id +pprHsWrapper it (WpTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty +pprHsWrapper it (WpLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it +pprHsWrapper it (WpTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it +pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys) + +mkWpApps :: [Id] -> HsWrapper +mkWpApps ids = mk_co_fn WpApp (reverse ids) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_fn WpTyLam ids + +mkWpLams :: [Id] -> HsWrapper +mkWpLams ids = mk_co_fn WpLam ids -(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn -(<.>) = CoCompose +mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_fn f as = foldr (WpCompose . f) WpHole as -idCoercion :: ExprCoFn -idCoercion = CoHole +idHsWrapper :: HsWrapper +idHsWrapper = WpHole -isIdCoercion :: ExprCoFn -> Bool -isIdCoercion CoHole = True -isIdCoercion other = False +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper other = False \end{code}