X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;fp=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;h=8f3006d0f338295e3057b45f0fb35c3e2802dbdd;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=70980f978539bb59e32bb0326e6a5d645f90b05a;hpb=479cc24837aa2c14c3bbed323bb640a5c53a2522;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 70980f9..8f3006d 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -8,7 +8,10 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
 lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
-module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, AutoScc(..) ) where
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
+		 dsCoercion,
+		 AutoScc(..)
+  ) where
 
 #include "HsVersions.h"
 
@@ -84,12 +87,13 @@ dsHsBind auto_scc rest (VarBind var expr)
     addDictScc var core_expr	`thenDs` \ core_expr' ->
     returnDs ((var, core_expr') : rest)
 
-dsHsBind auto_scc rest (FunBind (L _ fun) _ matches _)
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
   = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
-    addAutoScc auto_scc (fun, mkLams args body)		`thenDs` \ pair ->
+    dsCoercion co_fn (return (mkLams args body))	`thenDs` \ rhs ->
+    addAutoScc auto_scc (fun, rhs)			`thenDs` \ pair ->
     returnDs (pair : rest)
 
-dsHsBind auto_scc rest (PatBind pat grhss ty _)
+dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
   = dsGuarded grhss ty				`thenDs` \ body_expr ->
     mkSelectorBinds pat body_expr		`thenDs` \ sel_binds ->
     mappM (addAutoScc auto_scc) sel_binds	`thenDs` \ sel_binds ->
@@ -384,3 +388,30 @@ addDictScc var rhs = returnDs rhs
     returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 -}
 \end{code}
+
+
+%************************************************************************
+%*									*
+		Desugaring coercions
+%*									*
+%************************************************************************
+
+
+\begin{code}
+dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr
+dsCoercion CoHole 	     thing_inside = thing_inside
+dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
+dsCoercion (CoLams ids c)    thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkLams ids expr) }
+dsCoercion (CoTyLams tvs c)  thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkLams tvs expr) }
+dsCoercion (CoApps c ids)    thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkVarApps expr ids) }
+dsCoercion (CoTyApps c tys)  thing_inside = do { expr <- dsCoercion c thing_inside
+					       ; return (mkTyApps expr tys) }
+dsCoercion (CoLet bs c)      thing_inside = do { prs <- dsLHsBinds bs
+					       ; expr <- dsCoercion c thing_inside
+					       ; return (Let (Rec prs) expr) }
+\end{code}
+
+