X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=300f683c1cca51b1b7ebdab66724c8d113cd0e56;hb=77ccc59a243ea419d5f04046599c3fcd2638cb21;hp=31c1cae459b8c952456a5f612fddfd4f8ffc7606;hpb=5a552652286f9a019d37ded2428fb6543b169310;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 31c1cae..300f683 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}
 
@@ -82,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 
@@ -296,20 +296,60 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 %************************************************************************
 
 \begin{code}
--- A Coercion is an expression with a hole in it
+-- A ExprCoFn 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
+
+  | CoCompose ExprCoFn ExprCoFn	-- (\a1..an. []) `CoCompose` (\x1..xn. [])
+				--	= (\a1..an \x1..xn. [])
+
+  | ExprCoFn Coercion		-- A cast:  [] `cast` co
+				-- Guaranteedn not the identity coercion
+
+  | CoApp Var			-- [] x; the xi are dicts or coercions
+  | CoTyApp Type		-- [] t
+  | CoLam Id	 		-- \x. []; the xi are dicts or coercions
+  | CoTyLam TyVar 		-- \a. []
+
+	-- Non-empty bindings, so that the identity coercion
+	-- is always exactly CoHole
+  | CoLet (LHsBinds Id)		-- let binds in []
+				-- (would be nicer to be core bindings)
+
+instance Outputable ExprCoFn where 
+  ppr co_fn = pprCoFn (ptext SLIT("<>")) co_fn
+
+pprCoFn :: SDoc -> ExprCoFn -> SDoc
+pprCoFn it CoHole = it
+pprCoFn it (CoCompose f1 f2) = pprCoFn (pprCoFn it f2) f1
+pprCoFn it (ExprCoFn co)     = it <+> ptext SLIT("`cast`") <+> pprParendType co
+pprCoFn it (CoApp id)    = it <+> ppr id
+pprCoFn it (CoTyApp ty)  = it <+> ptext SLIT("@") <+> pprParendType ty
+pprCoFn it (CoLam id)    = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
+pprCoFn it (CoTyLam tv)  = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
+pprCoFn it (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
 
 (<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
-(<.>) = CoCompose
+CoHole <.> c = c
+c <.> CoHole = c
+c1 <.> c2    = c1 `CoCompose` c2
+
+mkCoTyApps :: [Type] -> ExprCoFn
+mkCoTyApps tys = mk_co_fn CoTyApp (reverse tys)
+
+mkCoApps :: [Id] -> ExprCoFn
+mkCoApps ids = mk_co_fn CoApp (reverse ids)
+
+mkCoTyLams :: [TyVar] -> ExprCoFn
+mkCoTyLams ids = mk_co_fn CoTyLam ids
+
+mkCoLams :: [Id] -> ExprCoFn
+mkCoLams ids = mk_co_fn CoLam ids
+
+mk_co_fn :: (a -> ExprCoFn) -> [a] -> ExprCoFn
+mk_co_fn f as = foldr (CoCompose . f) CoHole as
 
 idCoercion :: ExprCoFn
 idCoercion = CoHole