#ifdef GHCI
import PrelNames
-import DsBreakpoint
-- Template Haskell stuff iff bootstrapped
import DsMeta
-#else
-import DsBreakpoint
#endif
import HsSyn
\begin{code}
dsLExpr :: LHsExpr Id -> DsM CoreExpr
-#if defined(GHCI)
-dsLExpr (L loc expr@(HsWrap w (HsVar v)))
- | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
- = do areBreakpointsEnabled <- breakpoints_enabled
- if areBreakpointsEnabled
- then do
- L _ breakpointExpr <- mkBreakpointExpr loc v
- dsLExpr (L loc $ HsWrap w breakpointExpr)
- else putSrcSpanDs loc $ dsExpr expr
-#endif
-
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
dsExpr :: HsExpr Id -> DsM CoreExpr
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
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
-- 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)
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 ->
-- 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)
- = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $
- dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' ->
+ = dsLExpr body `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
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')
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
Hpc Support
\begin{code}
-dsExpr (HsTick ix e) = do
+dsExpr (HsTick ix vars e) = do
e' <- dsLExpr e
- mkTickBox ix e'
+ mkTickBox ix vars e'
-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
dsDo stmts body result_ty
= go (map unLoc stmts)
where
- go [] = dsAndThenMaybeInsertBreakpoint body
+ go [] = dsLExpr body
go (ExprStmt rhs then_expr _ : stmts)
- = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
+ = do { rhs2 <- dsLExpr rhs
; then_expr2 <- dsExpr then_expr
; rest <- go stmts
; returnDs (mkApps then_expr2 [rhs2, rest]) }
go (LetStmt binds : stmts)
- = do { rest <- bindLocalsDs (map unLoc$ collectLocalBinders binds) $
- go stmts
+ = do { rest <- 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 <- bindLocalsDs (collectPatBinders pat) $ go stmts
+ do { body <- 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' <- dsAndThenMaybeInsertBreakpoint rhs
+ ; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
- = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
+ = do { rhs2 <- dsLExpr rhs
; rest <- go stmts
; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
go (BindStmt pat rhs _ _ : stmts)
- = do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
+ = do { body <- go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
; match_code <- extractMatchResult match fail_expr
- ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
+ ; rhs' <- dsLExpr rhs
; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
projects / ghc-hetmet.git / blobdiff