diff options
Diffstat (limited to 'compiler/GHC/HsToCore/Expr.hs')
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 76 |
1 files changed, 38 insertions, 38 deletions
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 387963827e..1b18176051 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -80,11 +80,11 @@ import Data.Void( absurd ) ************************************************************************ -} -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds (EmptyLocalBinds _) body = return body +dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $ + dsValBinds binds body +dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body ------------------------- -- caller sets location @@ -121,7 +121,7 @@ ds_val_bind (NonRecursive, hsbinds) body -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) , isUnliftedHsBind bind - = putSrcSpanDs loc $ + = putSrcSpanDs (locA loc) $ -- see Note [Strict binds checks] in GHC.HsToCore.Binds if is_polymorphic bind then errDsCoreExpr (poly_bind_err bind) @@ -249,7 +249,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) -- ; return core_expr } dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsLExpr (L loc e) = - putSrcSpanDs loc $ dsExpr e + putSrcSpanDsA loc $ dsExpr e -- | Variant of 'dsLExpr' that ensures that the result is not levity -- polymorphic. This should be used when the resulting expression will @@ -258,7 +258,7 @@ dsLExpr (L loc e) = -- See Note [Levity polymorphism invariants] in "GHC.Core" dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e) - = putSrcSpanDs loc $ + = putSrcSpanDsA loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) ; return e' } @@ -311,7 +311,7 @@ dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e))) dsExpr (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) - = do { expr' <- putSrcSpanDs loc $ do + = do { expr' <- putSrcSpanDsA loc $ do { warnAboutOverflowedOverLit (lit { ol_val = HsIntegral (negateIntegralLit i) }) ; dsOverLit lit } @@ -356,12 +356,12 @@ converting to core it must become a CO. -} dsExpr (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty))) + = do { let go (lam_vars, args) (Missing (Scaled mult ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP mult ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present _ expr)) + go (lam_vars, args) (Present _ expr) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr @@ -411,7 +411,7 @@ dsExpr (HsMultiIf res_ty alts) = mkErrorExpr | otherwise - = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds) + = do { let grhss = GRHSs noExtField alts emptyLocalBinds ; rhss_nablas <- pmcGRHSs IfAlt grhss ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas ; error_expr <- mkErrorExpr @@ -452,7 +452,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do dflags <- getDynFlags let platform = targetPlatform dflags - let (line, col) = case loc of + let (line, col) = case locA loc of RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r , srcLocCol $ realSrcSpanStart r @@ -463,7 +463,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do , mkIntExprInt platform line, mkIntExprInt platform col ] - putSrcSpanDs loc $ return $ + putSrcSpanDsA loc $ return $ mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] {- @@ -633,7 +633,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] - (MG { mg_alts = noLoc alts + (MG { mg_alts = noLocA alts , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty , mg_origin = FromSource }) @@ -687,7 +687,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) + inst_con = noLocA $ mkHsWrap wrap (HsConLikeOut noExtField con) -- Reconstruct with the WrapId so that unpacking happens wrap = mkWpEvVarApps theta_vars <.> dict_req_wrap <.> @@ -731,16 +731,16 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - pat = noLoc $ ConPat { pat_con = noLoc con - , pat_args = PrefixCon [] $ map nlVarPat arg_ids - , pat_con_ext = ConPatTc - { cpt_tvs = ex_tvs - , cpt_dicts = eqs_vars ++ theta_vars - , cpt_binds = emptyTcEvBinds - , cpt_arg_tys = in_inst_tys - , cpt_wrap = req_wrap - } - } + pat = noLocA $ ConPat { pat_con = noLocA con + , pat_args = PrefixCon [] $ map nlVarPat arg_ids + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs + , cpt_dicts = eqs_vars ++ theta_vars + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = in_inst_tys + , cpt_wrap = req_wrap + } + } ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } {- Note [Scrutinee in Record updates] @@ -813,7 +813,7 @@ ds_prag_expr (HsPragSCC _ _ cc) expr = do count <- goptM Opt_ProfCountEntries let nm = sl_fs cc flavour <- ExprCC <$> getCCIndexDsM nm - Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) + Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True) <$> dsLExpr expr else dsLExpr expr @@ -951,7 +951,7 @@ dsDo ctx stmts = goL stmts where goL [] = panic "dsDo" - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts) go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body @@ -984,11 +984,11 @@ dsDo ctx stmts do_arg (ApplicativeArgOne fail_op pat expr _) = ((pat, fail_op), dsLExpr expr) do_arg (ApplicativeArgMany _ stmts ret pat _) = - ((pat, Nothing), dsDo ctx (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)])) ; rhss' <- sequence rhss - ; body' <- dsLExpr $ noLoc $ HsDo body_ty ctx (noLoc stmts) + ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts) ; let match_args (pat, fail_op) (vs,body) = do { var <- selectSimpleMatchVarL Many pat @@ -1006,7 +1006,7 @@ dsDo ctx stmts Nothing -> return expr Just join_op -> dsSyntaxExpr join_op [expr] } - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op , recS_ext = RecStmtTc @@ -1029,19 +1029,19 @@ dsDo ctx stmts tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats - rets = map noLoc rec_rets + rets = map noLocA rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam noExtField - (MG { mg_alts = noLoc [mkSimpleMatch + mfix_arg = noLocA $ HsLam noExtField + (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr [mfix_pat] body] , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo body_ty - ctx (noLoc (rec_stmts ++ [ret_stmt])) + mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats + body = noLocA $ HsDo body_ty + ctx (noLocA (rec_stmts ++ [ret_stmt])) ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] - ret_stmt = noLoc $ mkLastStmt ret_app + ret_stmt = noLocA $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, -- which ignores the return_op in the LastStmt, -- so we must apply the return_op explicitly |