From 2290c8bd8c3faee0cb7dc1c2c7951bb9d5e3ebf9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 13 Nov 2015 08:39:07 +0200 Subject: APIAnnotations:add Locations in hsSyn for layout Summary: At the moment ghc-exactprint, which uses the GHC API Annotations to provide a framework for roundtripping Haskell source code with optional AST edits, has to implement a horrible workaround to manage the points where layout needs to be captured. These are MatchGroup HsDo HsCmdDo HsLet LetStmt HsCmdLet GRHSs To provide a more natural representation, the contents subject to layout rules need to be wrapped in a SrcSpan. This commit does this. Trac ticket #10250 Test Plan: ./validate Reviewers: hvr, goldfire, bgamari, austin, mpickering Reviewed By: mpickering Subscribers: thomie, mpickering Differential Revision: https://phabricator.haskell.org/D1370 GHC Trac Issues: #10250 --- compiler/deSugar/Coverage.hs | 48 ++++++++++++++++---------------- compiler/deSugar/DsArrows.hs | 18 ++++++------ compiler/deSugar/DsExpr.hs | 33 ++++++++++++---------- compiler/deSugar/DsGRHSs.hs | 4 +-- compiler/deSugar/DsListComp.hs | 8 +++--- compiler/deSugar/DsMeta.hs | 35 ++++++++++++----------- compiler/deSugar/Match.hs | 2 +- compiler/hsSyn/Convert.hs | 14 ++++++---- compiler/hsSyn/HsExpr.hs | 47 ++++++++++++++++--------------- compiler/hsSyn/HsUtils.hs | 42 ++++++++++++++++------------ compiler/main/InteractiveEval.hs | 2 +- compiler/parser/Parser.y | 20 +++++++------- compiler/parser/RdrHsSyn.hs | 14 ++++++---- compiler/rename/RnBinds.hs | 6 ++-- compiler/rename/RnExpr.hs | 60 ++++++++++++++++++++-------------------- compiler/rename/RnTypes.hs | 2 +- compiler/typecheck/TcArrows.hs | 16 +++++------ compiler/typecheck/TcBinds.hs | 4 +-- compiler/typecheck/TcExpr.hs | 4 +-- compiler/typecheck/TcGenDeriv.hs | 9 +++--- compiler/typecheck/TcHsSyn.hs | 30 ++++++++++---------- compiler/typecheck/TcMatches.hs | 43 ++++++++++++++-------------- compiler/typecheck/TcPatSyn.hs | 21 ++++++++------ compiler/typecheck/TcRnDriver.hs | 6 ++-- 24 files changed, 258 insertions(+), 230 deletions(-) (limited to 'compiler') diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 0678acec97..aec2a3fada 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -508,14 +508,14 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet binds e) = +addTickHsExpr (HsLet (L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 HsLet - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExprLetBody e) -addTickHsExpr (HsDo cxt stmts srcloc) + liftM2 (HsLet . L l) + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsExprLetBody e) +addTickHsExpr (HsDo cxt (L l stmts) srcloc) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo cxt stmts' srcloc) } + ; return (HsDo cxt (L l stmts') srcloc) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -610,10 +610,10 @@ addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) -addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = matches' } + return $ mg { mg_alts = L l matches' } addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = @@ -622,11 +622,11 @@ addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = return $ Match mf pats opSig gRHSs' addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) -addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do +addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs guarded' local_binds' + return $ GRHSs guarded' (L l local_binds') where binders = collectLocalBinders local_binds @@ -679,8 +679,8 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') (return ty) -addTickStmt _isGuard (LetStmt binds) = do - liftM LetStmt +addTickStmt _isGuard (LetStmt (L l binds)) = do + liftM (LetStmt . L l) (addTickHsLocalBinds binds) addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do liftM3 ParStmt @@ -815,14 +815,14 @@ addTickHsCmd (HsCmdIf cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet binds c) = +addTickHsCmd (HsCmdLet (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 HsCmdLet - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsCmd c) -addTickHsCmd (HsCmdDo stmts srcloc) + liftM2 (HsCmdLet . L l) + (addTickHsLocalBinds binds) -- to think about: !patterns. + (addTickLHsCmd c) +addTickHsCmd (HsCmdDo (L l stmts) srcloc) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo stmts' srcloc) } + ; return (HsCmdDo (L l stmts') srcloc) } addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsCmdArrApp @@ -844,9 +844,9 @@ addTickHsCmd (HsCmdCast co cmd) --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) -addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do +addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = matches' } + return $ mg { mg_alts = L l matches' } addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) addTickCmdMatch (Match mf pats opSig gRHSs) = @@ -855,11 +855,11 @@ addTickCmdMatch (Match mf pats opSig gRHSs) = return $ Match mf pats opSig gRHSs' addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) -addTickCmdGRHSs (GRHSs guarded local_binds) = do +addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs guarded' local_binds' + return $ GRHSs guarded' (L l local_binds') where binders = collectLocalBinders local_binds @@ -903,8 +903,8 @@ addTickCmdStmt (BodyStmt c bind' guard' ty) = do (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') (return ty) -addTickCmdStmt (LetStmt binds) = do - liftM LetStmt +addTickCmdStmt (LetStmt (L l binds)) = do + liftM (LetStmt . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 1657a5f49d..14c38b0e9a 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -400,8 +400,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _ - (GRHSs [L _ (GRHS [] body)] _ ))] })) + (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ + (GRHSs [L _ (GRHS [] body)] _ ))] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) @@ -505,7 +505,8 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin })) + (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys + , mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -548,7 +549,8 @@ dsCmd ids local_vars stack_ty res_ty (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys + core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' + , mg_arg_tys = arg_tys , mg_res_ty = sum_ty, mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' @@ -563,7 +565,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -588,7 +590,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -833,7 +835,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do +dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -1048,7 +1050,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] -leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds))) +leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 0f5d6e5d53..dc6be9cddd 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -319,19 +319,19 @@ dsExpr (HsCase discrim matches) -- 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) = do +dsExpr (HsLet (L _ binds) body) = do body' <- dsLExpr body dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty -dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) -dsExpr (HsDo DoExpr stmts _) = dsDo stmts -dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts -dsExpr (HsDo MDoExpr stmts _) = dsDo stmts -dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts +dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts +dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts +dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts +dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -567,7 +567,8 @@ dsExpr expr@(RecordUpd record_expr fields -- constructor aguments. ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) - <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty] + <- matchWrapper RecUpd (MG { mg_alts = noLoc alts + , mg_arg_tys = [in_ty] , mg_res_ty = out_ty, mg_origin = FromSource }) -- FromSource is not strictly right, but we -- want incomplete pattern-match warnings @@ -857,7 +858,7 @@ dsDo stmts ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } - go _ (LetStmt binds) stmts + go _ (LetStmt (L _ binds)) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } @@ -888,10 +889,10 @@ dsDo stmts ; rhss' <- sequence rhss ; ops' <- mapM dsExpr (map fst args) - ; let body' = noLoc $ HsDo DoExpr stmts body_ty + ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty ; let fun = L noSrcSpan $ HsLam $ - MG { mg_alts = [mkSimpleMatch pats body'] + MG { mg_alts = noLoc [mkSimpleMatch pats body'] , mg_arg_tys = arg_tys , mg_res_ty = body_ty , mg_origin = Generated } @@ -921,11 +922,13 @@ dsDo stmts later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body] - , mg_arg_tys = [tup_ty], mg_res_ty = body_ty - , mg_origin = Generated }) + mfix_arg = noLoc $ HsLam + (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body] + , mg_arg_tys = [tup_ty], mg_res_ty = body_ty + , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + body = noLoc $ HsDo + DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty ret_app = nlHsApp (noLoc return_op) (mkBigLHsTupId rets) ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 6e4056a7c3..3eafd12c73 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon -> GRHSs Id (LHsExpr Id) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty +dsGRHSs hs_ctx _ (GRHSs grhss (L _ binds)) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results @@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do +matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 985b12e19f..4d11fa21b8 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -221,7 +221,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt binds : quals) list = do +deListComp (LetStmt (L _ binds) : quals) list = do core_rest <- deListComp quals list dsLocalBinds binds core_rest @@ -326,7 +326,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt binds : quals) = do +dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do -- new in 1.3, local bindings core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest @@ -568,7 +568,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- -dePArrComp (LetStmt ds : qs) pa cea = do +dePArrComp (LetStmt (L _ ds) : qs) pa cea = do mapP <- dsDPHBuiltin mapPVar let xs = collectLocalBinders ds ty'cea = parrElemType cea @@ -680,7 +680,7 @@ dsMcStmt (LastStmt body _ ret_op) stmts ; return (App ret_op' body') } -- [ .. | let binds, stmts ] -dsMcStmt (LetStmt binds) stmts +dsMcStmt (LetStmt (L _ binds)) stmts = do { rest <- dsMcStmts stmts ; dsLocalBinds binds rest } diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2ad38c0e36..c0f0ba0db1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1081,8 +1081,8 @@ repE e@(HsRecFld f) = case f of -- HsOverlit can definitely occur repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } -repE (HsLam (MG { mg_alts = [m] })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = ms })) +repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = L _ ms })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } @@ -1100,7 +1100,7 @@ repE (NegApp x _) = do repE (HsPar x) = repLE x repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase e (MG { mg_alts = ms })) +repE (HsCase e (MG { mg_alts = L _ ms })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 @@ -1114,13 +1114,13 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet bs e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } +repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt sts _) +repE e@(HsDo ctxt (L _ sts) _) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1187,7 +1187,7 @@ repE e = notHandled "Expression form" (ppr e) -- Building representations of auxillary structures like Match, Clause, Stmt, repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) = +repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1199,7 +1199,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) = repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) = +repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1286,7 +1286,7 @@ repSts (BindStmt p e _ _ : ss) = ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} -repSts (LetStmt bs : ss) = +repSts (LetStmt (L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) @@ -1365,8 +1365,9 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- with an empty list of patterns rep_bind (L loc (FunBind { fun_id = fn, - fun_matches = MG { mg_alts = [L _ (Match _ [] _ - (GRHSs guards wheres))] } })) + fun_matches = MG { mg_alts + = L _ [L _ (Match _ [] _ + (GRHSs guards (L _ wheres)))] } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -1375,13 +1376,15 @@ rep_bind (L loc (FunBind ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } })) +rep_bind (L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = L _ ms } })) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) +rep_bind (L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs guards (L _ wheres) })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -1425,7 +1428,7 @@ rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec) -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ) -repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) +repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 8af0a6e5e3..fc92bad79d 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -791,7 +791,7 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt (MG { mg_alts = matches +matchWrapper ctxt (MG { mg_alts = L _ matches , mg_arg_tys = arg_tys , mg_res_ty = rhs_ty , mg_origin = origin }) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 2d7194e2b3..0b8ede6087 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -156,7 +156,7 @@ cvtDec (TH.ValD pat body ds) ; body' <- cvtGuard body ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds ; returnJustL $ Hs.ValD $ - PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds' + PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds') , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames , pat_ticks = ([],[]) } } @@ -630,7 +630,8 @@ cvtClause (Clause ps body wheres) = do { ps' <- cvtPats ps ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres - ; returnL $ Hs.Match NonFunBindMatch ps' Nothing (GRHSs g' ds') } + ; returnL $ Hs.Match NonFunBindMatch ps' Nothing + (GRHSs g' (noLoc ds')) } ------------------------------------------------------------------- @@ -669,7 +670,7 @@ cvtl e = wrapL (cvt e) | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf placeHolderType alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds - ; e' <- cvtl e; return $ HsLet ds' e' } + ; e' <- cvtl e; return $ HsLet (noLoc ds') e' } cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms ; return $ HsCase e' (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss @@ -828,7 +829,7 @@ cvtHsDo do_or_lc stmts L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType } + ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType } where bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt @@ -841,7 +842,7 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds - ; returnL $ LetStmt ds' } + ; returnL $ LetStmt (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } @@ -851,7 +852,8 @@ cvtMatch (TH.Match p body decs) = do { p' <- cvtPat p ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs - ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing (GRHSs g' decs') } + ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing + (GRHSs g' (noLoc decs')) } cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 19e7d2fade..a0a9907079 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -237,7 +237,7 @@ data HsExpr id -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (HsLocalBinds id) + | HsLet (Located (HsLocalBinds id)) (LHsExpr id) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', @@ -246,11 +246,11 @@ data HsExpr id -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - [ExprLStmt id] -- "do":one or more stmts - (PostTc id Type) -- Type of the whole expression + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + (Located [ExprLStmt id]) -- "do":one or more stmts + (PostTc id Type) -- Type of the whole expression -- | Syntactic list: [a,b,c,...] -- @@ -713,15 +713,15 @@ ppr_expr (HsMultiIf _ alts) , ptext (sLit "->") <+> pprDeeper (ppr expr) ] -- special case: let ... in let ... -ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) +ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] -ppr_expr (HsLet binds expr) +ppr_expr (HsLet (L _ binds) expr) = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), hang (ptext (sLit "in")) 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts +ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@ -944,7 +944,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdLet (HsLocalBinds id) -- let(rec) + | HsCmdLet (Located (HsLocalBinds id)) -- let(rec) (LHsCmd id) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, @@ -952,7 +952,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdDo [CmdLStmt id] + | HsCmdDo (Located [CmdLStmt id]) (PostTc id Type) -- Type of the whole expression -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', @@ -1037,15 +1037,15 @@ ppr_cmd (HsCmdIf _ e ct ce) nest 4 (ppr ce)] -- special case: let ... in let ... -ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _))) +ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _))) = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lcmd cmd] -ppr_cmd (HsCmdLet binds cmd) +ppr_cmd (HsCmdLet (L _ binds) cmd) = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), hang (ptext (sLit "in")) 2 (ppr cmd)] -ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts +ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd , ptext (sLit "|>") <+> ppr co ] @@ -1106,7 +1106,7 @@ patterns in each equation. -} data MatchGroup id body - = MG { mg_alts :: [LMatch id body] -- The alternatives + = MG { mg_alts :: Located [LMatch id body] -- The alternatives , mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn , mg_res_ty :: PostTc id Type -- Type of the result, tr , mg_origin :: Origin } @@ -1174,13 +1174,13 @@ isInfixMatch match = case m_fixity match of _ -> False isEmptyMatchGroup :: MatchGroup id body -> Bool -isEmptyMatchGroup (MG { mg_alts = ms }) = null ms +isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms matchGroupArity :: MatchGroup id body -> Arity -- Precondition: MatchGroup is non-empty -- This is called before type checking, when mg_arg_tys is not set matchGroupArity (MG { mg_alts = alts }) - | (alt1:_) <- alts = length (hsLMatchPats alt1) + | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) | otherwise = panic "matchGroupArity" hsLMatchPats :: LMatch id body -> [LPat id] @@ -1197,7 +1197,7 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats data GRHSs id body = GRHSs { grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs - grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause + grhssLocalBinds :: Located (HsLocalBinds id) -- ^ The where clause } deriving (Typeable) deriving instance (Data body,DataId id) => Data (GRHSs id body) @@ -1214,7 +1214,7 @@ deriving instance (Data body,DataId id) => Data (GRHS id body) pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => HsMatchContext idL -> MatchGroup idR body -> SDoc pprMatches ctxt (MG { mg_alts = matches }) - = vcat (map (pprMatch ctxt) (map unLoc matches)) + = vcat (map (pprMatch ctxt) (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext @@ -1266,7 +1266,7 @@ pprMatch ctxt match pprGRHSs :: (OutputableBndr idR, Outputable body) => HsMatchContext idL -> GRHSs idR body -> SDoc -pprGRHSs ctxt (GRHSs grhss binds) +pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ ppUnless (isEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) @@ -1360,7 +1360,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, -- For details on above see note [Api annotations] in ApiAnnotation - | LetStmt (HsLocalBindsLR idL idR) + | LetStmt (Located (HsLocalBindsLR idL idR)) -- ParStmts only occur in a list/monad comprehension | ParStmt [ParStmtBlock idL idR] @@ -1607,7 +1607,7 @@ pprStmt (LastStmt expr ret_stripped _) (if ret_stripped then ptext (sLit "return") else empty) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr] -pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] +pprStmt (LetStmt (L _ binds)) = hsep [ptext (sLit "let"), pprBinds binds] pprStmt (BodyStmt expr _ _ _) = ppr expr pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) @@ -1657,7 +1657,8 @@ pprStmt (ApplicativeStmt args mb_join _) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> ptext (sLit "<-") <+> - ppr (HsDo DoExpr (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]) + ppr (HsDo DoExpr (noLoc + (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index e88c7b64f3..259edcaab9 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -142,20 +142,27 @@ mkSimpleMatch pats rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) -unguardedGRHSs rhs@(L loc _) = GRHSs (unguardedRHS loc rhs) emptyLocalBinds +unguardedGRHSs rhs@(L loc _) + = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))] unguardedRHS loc rhs = [L loc (GRHS [] rhs)] mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))] -> MatchGroup RdrName (Located (body RdrName)) -mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [] +mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches + , mg_arg_tys = [] , mg_res_ty = placeHolderType , mg_origin = origin } +mkLocatedList :: [Located a] -> Located [Located a] +mkLocatedList [] = noLoc [] +mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms + mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))] -> MatchGroup Name (Located (body Name)) -mkMatchGroupName origin matches = MG { mg_alts = matches, mg_arg_tys = [] +mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches + , mg_arg_tys = [] , mg_res_ty = placeHolderType , mg_origin = origin } @@ -236,7 +243,7 @@ mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noSyntaxExpr noRebindableInfo :: PlaceHolder noRebindableInfo = PlaceHolder -- Just another placeholder; -mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType +mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = L (getLoc expr) $ mkLastStmt expr @@ -641,9 +648,7 @@ mkPatSynBind name details lpat dir = PatSynBind psb -- considered infix. isInfixFunBind :: HsBindLR id1 id2 -> Bool isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _) - = any isInfix matches - where - isInfix (L _ match) = isInfixMatch match + = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False @@ -651,13 +656,14 @@ isInfixFunBind _ = False mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] -> LHsExpr RdrName -> LHsBind RdrName mk_easy_FunBind loc fun pats expr - = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] + = L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)] ------------ -mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) -mkMatch pats expr binds +mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id) + -> LMatch id (LHsExpr id) +mkMatch pats expr lbinds = noLoc (Match NonFunBindMatch (map paren pats) Nothing - (GRHSs (unguardedRHS noSrcSpan expr) binds)) + (GRHSs (unguardedRHS noSrcSpan expr) lbinds)) where paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) | otherwise = lp @@ -752,12 +758,12 @@ collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: StmtLR idL idR body -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat -collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (BodyStmt {}) = [] -collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders - $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] +collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds +collectStmtBinders (BodyStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders + $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders ApplicativeStmt{} = [] @@ -987,7 +993,7 @@ lStmtsImplicits = hs_lstmts hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts - hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 2b2fdaf9e8..1ef3ceb8b1 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -1029,7 +1029,7 @@ compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do -- create a new binding. let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt . HsValBinds $ + let_stmt = L loc . LetStmt . L loc . HsValBinds $ ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 40481e5d20..a74d7a8b95 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1323,35 +1323,35 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } | decl { sL1 $1 ([], unitOL $1) } | {- empty -} { noLoc ([],nilOL) } -decllist :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } +decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl RdrName))) } : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,snd $ unLoc $2) } - | vocurly decls close { L (gl $2) (fst $ unLoc $2,snd $ unLoc $2) } + ,sL1 $2 $ snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- -binds :: { Located ([AddAnn],HsLocalBinds RdrName) } +binds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } -- May have implicit parameters -- No type declarations - : decllist {% do { val_binds <- cvBindGroup (snd $ unLoc $1) + : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) ; return (sL1 $1 (fst $ unLoc $1 - ,HsValBinds val_binds)) } } + ,sL1 $1 $ HsValBinds val_binds)) } } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,HsIPBinds (IPBinds (unLoc $2) + ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } | vocurly dbinds close { L (getLoc $2) ([] - ,HsIPBinds (IPBinds (unLoc $2) + ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } -wherebinds :: { Located ([AddAnn],HsLocalBinds RdrName) } +wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } -- May have implicit parameters -- No type declarations : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],emptyLocalBinds) } + | {- empty -} { noLoc ([],noLoc emptyLocalBinds) } ----------------------------------------------------------------------------- diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index f804e44f17..384913a1a0 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -388,13 +388,15 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- No AndMonoBinds or EmptyMonoBinds here; just single equations getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), - fun_matches = MG { mg_alts = mtchs1 } })) binds + fun_matches + = MG { mg_alts = L _ mtchs1 } })) binds | has_args mtchs1 = go mtchs1 loc1 binds [] where go mtchs loc (L loc2 (ValD (FunBind { fun_id = L _ f2, - fun_matches = MG { mg_alts = mtchs2 } })) : binds) _ + fun_matches + = MG { mg_alts = L _ mtchs2 } })) : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls @@ -1115,8 +1117,8 @@ checkCmd _ (HsIf cf ep et ee) = do return $ HsCmdIf cf ep pt pe checkCmd _ (HsLet lb e) = checkCommand e >>= (\c -> return $ HsCmdLet lb c) -checkCmd _ (HsDo DoExpr stmts ty) = - mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty) +checkCmd _ (HsDo DoExpr (L l stmts) ty) = + mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty) checkCmd _ (OpApp eLeft op _fixity eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it @@ -1145,9 +1147,9 @@ checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do checkCmdStmt l stmt = cmdStmtFail l stmt checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) -checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do +checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do ms' <- mapM (locMap $ const convert) ms - return $ mg { mg_alts = ms' } + return $ mg { mg_alts = L l ms' } where convert (Match mf pat mty grhss) = do grhss' <- checkCmdGRHSs grhss return $ Match mf pat mty grhss' diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 8db6603f0f..9ec71df7e1 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -1043,7 +1043,7 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> MatchGroup RdrName (Located (body RdrName)) -> RnM (MatchGroup Name (Located (body Name)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) +rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) = do { empty_case_ok <- xoptM Opt_EmptyCase ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms @@ -1108,10 +1108,10 @@ rnGRHSs :: HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> GRHSs RdrName (Located (body RdrName)) -> RnM (GRHSs Name (Located (body Name)), FreeVars) -rnGRHSs ctxt rnBody (GRHSs grhss binds) +rnGRHSs ctxt rnBody (GRHSs grhss (L l binds)) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss - return (GRHSs grhss' binds', fvGRHSs) + return (GRHSs grhss' (L l binds'), fvGRHSs) rnGRHS :: HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 81ed15731e..5764765fd3 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -213,17 +213,17 @@ rnExpr (HsCase expr matches) ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet binds expr) +rnExpr (HsLet (L l binds) expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet binds' expr', fvExpr) } + ; return (HsLet (L l binds') expr', fvExpr) } -rnExpr (HsDo do_or_lc stmts _) +rnExpr (HsDo do_or_lc (L l stmts) _) = do { ((stmts', _), fvs) <- rnStmtsWithPostProcessing do_or_lc rnLExpr postProcessStmtsForApplicativeDo stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } + ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) } rnExpr (ExplicitList _ _ exps) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists @@ -518,15 +518,15 @@ rnCmd (HsCmdIf _ p b1 b2) ; (mb_ite, fvITE) <- lookupIfThenElse ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -rnCmd (HsCmdLet binds cmd) +rnCmd (HsCmdLet (L l binds) cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet binds' cmd', fvExpr) } + ; return (HsCmdLet (L l binds') cmd', fvExpr) } -rnCmd (HsCmdDo stmts _) +rnCmd (HsCmdDo (L l stmts) _) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo stmts' placeHolderType, fvs ) } + ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) } rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd) @@ -552,10 +552,10 @@ methodNamesCmd (HsCmdPar c) = methodNamesLCmd c methodNamesCmd (HsCmdIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts -methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam match) = methodNamesMatch match +methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam match) = methodNamesMatch match methodNamesCmd (HsCmdCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName @@ -567,7 +567,7 @@ methodNamesCmd (HsCmdCase _ matches) --------------------------------------------------- methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars -methodNamesMatch (MG { mg_alts = ms }) +methodNamesMatch (MG { mg_alts = L _ ms }) = plusFVs (map do_one ms) where do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss @@ -793,10 +793,10 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt binds)) thing_inside +rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') - ; return (([(L loc (LetStmt binds'), bind_fvs)], thing), fvs) } } + ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName @@ -996,11 +996,11 @@ rnRecStmtsAndThen rnBody s cont collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> - foldr (\ sig -> \ acc -> case sig of - (L loc (FixSig s)) -> (L loc s) : acc - _ -> acc) acc sigs - _ -> acc) [] l + (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l -- left-hand sides @@ -1024,12 +1024,12 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) return [(L loc (BindStmt pat' body a b), fv_pat)] -rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) +rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _)))) = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds)))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt (HsValBinds binds')), + return [(L loc (LetStmt (L l (HsValBinds binds'))), -- Warning: this is bogus; see function invariant emptyFVs )] @@ -1047,7 +1047,7 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) +rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv @@ -1094,15 +1094,15 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat) ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, L loc (BindStmt pat' body' bind_op fail_op))] } -rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _)), _) +rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds')), _) +rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt (HsValBinds binds')))] } + L loc (LetStmt (L l (HsValBinds binds'))))] } -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) @@ -1114,7 +1114,7 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds), _) +rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) @@ -1747,8 +1747,8 @@ okPatGuardStmt stmt ------------- okParStmt dflags ctxt stmt = case stmt of - LetStmt (HsIPBinds {}) -> emptyInvalid - _ -> okStmt dflags ctxt stmt + LetStmt (L _ (HsIPBinds {})) -> emptyInvalid + _ -> okStmt dflags ctxt stmt ---------------- okDoStmt dflags ctxt stmt diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 37a972aa4d..7fff70312d 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -954,7 +954,7 @@ checkPrecMatch :: Name -> MatchGroup Name body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = ms }) +checkPrecMatch op (MG { mg_alts = L _ ms }) = mapM_ check ms where check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _)) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 76ef03785b..bb7a3744f0 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -136,11 +136,11 @@ tc_cmd env (HsCmdPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar cmd') } -tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty +tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan body_loc $ tc_cmd env body res_ty - ; return (HsCmdLet binds' (L body_loc body')) } + ; return (HsCmdLet (L l binds') (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do @@ -234,7 +234,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) -- D;G |-a (\x.cmd) : (t,stk) --> res tc_cmd env - (HsCmdLam (MG { mg_alts = [L mtch_loc + (HsCmdLam (MG { mg_alts = L l [L mtch_loc (match@(Match _ pats _maybe_rhs_sig grhss))], mg_origin = origin })) (cmd_stk, res_ty) @@ -248,7 +248,7 @@ tc_cmd env ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss') arg_tys = map hsLPatType pats' - cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys + cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) ; return (mkHsCmdCast co cmd') } where @@ -256,10 +256,10 @@ tc_cmd env match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt - tc_grhss (GRHSs grhss binds) stk_ty res_ty + tc_grhss (GRHSs grhss (L l binds)) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs grhss' binds') } + ; return (GRHSs grhss' (L l binds')) } tc_grhs stk_ty res_ty (GRHS guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ @@ -269,10 +269,10 @@ tc_cmd env ------------------------------------------- -- Do notation -tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) +tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } + ; return (mkHsCmdCast co (HsCmdDo (L l stmts') res_ty)) } ----------------------------------------------------------------- diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 9f96a91c9a..ff97fecd50 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1797,8 +1797,8 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind" restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds" - restricted_match (MG { mg_alts = L _ (Match _ [] _ _) : _ }) = True - restricted_match _ = False + restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True + restricted_match _ = False -- No args => like a pattern binding -- Some args => a function binding diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index caf732ba7f..a97c75424e 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -434,10 +434,10 @@ tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty ************************************************************************ -} -tcExpr (HsLet binds expr) res_ty +tcExpr (HsLet (L l binds) expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet binds' expr') } + ; return (HsLet (L l binds') expr') } tcExpr (HsCase scrut matches) exp_ty = do { -- We used to typecheck the case alternatives first. diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 753ea052d0..284c594036 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1720,7 +1720,7 @@ mkSimpleConMatch fold extra_pats con insides = do let vars_needed = takeList insides as_RDRs let pat = nlConVarPat con_name vars_needed rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) - return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds + return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds) -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a] @@ -1919,7 +1919,8 @@ makeG_d. gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) gen_Lift_binds loc tycon | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR) - [mkMatch [nlWildPat] errorMsg_Expr emptyLocalBinds]) + [mkMatch [nlWildPat] errorMsg_Expr + (noLoc emptyLocalBinds)]) , emptyBag) | otherwise = (unitBag lift_bind, emptyBag) where @@ -2157,7 +2158,7 @@ mk_FunBind :: SrcSpan -> RdrName mk_FunBind loc fun pats_and_exprs = mkRdrFunBind (L loc fun) matches where - matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] + matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs] mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') @@ -2168,7 +2169,7 @@ mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') -- which can happen with -XEmptyDataDecls -- See Trac #4302 matches' = if null matches - then [mkMatch [] (error_Expr str) emptyLocalBinds] + then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)] else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 7dd9559089..a11f9d6370 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -537,11 +537,13 @@ zonkLTcSpecPrags env ps zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) -zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin }) +zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys + , mg_res_ty = res_ty, mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypeToTypes env arg_tys ; res_ty' <- zonkTcTypeToType env res_ty - ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) } + ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys' + , mg_res_ty = res_ty', mg_origin = origin }) } zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) @@ -556,7 +558,7 @@ zonkGRHSs :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) -zonkGRHSs env zBody (GRHSs grhss binds) = do +zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS guarded rhs) @@ -564,7 +566,7 @@ zonkGRHSs env zBody (GRHSs grhss binds) = do new_rhs <- zBody env2 rhs return (GRHS new_guarded new_rhs) new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs new_grhss new_binds) + return (GRHSs new_grhss (L l new_binds)) {- ************************************************************************ @@ -680,15 +682,15 @@ zonkExpr env (HsMultiIf ty alts) ; expr' <- zonkLExpr env' expr ; return $ GRHS guard' expr' } -zonkExpr env (HsLet binds expr) +zonkExpr env (HsLet (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet new_binds new_expr) + return (HsLet (L l new_binds) new_expr) -zonkExpr env (HsDo do_or_lc stmts ty) +zonkExpr env (HsDo do_or_lc (L l stmts) ty) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToType env ty - return (HsDo do_or_lc new_stmts new_ty) + return (HsDo do_or_lc (L l new_stmts) new_ty) zonkExpr env (ExplicitList ty wit exprs) = do new_ty <- zonkTcTypeToType env ty @@ -818,15 +820,15 @@ zonkCmd env (HsCmdIf eCond ePred cThen cElse) ; new_cElse <- zonkLCmd env cElse ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet binds cmd) +zonkCmd env (HsCmdLet (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet new_binds new_cmd) + return (HsCmdLet (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo stmts ty) +zonkCmd env (HsCmdDo (L l stmts) ty) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToType env ty - return (HsCmdDo new_stmts new_ty) + return (HsCmdDo (L l new_stmts) new_ty) @@ -979,9 +981,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt binds) +zonkStmt env _ (LetStmt (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt new_binds) + return (env1, LetStmt (L l new_binds)) zonkStmt env zBody (BindStmt pat body bind_op fail_op) = do { new_body <- zBody env body diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 81dfb6cc52..d7dbddf6ec 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -104,7 +104,8 @@ tcMatchesCase :: (Outputable (body Name)) => tcMatchesCase ctxt scrut_ty matches res_ty | isEmptyMatchGroup matches -- Allow empty case expressions - = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty, mg_origin = mg_origin matches }) + = return (MG { mg_alts = noLoc [], mg_arg_tys = [scrut_ty] + , mg_res_ty = res_ty, mg_origin = mg_origin matches }) | otherwise = tcMatches ctxt [scrut_ty] res_ty matches @@ -170,10 +171,11 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module -> TcRhoType -> TcM (Located (body TcId)) } -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin }) +tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches, mg_origin = origin }) = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches - ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty, mg_origin = origin }) } + ; return (MG { mg_alts = L l matches', mg_arg_tys = pat_tys + , mg_res_ty = rhs_ty, mg_origin = origin }) } ------------- tcMatch :: (Outputable (body Name)) => TcMatchCtxt body @@ -215,11 +217,11 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more -tcGRHSs ctxt (GRHSs grhss binds) res_ty +tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - ; return (GRHSs grhss' binds') } + ; return (GRHSs grhss' (L l binds')) } ------------- tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name)) @@ -241,32 +243,32 @@ tcGRHS ctxt res_ty (GRHS guards rhs) -} tcDoStmts :: HsStmtContext Name - -> [LStmt Name (LHsExpr Name)] + -> Located [LStmt Name (LHsExpr Name)] -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo -tcDoStmts ListComp stmts res_ty +tcDoStmts ListComp (L l stmts) res_ty = do { (co, elt_ty) <- matchExpectedListTy res_ty ; let list_ty = mkListTy elt_ty ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty - ; return $ mkHsWrapCo co (HsDo ListComp stmts' list_ty) } + ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) } -tcDoStmts PArrComp stmts res_ty +tcDoStmts PArrComp (L l stmts) res_ty = do { (co, elt_ty) <- matchExpectedPArrTy res_ty ; let parr_ty = mkPArrTy elt_ty ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty - ; return $ mkHsWrapCo co (HsDo PArrComp stmts' parr_ty) } + ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) } -tcDoStmts DoExpr stmts res_ty +tcDoStmts DoExpr (L l stmts) res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty - ; return (HsDo DoExpr stmts' res_ty) } + ; return (HsDo DoExpr (L l stmts') res_ty) } -tcDoStmts MDoExpr stmts res_ty +tcDoStmts MDoExpr (L l stmts) res_ty = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty - ; return (HsDo MDoExpr stmts' res_ty) } + ; return (HsDo MDoExpr (L l stmts') res_ty) } -tcDoStmts MonadComp stmts res_ty +tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty - ; return (HsDo MonadComp stmts' res_ty) } + ; return (HsDo MonadComp (L l stmts') res_ty) } tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) @@ -320,10 +322,11 @@ tcStmtsAndThen _ _ [] res_ty thing_inside ; return ([], thing) } -- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (L l binds)) : stmts) + res_ty thing_inside = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt binds') : stmts', thing) } + ; return (L loc (LetStmt (L l binds')) : stmts', thing) } -- Don't set the error context for an ApplicativeStmt. It ought to be -- possible to do this with a popErrCtxt in the tcStmt case for @@ -950,9 +953,9 @@ number of args are used in each equation. -} checkArgs :: Name -> MatchGroup Name body -> TcM () -checkArgs _ (MG { mg_alts = [] }) +checkArgs _ (MG { mg_alts = L _ [] }) = return () -checkArgs fun (MG { mg_alts = match1:matches }) +checkArgs fun (MG { mg_alts = L _ (match1:matches) }) | null bad_matches = return () | otherwise diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 094d3f62af..b27c9e38ff 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -331,20 +331,21 @@ tcPatSynMatcher (L loc name) lpat body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ HsCase (nlHsVar scrutinee) $ - MG{ mg_alts = cases + MG{ mg_alts = L (getLoc lpat) cases , mg_arg_tys = [pat_ty] , mg_res_ty = res_ty , mg_origin = Generated } body' = noLoc $ HsLam $ - MG{ mg_alts = [mkSimpleMatch args body] + MG{ mg_alts = noLoc [mkSimpleMatch args body] , mg_arg_tys = [pat_ty, cont_ty, res_ty] , mg_res_ty = res_ty , mg_origin = Generated } - match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds - mg = MG{ mg_alts = [match] + match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') + (noLoc EmptyLocalBinds) + mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] , mg_res_ty = res_ty , mg_origin = Generated @@ -446,9 +447,9 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name) mk_mg body = mkMatchGroupName Generated [builder_match] - where - builder_args = [L loc (VarPat n) | L loc n <- args] - builder_match = mkMatch builder_args body EmptyLocalBinds + where + builder_args = [L loc (VarPat n) | L loc n <- args] + builder_match = mkMatch builder_args body (noLoc EmptyLocalBinds) args = case details of PrefixPatSyn args -> args @@ -456,8 +457,10 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat RecordPatSyn args -> map recordPatSynPatVar args add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name) - add_dummy_arg mg@(MG {mg_alts = [L l (Match NonFunBindMatch [] ty grhss)] }) - = mg { mg_alts = [L l (Match NonFunBindMatch [nlWildPatName] ty grhss)] } + add_dummy_arg mg@(MG { mg_alts + = L l [L loc (Match NonFunBindMatch [] ty grhss)] }) + = mg { mg_alts + = L l [L loc (Match NonFunBindMatch [nlWildPatName] ty grhss)] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches (PatSyn :: HsMatchContext Name) other_mg diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index febd8900f5..1987354dbd 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1597,7 +1597,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc - matches = [mkMatch [] rn_expr emptyLocalBinds] + matches = [mkMatch [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr] the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs } -- Care here! In GHCi the expression might have @@ -1605,7 +1605,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt $ HsValBinds $ + let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] -- [it <- e] @@ -1734,7 +1734,7 @@ tcGhciStmts stmts stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmtCtxt stmts io_ret_ty)) + noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty)) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -- cgit v1.2.1