X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=982e315780bea42b8c89ad2355875d2522f5e18a;hb=1ee08bbe86b03ba74a9be309a84602b34e41cbb4;hp=e90a55641d3ac9e22526424fc8988093c9ea8cf8;hpb=eca538c8c62951d6f140c99c88a97ef2b0a0497d;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index e90a556..982e315 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -52,6 +52,8 @@ import Util
 import Bag
 import Outputable
 import FastString
+
+import Data.Maybe
 \end{code}
 
 
@@ -190,12 +192,16 @@ dsLExpr :: LHsExpr Id -> DsM CoreExpr
 #if defined(GHCI)
 dsLExpr (L loc expr@(HsWrap w (HsVar v)))
     | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
+    , WpTyApp ty <- simpWrapper w
     = do areBreakpointsEnabled <- breakpoints_enabled
          if areBreakpointsEnabled
            then do
-              L _ breakpointExpr <- mkBreakpointExpr loc v
+              L _ breakpointExpr <- mkBreakpointExpr loc v ty
               dsLExpr (L loc $ HsWrap w breakpointExpr)
            else putSrcSpanDs loc $ dsExpr expr
+       where simpWrapper (WpCompose w1 WpHole) = w1
+             simpWrapper (WpCompose WpHole w1) = w1
+             simpWrapper w = w
 #endif
 
 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
@@ -207,7 +213,7 @@ dsExpr (HsVar var)     	      = returnDs (Var var)
 dsExpr (HsIPVar ip)    	      = returnDs (Var (ipNameName ip))
 dsExpr (HsLit lit)     	      = dsLit lit
 dsExpr (HsOverLit lit) 	      = dsOverLit lit
-dsExpr (HsWrap co_fn e)     = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
 
 dsExpr (NegApp expr neg_expr) 
   = do	{ core_expr <- dsLExpr expr
@@ -221,7 +227,7 @@ dsExpr expr@(HsLam a_Match)
 dsExpr expr@(HsApp fun arg)      
   = dsLExpr fun		`thenDs` \ core_fun ->
     dsLExpr arg		`thenDs` \ core_arg ->
-    returnDs (core_fun `App` core_arg)
+    returnDs (core_fun `mkDsApp` core_arg)
 \end{code}
 
 Operator sections.  At first it looks as if we can convert
@@ -251,12 +257,12 @@ dsExpr (OpApp e1 op _ e2)
     -- for the type of y, we need the type of op's 2nd argument
     dsLExpr e1				`thenDs` \ x_core ->
     dsLExpr e2				`thenDs` \ y_core ->
-    returnDs (mkApps core_op [x_core, y_core])
+    returnDs (mkDsApps core_op [x_core, y_core])
     
 dsExpr (SectionL expr op)	-- Desugar (e !) to ((!) e)
   = dsLExpr op				`thenDs` \ core_op ->
     dsLExpr expr			`thenDs` \ x_core ->
-    returnDs (App core_op x_core)
+    returnDs (mkDsApp core_op x_core)
 
 -- dsLExpr (SectionR op expr)	-- \ x -> op x expr
 dsExpr (SectionR op expr)
@@ -271,7 +277,7 @@ dsExpr (SectionR op expr)
     newSysLocalDs y_ty			`thenDs` \ y_id ->
 
     returnDs (bindNonRec y_id y_core $
-	      Lam x_id (mkApps core_op [Var x_id, Var y_id]))
+	      Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
 
 dsExpr (HsSCC cc expr)
   = dsLExpr expr			`thenDs` \ core_expr ->
@@ -423,7 +429,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
 constructor @C@, setting all of @C@'s fields to bottom.
 
 \begin{code}
-dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
+dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
   = dsExpr con_expr	`thenDs` \ con_expr' ->
     let
 	(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -471,10 +477,10 @@ might do some argument-evaluation first; and may have to throw away some
 dictionaries.
 
 \begin{code}
-dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
+dsExpr (RecordUpd record_expr (HsRecordBinds []) record_in_ty record_out_ty)
   = dsLExpr record_expr
 
-dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
+dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) record_in_ty record_out_ty)
   = dsLExpr record_expr	 	`thenDs` \ record_expr' ->
 
 	-- Desugar the rbinds, and generate let-bindings if