diff options
28 files changed, 271 insertions, 248 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index b44e9d8fa4..13a91a2574 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -509,14 +509,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) = - bindLocals (collectLocalBinders binds) $ - liftM2 HsLet - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExprLetBody e) -addTickHsExpr (HsDo cxt stmts srcloc) +addTickHsExpr (HsLet (L l binds) e) = + bindLocals (collectLocalBinders binds) $ do + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + e' <- addTickLHsExprLetBody e + return $ HsLet (L l binds') 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 @@ -678,9 +678,9 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') (return ty) -addTickStmt _isGuard (LetStmt binds) = do - liftM LetStmt - (addTickHsLocalBinds binds) +addTickStmt _isGuard (LetStmt (L l binds)) = do + binds' <- addTickHsLocalBinds binds + return $ LetStmt (L l binds') addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do liftM3 ParStmt (mapM (addTickStmtAndBinders isGuard) pairs) @@ -797,14 +797,14 @@ addTickHsCmd (HsCmdIf cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet binds c) = - bindLocals (collectLocalBinders binds) $ - liftM2 HsCmdLet - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsCmd c) -addTickHsCmd (HsCmdDo stmts srcloc) +addTickHsCmd (HsCmdLet (L l binds) c) = + bindLocals (collectLocalBinders binds) $ do + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + c' <- addTickLHsCmd c + return $ HsCmdLet (L l binds') 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 @@ -826,9 +826,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) = @@ -837,11 +837,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 @@ -884,9 +884,9 @@ addTickCmdStmt (BodyStmt c bind' guard' ty) = do (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') (return ty) -addTickCmdStmt (LetStmt binds) = do - liftM LetStmt - (addTickHsLocalBinds binds) +addTickCmdStmt (LetStmt (L l binds)) = do + binds' <- addTickHsLocalBinds binds + return $ LetStmt (L l binds') addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 55cd7d2ac3..baed3e2e9f 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -399,8 +399,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) @@ -504,7 +504,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 @@ -547,7 +548,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' @@ -562,7 +564,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 @@ -587,7 +589,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 @@ -832,7 +834,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 @@ -1047,7 +1049,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` @@ -1167,11 +1169,11 @@ collectLStmtBinders :: LStmt Id body -> [Id] collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: Stmt Id body -> [Id] -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_later_ids = later_ids }) = later_ids diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 42aa22245e..a5bd29be64 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -321,19 +321,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 @@ -571,7 +571,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = 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 @@ -839,7 +840,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 } @@ -871,11 +872,12 @@ 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 $ mkBigLHsPatTup 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) (mkBigLHsTup 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 1346f8af5e..2532d6c7a7 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 79d6f47612..6d147605e3 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 @@ -323,7 +323,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 @@ -563,7 +563,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 @@ -673,7 +673,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 9eb37a9c1e..ed43099b6e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1013,8 +1013,8 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) -- 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 } @@ -1032,7 +1032,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 @@ -1046,13 +1046,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); @@ -1114,7 +1114,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 @@ -1126,7 +1126,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 @@ -1201,7 +1201,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) @@ -1280,8 +1280,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 @@ -1290,13 +1291,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) @@ -1340,7 +1343,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 c8e30f18a7..5ea18a4470 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 031a340a0b..6ec9970e4f 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -153,7 +153,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 = ([],[]) } } @@ -611,7 +611,7 @@ cvtClause (Clause ps body wheres) = do { ps' <- cvtPats ps ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres - ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') } + ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' (noLoc ds')) } ------------------------------------------------------------------- @@ -650,7 +650,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 @@ -801,7 +801,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 @@ -814,7 +814,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) } @@ -824,7 +824,7 @@ cvtMatch (TH.Match p body decs) = do { p' <- cvtPat p ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs - ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') } + ; returnL $ Hs.Match Nothing [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 efefd17e4a..31f2152436 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -227,7 +227,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', @@ -236,11 +236,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,...] -- @@ -672,15 +672,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))) @@ -898,7 +898,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' @'{'@, @@ -906,7 +906,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', @@ -992,15 +992,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 ] @@ -1061,7 +1061,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 } @@ -1116,13 +1116,13 @@ Example infix function definition requiring individual API Annotations -} 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] @@ -1139,7 +1139,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) @@ -1156,7 +1156,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 @@ -1207,7 +1207,7 @@ pprMatch ctxt (Match _ pats maybe_ty grhss) 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)) @@ -1284,7 +1284,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] @@ -1517,7 +1517,7 @@ pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> 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)) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index b1c8036bc1..df18317f8b 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -129,20 +129,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 } @@ -223,7 +230,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 @@ -560,13 +567,14 @@ mkPatSynBind name details lpat dir = PatSynBind psb 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 Nothing (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 @@ -661,12 +669,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 @@ -875,11 +883,12 @@ lStmtsImplicits = hs_lstmts hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet - hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat - hs_stmt (LetStmt binds) = hs_local_binds binds - hs_stmt (BodyStmt {}) = emptyNameSet - hs_stmt (LastStmt {}) = emptyNameSet - hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt (L _ binds)) = hs_local_binds binds + hs_stmt (BodyStmt {}) = emptyNameSet + hs_stmt (LastStmt {}) = emptyNameSet + hs_stmt (ParStmt xs _ _) + = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index f7ca79e94f..aedfaf806d 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1339,35 +1339,35 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } | decl { sL1 $1 ([],unLoc $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 06c6564716..87130cc980 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -492,13 +492,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_infix = is_infix1, - fun_matches = MG { mg_alts = mtchs1 } })) binds + fun_matches + = MG { mg_alts = L _ mtchs1 } })) binds | has_args mtchs1 = go is_infix1 mtchs1 loc1 binds [] where go is_infix mtchs loc (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2, - fun_matches = MG { mg_alts = mtchs2 } })) : binds) _ + fun_matches + = MG { mg_alts = L _ mtchs2 } })) : binds) _ | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls @@ -1256,8 +1258,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 @@ -1286,9 +1288,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 beda054423..bdbaa226ef 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -732,7 +732,7 @@ rnMethodBind :: Name -> RnM (Bag (LHsBindLR Name Name), FreeVars) rnMethodBind cls sig_fn (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix - , fun_matches = MG { mg_alts = matches + , fun_matches = MG { mg_alts = L _ matches , mg_origin = origin } })) = setSrcSpan loc $ do sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name @@ -962,7 +962,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 @@ -1026,10 +1026,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 50860f9c9f..924dd248f3 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -199,14 +199,14 @@ 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) <- rnStmts do_or_lc rnLExpr 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 @@ -499,14 +499,14 @@ 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) @@ -532,10 +532,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 @@ -547,7 +547,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 @@ -698,10 +698,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' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') - ; return (([L loc (LetStmt binds')], thing), fvs) } } + ; return (([L loc (LetStmt (L l binds'))], thing), fvs) } } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName @@ -892,11 +892,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 @@ -920,12 +920,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 )] @@ -940,7 +940,7 @@ rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = 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 @@ -987,14 +987,14 @@ 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 ; return [(duDefs du_binds, allUses du_binds, - emptyNameSet, L loc (LetStmt (HsValBinds binds')))] } + emptyNameSet, 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 {}), _) @@ -1006,7 +1006,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_stmts :: Outputable (body RdrName) => @@ -1281,8 +1281,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 c77ef3f7a8..a4a80e9ffa 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -729,7 +729,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 9ad65722cd..106fa04f98 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 Nothing 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 64333ebdb3..00be08d666 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1694,8 +1694,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 353b2b71fa..8a7f7f4f8b 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -427,10 +427,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 d18e6edb60..0c508e721b 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1711,7 +1711,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] @@ -2046,7 +2046,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') @@ -2057,7 +2057,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 80dd175e3c..7dd38c9736 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -538,11 +538,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))) @@ -557,7 +559,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) @@ -565,7 +567,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)) {- ************************************************************************ @@ -681,15 +683,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 @@ -817,15 +819,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) @@ -978,9 +980,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 386a08d282..a714ddb07e 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) } -- For the vanilla case, handle the location-setting part tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside @@ -842,9 +845,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 dc470b4a38..94ac81d11c 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -278,20 +278,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 @@ -385,17 +386,17 @@ 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 InfixPatSyn arg1 arg2 -> [arg1, arg2] add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name) - add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] }) - = mg { mg_alts = [L loc (Match Nothing [nlWildPatName] ty grhss)] } + add_dummy_arg mg@(MG { mg_alts = L l [L loc (Match Nothing [] ty grhss)] }) + = mg { mg_alts = L l [L loc (Match Nothing [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 ec22699ed1..af901609d3 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1570,7 +1570,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 @@ -1578,7 +1578,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] @@ -1707,7 +1707,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) diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 13b80eef87..58a4f9b7d5 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -35,7 +35,7 @@ main = do isDataCon (L _ (AbsBinds { abs_binds = bs })) = not (isEmptyBag (filterBag isDataCon bs)) isDataCon (L l (f@FunBind {})) - | (MG (m:_) _ _ _) <- fun_matches f, + | (MG (L _ (m:_)) _ _ _) <- fun_matches f, (L _ (c@ConPatOut{}):_)<-hsLMatchPats m, (L l _)<-pat_con c = isGoodSrcSpan l -- Check that the source location is a good one diff --git a/testsuite/tests/ghc-api/annotations/T10255.stdout b/testsuite/tests/ghc-api/annotations/T10255.stdout index 099ef5454e..91d32178fc 100644 --- a/testsuite/tests/ghc-api/annotations/T10255.stdout +++ b/testsuite/tests/ghc-api/annotations/T10255.stdout @@ -1,6 +1,5 @@ ---Problems--------------------- [ -(AK <no location info> AnnEofPos = [Test10255.hs:8:1]) ] -------------------------------- diff --git a/testsuite/tests/ghc-api/annotations/exampleTest.stdout b/testsuite/tests/ghc-api/annotations/exampleTest.stdout index 128b70a598..a6a8468a29 100644 --- a/testsuite/tests/ghc-api/annotations/exampleTest.stdout +++ b/testsuite/tests/ghc-api/annotations/exampleTest.stdout @@ -1,8 +1,6 @@ ---Problems--------------------- [ (AK AnnotationTuple.hs:14:39 AnnComma = [AnnotationTuple.hs:14:39]) - -(AK <no location info> AnnEofPos = [AnnotationTuple.hs:32:1]) ] -------------------------------- diff --git a/testsuite/tests/ghc-api/annotations/listcomps.stdout b/testsuite/tests/ghc-api/annotations/listcomps.stdout index 081258a5cf..1c0b8e5ce4 100644 --- a/testsuite/tests/ghc-api/annotations/listcomps.stdout +++ b/testsuite/tests/ghc-api/annotations/listcomps.stdout @@ -12,9 +12,10 @@ ListComprehensions.hs:(18,18)-(22,20), ListComprehensions.hs:(18,20)-(22,20), ListComprehensions.hs:18:22, ListComprehensions.hs:18:22-26, ListComprehensions.hs:18:22-30, - ListComprehensions.hs:18:24, ListComprehensions.hs:18:26, - ListComprehensions.hs:18:28, ListComprehensions.hs:18:30, - ListComprehensions.hs:19:22, ListComprehensions.hs:19:22-33, + ListComprehensions.hs:(18,22)-(21,34), ListComprehensions.hs:18:24, + ListComprehensions.hs:18:26, ListComprehensions.hs:18:28, + ListComprehensions.hs:18:30, ListComprehensions.hs:19:22, + ListComprehensions.hs:19:22-33, ListComprehensions.hs:(19,22)-(21,34), ListComprehensions.hs:19:27-33, ListComprehensions.hs:19:28, ListComprehensions.hs:19:31-32, ListComprehensions.hs:20:22, @@ -30,7 +31,8 @@ ListComprehensions.hs:25:8-10, ListComprehensions.hs:(25,12)-(28,14), ListComprehensions.hs:(25,14)-(28,14), - ListComprehensions.hs:25:16-20, ListComprehensions.hs:26:16, + ListComprehensions.hs:25:16-20, + ListComprehensions.hs:(25,16)-(27,22), ListComprehensions.hs:26:16, ListComprehensions.hs:26:16-23, ListComprehensions.hs:(26,16)-(27,22), ListComprehensions.hs:26:21-23, ListComprehensions.hs:27:21-22, diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index 7d667ed6f8..bddb1be992 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ -(10,10,6) +(11,11,7) (49,45,0) -(12,11,6) -(8,8,6) +(13,12,7) +(9,9,7) |