Make HsRecordBinds a data type instead of a synonym.

[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 554149c..eb93353 100644 (file)
--- 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
@@ -290,8 +296,11 @@ dsExpr (HsCase discrim matches)
     matchWrapper CaseAlt matches       `thenDs` \ ([discrim_var], matching_code) ->
     returnDs (scrungleMatch discrim_var core_discrim matching_code)
 
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+--       This is to avoid silliness in breakpoints
 dsExpr (HsLet binds body)
-  = dsLExpr body               `thenDs` \ body' ->
+  = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $ 
+     dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' ->
     dsLocalBinds binds body'
 
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
@@ -420,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')
@@ -468,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
@@ -593,25 +602,30 @@ dsDo      :: [LStmt Id]
 dsDo stmts body result_ty
   = go (map unLoc stmts)
   where
-    go [] = dsLExpr body
+    go [] = dsAndThenMaybeInsertBreakpoint body
     
     go (ExprStmt rhs then_expr _ : stmts)
-      = do { rhs2 <- dsLExpr rhs
+      = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
           ; then_expr2 <- dsExpr then_expr
           ; rest <- go stmts
           ; returnDs (mkApps then_expr2 [rhs2, rest]) }
     
     go (LetStmt binds : stmts)
-      = do { rest <- go stmts
+      = do { rest <- bindLocalsDs (map unLoc$ collectLocalBinders binds) $ 
+                      go stmts
           ; dsLocalBinds binds rest }
-        
+
+    -- Notice how due to the placement of bindLocals, binders in this stmt
+    -- are available in posterior stmts but Not in this one rhs.
+    -- This is to avoid silliness in breakpoints
     go (BindStmt pat rhs bind_op fail_op : stmts)
-      = do { body  <- go stmts
+      = 
+       do { body  <- bindLocalsDs (collectPatBinders pat) $ go stmts
           ; var   <- selectSimpleMatchVarL pat
           ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
                                  result_ty (cantFailMatchResult body)
           ; match_code <- handle_failure pat match fail_op
-          ; rhs'       <- dsLExpr rhs
+           ; rhs'       <- dsAndThenMaybeInsertBreakpoint rhs
           ; bind_op'   <- dsExpr bind_op
           ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
     
@@ -661,12 +675,12 @@ dsMDo tbl stmts body result_ty
           ; dsLocalBinds binds rest }
 
     go (ExprStmt rhs _ rhs_ty : stmts)
-      = do { rhs2 <- dsLExpr rhs
+      = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
           ; rest <- go stmts
           ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
     
     go (BindStmt pat rhs _ _ : stmts)
-      = do { body  <- go stmts
+      = do { body  <- bindLocalsDs (collectPatBinders pat) $ go stmts
           ; var   <- selectSimpleMatchVarL pat
           ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
                                  result_ty (cantFailMatchResult body)
@@ -674,7 +688,7 @@ dsMDo tbl stmts body result_ty
           ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
           ; match_code <- extractMatchResult match fail_expr
 
-          ; rhs'       <- dsLExpr rhs
+          ; rhs'       <- dsAndThenMaybeInsertBreakpoint rhs
           ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
                                             rhs', Lam var match_code]) }