X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=982e315780bea42b8c89ad2355875d2522f5e18a;hb=d753d69a65e5acd860f626a6d2f6b86b75289066;hp=554149c7e366a9afc749546ad9951f29d22faaf3;hpb=3a99fa889bdff0c86df20cb18c71d30e30a79b43;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 554149c..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 -> @@ -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]) }