diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Check.hs | 5 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 8 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 14 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 2 |
4 files changed, 19 insertions, 10 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 02074e5a3e..d3364332c5 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -1328,8 +1328,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) - _ -> (pprMatchContext kind, \ pp -> pp) + FunRhs (L _ fun) _ -> (pprMatchContext kind, + \ pp -> ppr fun <+> pp) + _ -> (pprMatchContext kind, \ pp -> pp) ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc ppr_pats kind pats diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 00b111abbb..c27168a042 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -124,7 +124,9 @@ dsHsBind dflags dsHsBind dflags (FunBind { fun_id = L _ fun, fun_matches = matches , fun_co_fn = co_fn, fun_tick = tick }) - = do { (args, body) <- matchWrapper (FunRhs (idName fun)) Nothing matches + = do { (args, body) <- matchWrapper + (FunRhs (noLoc $ idName fun) Prefix) + Nothing matches ; let body' = mkOptTickBox tick body ; rhs <- dsHsWrapper co_fn (mkLams args body') ; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs @@ -313,7 +315,9 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts = putSrcSpanDs bind_loc $ addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check - do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches + do { (args, body) <- matchWrapper + (FunRhs (noLoc $ idName global) Prefix) + Nothing matches ; let body' = mkOptTickBox tick body ; fun_rhs <- dsHsWrapper co_fn $ mkLams args body' diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index c33b867358..85177ee679 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -149,13 +149,14 @@ dsUnliftedBind (AbsBindsSig { abs_tvs = [] ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body ; return (mkCoreLets ds_binds body') } -dsUnliftedBind (FunBind { fun_id = L _ fun +dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches + = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix) + Nothing matches ; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( isIdHsWrapper co_fn ) ; let rhs' = mkOptTickBox tick rhs @@ -685,7 +686,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_arg_tys = in_inst_tys , pat_wrap = req_wrap } - ; return (mkSimpleMatch [pat] wrapped_rhs) } + ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } -- Here is where we desugar the Template Haskell brackets and escapes @@ -909,7 +910,8 @@ dsDo stmts ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty ; let fun = L noSrcSpan $ HsLam $ - MG { mg_alts = noLoc [mkSimpleMatch pats body'] + MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats + body'] , mg_arg_tys = arg_tys , mg_res_ty = body_ty , mg_origin = Generated } @@ -940,7 +942,9 @@ dsDo stmts rets = map noLoc rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] mfix_arg = noLoc $ HsLam - (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body] + (MG { mg_alts = noLoc [mkSimpleMatch + LambdaExpr + [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 370e310204..91489b7bc7 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1553,7 +1553,7 @@ repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m) ----------------------------------------------------------------------------- |