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

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 31c1cae..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}
 
@@ -74,7 +76,7 @@ data HsBind id
 
 	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
@@ -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,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
 
-(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
-(<.>) = CoCompose
+  | WpCompose HsWrapper HsWrapper	-- (\a1..an. []) `WpCompose` (\x1..xn. [])
+				--	= (\a1..an \x1..xn. [])
 
-idCoercion :: ExprCoFn
-idCoercion = CoHole
+  | WpCo Coercion		-- A cast:  [] `cast` co
+				-- Guaranteedn not the identity coercion
 
-isIdCoercion :: ExprCoFn -> Bool
-isIdCoercion CoHole = True
-isIdCoercion other  = False
+  | 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
+
+mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+mk_co_fn f as = foldr (WpCompose . f) WpHole as
+
+idHsWrapper :: HsWrapper
+idHsWrapper = WpHole
+
+isIdHsWrapper :: HsWrapper -> Bool
+isIdHsWrapper WpHole = True
+isIdHsWrapper other  = False
 \end{code}