1{- 2(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 3 4\section[RnExpr]{Renaming of expressions} 5 6Basically dependency analysis. 7 8Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In 9general, all of these functions return a renamed thing, and a set of 10free variables. 11-} 12 13{-# LANGUAGE CPP #-} 14{-# LANGUAGE ScopedTypeVariables #-} 15{-# LANGUAGE MultiWayIf #-} 16{-# LANGUAGE TypeFamilies #-} 17{-# LANGUAGE ViewPatterns #-} 18 19module RnExpr ( 20 rnLExpr, rnExpr, rnStmts 21 ) where 22 23#include "HsVersions.h" 24 25import GhcPrelude 26 27import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, 28 rnMatchGroup, rnGRHS, makeMiniFixityEnv) 29import GHC.Hs 30import TcEnv ( isBrackStage ) 31import TcRnMonad 32import Module ( getModule ) 33import RnEnv 34import RnFixity 35import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames 36 , bindLocalNames 37 , mapMaybeFvRn, mapFvRn 38 , warnUnusedLocalBinds, typeAppErr 39 , checkUnusedRecordWildcard ) 40import RnUnbound ( reportUnboundName ) 41import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName ) 42import RnTypes 43import RnPat 44import DynFlags 45import PrelNames 46 47import BasicTypes 48import Name 49import NameSet 50import RdrName 51import UniqSet 52import Data.List 53import Util 54import ListSetOps ( removeDups ) 55import ErrUtils 56import Outputable 57import SrcLoc 58import FastString 59import Control.Monad 60import TysWiredIn ( nilDataConName ) 61import qualified GHC.LanguageExtensions as LangExt 62 63import Data.Ord 64import Data.Array 65import qualified Data.List.NonEmpty as NE 66 67import Unique ( mkVarOccUnique ) 68 69{- 70************************************************************************ 71* * 72\subsubsection{Expressions} 73* * 74************************************************************************ 75-} 76 77rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) 78rnExprs ls = rnExprs' ls emptyUniqSet 79 where 80 rnExprs' [] acc = return ([], acc) 81 rnExprs' (expr:exprs) acc = 82 do { (expr', fvExpr) <- rnLExpr expr 83 -- Now we do a "seq" on the free vars because typically it's small 84 -- or empty, especially in very long lists of constants 85 ; let acc' = acc `plusFV` fvExpr 86 ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' 87 ; return (expr':exprs', fvExprs) } 88 89-- Variables. We look up the variable and return the resulting name. 90 91rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) 92rnLExpr = wrapLocFstM rnExpr 93 94rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) 95 96finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) 97-- Separated from rnExpr because it's also used 98-- when renaming infix expressions 99finishHsVar (L l name) 100 = do { this_mod <- getModule 101 ; when (nameIsLocalOrFrom this_mod name) $ 102 checkThLocalName name 103 ; return (HsVar noExtField (L l name), unitFV name) } 104 105rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) 106rnUnboundVar v 107 = do { if isUnqual v 108 then -- Treat this as a "hole" 109 -- Do not fail right now; instead, return HsUnboundVar 110 -- and let the type checker report the error 111 do { let occ = rdrNameOcc v 112 ; uv <- if startsWithUnderscore occ 113 then return (TrueExprHole occ) 114 else OutOfScope occ <$> getGlobalRdrEnv 115 ; return (HsUnboundVar noExtField uv, emptyFVs) } 116 117 else -- Fail immediately (qualified name) 118 do { n <- reportUnboundName v 119 ; return (HsVar noExtField (noLoc n), emptyFVs) } } 120 121rnExpr (HsVar _ (L l v)) 122 = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields 123 ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v 124 ; dflags <- getDynFlags 125 ; case mb_name of { 126 Nothing -> rnUnboundVar v ; 127 Just (Left name) 128 | name == nilDataConName -- Treat [] as an ExplicitList, so that 129 -- OverloadedLists works correctly 130 -- Note [Empty lists] in GHC.Hs.Expr 131 , xopt LangExt.OverloadedLists dflags 132 -> rnExpr (ExplicitList noExtField Nothing []) 133 134 | otherwise 135 -> finishHsVar (L l name) ; 136 Just (Right [s]) -> 137 return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ; 138 Just (Right fs@(_:_:_)) -> 139 return ( HsRecFld noExtField (Ambiguous noExtField (L l v)) 140 , mkFVs fs); 141 Just (Right []) -> panic "runExpr/HsVar" } } 142 143rnExpr (HsIPVar x v) 144 = return (HsIPVar x v, emptyFVs) 145 146rnExpr (HsUnboundVar x v) 147 = return (HsUnboundVar x v, emptyFVs) 148 149rnExpr (HsOverLabel x _ v) 150 = do { rebindable_on <- xoptM LangExt.RebindableSyntax 151 ; if rebindable_on 152 then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) 153 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } 154 else return (HsOverLabel x Nothing v, emptyFVs) } 155 156rnExpr (HsLit x lit@(HsString src s)) 157 = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings 158 ; if opt_OverloadedStrings then 159 rnExpr (HsOverLit x (mkHsIsString src s)) 160 else do { 161 ; rnLit lit 162 ; return (HsLit x (convertLit lit), emptyFVs) } } 163 164rnExpr (HsLit x lit) 165 = do { rnLit lit 166 ; return (HsLit x(convertLit lit), emptyFVs) } 167 168rnExpr (HsOverLit x lit) 169 = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] 170 ; case mb_neg of 171 Nothing -> return (HsOverLit x lit', fvs) 172 Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) 173 , fvs ) } 174 175rnExpr (HsApp x fun arg) 176 = do { (fun',fvFun) <- rnLExpr fun 177 ; (arg',fvArg) <- rnLExpr arg 178 ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } 179 180rnExpr (HsAppType x fun arg) 181 = do { type_app <- xoptM LangExt.TypeApplications 182 ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg 183 ; (fun',fvFun) <- rnLExpr fun 184 ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg 185 ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } 186 187rnExpr (OpApp _ e1 op e2) 188 = do { (e1', fv_e1) <- rnLExpr e1 189 ; (e2', fv_e2) <- rnLExpr e2 190 ; (op', fv_op) <- rnLExpr op 191 192 -- Deal with fixity 193 -- When renaming code synthesised from "deriving" declarations 194 -- we used to avoid fixity stuff, but we can't easily tell any 195 -- more, so I've removed the test. Adding HsPars in TcGenDeriv 196 -- should prevent bad things happening. 197 ; fixity <- case op' of 198 L _ (HsVar _ (L _ n)) -> lookupFixityRn n 199 L _ (HsRecFld _ f) -> lookupFieldFixityRn f 200 _ -> return (Fixity NoSourceText minPrecedence InfixL) 201 -- c.f. lookupFixity for unbound 202 203 ; final_e <- mkOpAppRn e1' op' fixity e2' 204 ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } 205 206rnExpr (NegApp _ e _) 207 = do { (e', fv_e) <- rnLExpr e 208 ; (neg_name, fv_neg) <- lookupSyntaxName negateName 209 ; final_e <- mkNegAppRn e' neg_name 210 ; return (final_e, fv_e `plusFV` fv_neg) } 211 212------------------------------------------ 213-- Template Haskell extensions 214rnExpr e@(HsBracket _ br_body) = rnBracket e br_body 215 216rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice 217 218--------------------------------------------- 219-- Sections 220-- See Note [Parsing sections] in Parser.y 221rnExpr (HsPar x (L loc (section@(SectionL {})))) 222 = do { (section', fvs) <- rnSection section 223 ; return (HsPar x (L loc section'), fvs) } 224 225rnExpr (HsPar x (L loc (section@(SectionR {})))) 226 = do { (section', fvs) <- rnSection section 227 ; return (HsPar x (L loc section'), fvs) } 228 229rnExpr (HsPar x e) 230 = do { (e', fvs_e) <- rnLExpr e 231 ; return (HsPar x e', fvs_e) } 232 233rnExpr expr@(SectionL {}) 234 = do { addErr (sectionErr expr); rnSection expr } 235rnExpr expr@(SectionR {}) 236 = do { addErr (sectionErr expr); rnSection expr } 237 238--------------------------------------------- 239rnExpr (HsCoreAnn x src ann expr) 240 = do { (expr', fvs_expr) <- rnLExpr expr 241 ; return (HsCoreAnn x src ann expr', fvs_expr) } 242 243rnExpr (HsSCC x src lbl expr) 244 = do { (expr', fvs_expr) <- rnLExpr expr 245 ; return (HsSCC x src lbl expr', fvs_expr) } 246rnExpr (HsTickPragma x src info srcInfo expr) 247 = do { (expr', fvs_expr) <- rnLExpr expr 248 ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } 249 250rnExpr (HsLam x matches) 251 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches 252 ; return (HsLam x matches', fvMatch) } 253 254rnExpr (HsLamCase x matches) 255 = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches 256 ; return (HsLamCase x matches', fvs_ms) } 257 258rnExpr (HsCase x expr matches) 259 = do { (new_expr, e_fvs) <- rnLExpr expr 260 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches 261 ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } 262 263rnExpr (HsLet x (L l binds) expr) 264 = rnLocalBindsAndThen binds $ \binds' _ -> do 265 { (expr',fvExpr) <- rnLExpr expr 266 ; return (HsLet x (L l binds') expr', fvExpr) } 267 268rnExpr (HsDo x do_or_lc (L l stmts)) 269 = do { ((stmts', _), fvs) <- 270 rnStmtsWithPostProcessing do_or_lc rnLExpr 271 postProcessStmtsForApplicativeDo stmts 272 (\ _ -> return ((), emptyFVs)) 273 ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } 274 275rnExpr (ExplicitList x _ exps) 276 = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists 277 ; (exps', fvs) <- rnExprs exps 278 ; if opt_OverloadedLists 279 then do { 280 ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName 281 ; return (ExplicitList x (Just from_list_n_name) exps' 282 , fvs `plusFV` fvs') } 283 else 284 return (ExplicitList x Nothing exps', fvs) } 285 286rnExpr (ExplicitTuple x tup_args boxity) 287 = do { checkTupleSection tup_args 288 ; checkTupSize (length tup_args) 289 ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args 290 ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } 291 where 292 rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e 293 ; return (L l (Present x e'), fvs) } 294 rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) 295 , emptyFVs) 296 rnTupArg (L _ (XTupArg nec)) = noExtCon nec 297 298rnExpr (ExplicitSum x alt arity expr) 299 = do { (expr', fvs) <- rnLExpr expr 300 ; return (ExplicitSum x alt arity expr', fvs) } 301 302rnExpr (RecordCon { rcon_con_name = con_id 303 , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) 304 = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id 305 ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds 306 ; (flds', fvss) <- mapAndUnzipM rn_field flds 307 ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } 308 ; return (RecordCon { rcon_ext = noExtField 309 , rcon_con_name = con_lname, rcon_flds = rec_binds' } 310 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } 311 where 312 mk_hs_var l n = HsVar noExtField (L l n) 313 rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) 314 ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } 315 316rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) 317 = do { (expr', fvExpr) <- rnLExpr expr 318 ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds 319 ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' 320 , rupd_flds = rbinds' } 321 , fvExpr `plusFV` fvRbinds) } 322 323rnExpr (ExprWithTySig _ expr pty) 324 = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty 325 ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ 326 rnLExpr expr 327 ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } 328 329rnExpr (HsIf x _ p b1 b2) 330 = do { (p', fvP) <- rnLExpr p 331 ; (b1', fvB1) <- rnLExpr b1 332 ; (b2', fvB2) <- rnLExpr b2 333 ; (mb_ite, fvITE) <- lookupIfThenElse 334 ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } 335 336rnExpr (HsMultiIf x alts) 337 = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts 338 -- ; return (HsMultiIf ty alts', fvs) } 339 ; return (HsMultiIf x alts', fvs) } 340 341rnExpr (ArithSeq x _ seq) 342 = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists 343 ; (new_seq, fvs) <- rnArithSeq seq 344 ; if opt_OverloadedLists 345 then do { 346 ; (from_list_name, fvs') <- lookupSyntaxName fromListName 347 ; return (ArithSeq x (Just from_list_name) new_seq 348 , fvs `plusFV` fvs') } 349 else 350 return (ArithSeq x Nothing new_seq, fvs) } 351 352{- 353************************************************************************ 354* * 355 Static values 356* * 357************************************************************************ 358 359For the static form we check that it is not used in splices. 360We also collect the free variables of the term which come from 361this module. See Note [Grand plan for static forms] in StaticPtrTable. 362-} 363 364rnExpr e@(HsStatic _ expr) = do 365 -- Normally, you wouldn't be able to construct a static expression without 366 -- first enabling -XStaticPointers in the first place, since that extension 367 -- is what makes the parser treat `static` as a keyword. But this is not a 368 -- sufficient safeguard, as one can construct static expressions by another 369 -- mechanism: Template Haskell (see #14204). To ensure that GHC is 370 -- absolutely prepared to cope with static forms, we check for 371 -- -XStaticPointers here as well. 372 unlessXOptM LangExt.StaticPointers $ 373 addErr $ hang (text "Illegal static expression:" <+> ppr e) 374 2 (text "Use StaticPointers to enable this extension") 375 (expr',fvExpr) <- rnLExpr expr 376 stage <- getStage 377 case stage of 378 Splice _ -> addErr $ sep 379 [ text "static forms cannot be used in splices:" 380 , nest 2 $ ppr e 381 ] 382 _ -> return () 383 mod <- getModule 384 let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr 385 return (HsStatic fvExpr' expr', fvExpr) 386 387{- 388************************************************************************ 389* * 390 Arrow notation 391* * 392************************************************************************ 393-} 394 395rnExpr (HsProc x pat body) 396 = newArrowScope $ 397 rnPat ProcExpr pat $ \ pat' -> do 398 { (body',fvBody) <- rnCmdTop body 399 ; return (HsProc x pat' body', fvBody) } 400 401rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) 402 -- HsWrap 403 404---------------------- 405-- See Note [Parsing sections] in Parser.y 406rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) 407rnSection section@(SectionR x op expr) 408 = do { (op', fvs_op) <- rnLExpr op 409 ; (expr', fvs_expr) <- rnLExpr expr 410 ; checkSectionPrec InfixR section op' expr' 411 ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } 412 413rnSection section@(SectionL x expr op) 414 = do { (expr', fvs_expr) <- rnLExpr expr 415 ; (op', fvs_op) <- rnLExpr op 416 ; checkSectionPrec InfixL section op' expr' 417 ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } 418 419rnSection other = pprPanic "rnSection" (ppr other) 420 421{- 422************************************************************************ 423* * 424 Arrow commands 425* * 426************************************************************************ 427-} 428 429rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) 430rnCmdArgs [] = return ([], emptyFVs) 431rnCmdArgs (arg:args) 432 = do { (arg',fvArg) <- rnCmdTop arg 433 ; (args',fvArgs) <- rnCmdArgs args 434 ; return (arg':args', fvArg `plusFV` fvArgs) } 435 436rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) 437rnCmdTop = wrapLocFstM rnCmdTop' 438 where 439 rnCmdTop' (HsCmdTop _ cmd) 440 = do { (cmd', fvCmd) <- rnLCmd cmd 441 ; let cmd_names = [arrAName, composeAName, firstAName] ++ 442 nameSetElemsStable (methodNamesCmd (unLoc cmd')) 443 -- Generate the rebindable syntax for the monad 444 ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names 445 446 ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', 447 fvCmd `plusFV` cmd_fvs) } 448 rnCmdTop' (XCmdTop nec) = noExtCon nec 449 450rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) 451rnLCmd = wrapLocFstM rnCmd 452 453rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) 454 455rnCmd (HsCmdArrApp x arrow arg ho rtl) 456 = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) 457 ; (arg',fvArg) <- rnLExpr arg 458 ; return (HsCmdArrApp x arrow' arg' ho rtl, 459 fvArrow `plusFV` fvArg) } 460 where 461 select_arrow_scope tc = case ho of 462 HsHigherOrderApp -> tc 463 HsFirstOrderApp -> escapeArrowScope tc 464 -- See Note [Escaping the arrow scope] in TcRnTypes 465 -- Before renaming 'arrow', use the environment of the enclosing 466 -- proc for the (-<) case. 467 -- Local bindings, inside the enclosing proc, are not in scope 468 -- inside 'arrow'. In the higher-order case (-<<), they are. 469 470-- infix form 471rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) 472 = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) 473 ; let L _ (HsVar _ (L _ op_name)) = op' 474 ; (arg1',fv_arg1) <- rnCmdTop arg1 475 ; (arg2',fv_arg2) <- rnCmdTop arg2 476 -- Deal with fixity 477 ; fixity <- lookupFixityRn op_name 478 ; final_e <- mkOpFormRn arg1' op' fixity arg2' 479 ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } 480 481rnCmd (HsCmdArrForm x op f fixity cmds) 482 = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) 483 ; (cmds',fvCmds) <- rnCmdArgs cmds 484 ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } 485 486rnCmd (HsCmdApp x fun arg) 487 = do { (fun',fvFun) <- rnLCmd fun 488 ; (arg',fvArg) <- rnLExpr arg 489 ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } 490 491rnCmd (HsCmdLam x matches) 492 = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches 493 ; return (HsCmdLam x matches', fvMatch) } 494 495rnCmd (HsCmdPar x e) 496 = do { (e', fvs_e) <- rnLCmd e 497 ; return (HsCmdPar x e', fvs_e) } 498 499rnCmd (HsCmdCase x expr matches) 500 = do { (new_expr, e_fvs) <- rnLExpr expr 501 ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches 502 ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } 503 504rnCmd (HsCmdIf x _ p b1 b2) 505 = do { (p', fvP) <- rnLExpr p 506 ; (b1', fvB1) <- rnLCmd b1 507 ; (b2', fvB2) <- rnLCmd b2 508 ; (mb_ite, fvITE) <- lookupIfThenElse 509 ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} 510 511rnCmd (HsCmdLet x (L l binds) cmd) 512 = rnLocalBindsAndThen binds $ \ binds' _ -> do 513 { (cmd',fvExpr) <- rnLCmd cmd 514 ; return (HsCmdLet x (L l binds') cmd', fvExpr) } 515 516rnCmd (HsCmdDo x (L l stmts)) 517 = do { ((stmts', _), fvs) <- 518 rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) 519 ; return ( HsCmdDo x (L l stmts'), fvs ) } 520 521rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) 522rnCmd (XCmd nec) = noExtCon nec 523 524--------------------------------------------------- 525type CmdNeeds = FreeVars -- Only inhabitants are 526 -- appAName, choiceAName, loopAName 527 528-- find what methods the Cmd needs (loop, choice, apply) 529methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds 530methodNamesLCmd = methodNamesCmd . unLoc 531 532methodNamesCmd :: HsCmd GhcRn -> CmdNeeds 533 534methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) 535 = emptyFVs 536methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) 537 = unitFV appAName 538methodNamesCmd (HsCmdArrForm {}) = emptyFVs 539methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd 540 541methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c 542 543methodNamesCmd (HsCmdIf _ _ _ c1 c2) 544 = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName 545 546methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c 547methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts 548methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c 549methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match 550 551methodNamesCmd (HsCmdCase _ _ matches) 552 = methodNamesMatch matches `addOneFV` choiceAName 553 554methodNamesCmd (XCmd nec) = noExtCon nec 555 556--methodNamesCmd _ = emptyFVs 557 -- Other forms can't occur in commands, but it's not convenient 558 -- to error here so we just do what's convenient. 559 -- The type checker will complain later 560 561--------------------------------------------------- 562methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars 563methodNamesMatch (MG { mg_alts = L _ ms }) 564 = plusFVs (map do_one ms) 565 where 566 do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss 567 do_one (L _ (XMatch nec)) = noExtCon nec 568methodNamesMatch (XMatchGroup nec) = noExtCon nec 569 570------------------------------------------------- 571-- gaw 2004 572methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars 573methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) 574methodNamesGRHSs (XGRHSs nec) = noExtCon nec 575 576------------------------------------------------- 577 578methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds 579methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs 580methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec 581 582--------------------------------------------------- 583methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars 584methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) 585 586--------------------------------------------------- 587methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars 588methodNamesLStmt = methodNamesStmt . unLoc 589 590methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars 591methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd 592methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd 593methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd 594methodNamesStmt (RecStmt { recS_stmts = stmts }) = 595 methodNamesStmts stmts `addOneFV` loopAName 596methodNamesStmt (LetStmt {}) = emptyFVs 597methodNamesStmt (ParStmt {}) = emptyFVs 598methodNamesStmt (TransStmt {}) = emptyFVs 599methodNamesStmt ApplicativeStmt{} = emptyFVs 600 -- ParStmt and TransStmt can't occur in commands, but it's not 601 -- convenient to error here so we just do what's convenient 602methodNamesStmt (XStmtLR nec) = noExtCon nec 603 604{- 605************************************************************************ 606* * 607 Arithmetic sequences 608* * 609************************************************************************ 610-} 611 612rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) 613rnArithSeq (From expr) 614 = do { (expr', fvExpr) <- rnLExpr expr 615 ; return (From expr', fvExpr) } 616 617rnArithSeq (FromThen expr1 expr2) 618 = do { (expr1', fvExpr1) <- rnLExpr expr1 619 ; (expr2', fvExpr2) <- rnLExpr expr2 620 ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } 621 622rnArithSeq (FromTo expr1 expr2) 623 = do { (expr1', fvExpr1) <- rnLExpr expr1 624 ; (expr2', fvExpr2) <- rnLExpr expr2 625 ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } 626 627rnArithSeq (FromThenTo expr1 expr2 expr3) 628 = do { (expr1', fvExpr1) <- rnLExpr expr1 629 ; (expr2', fvExpr2) <- rnLExpr expr2 630 ; (expr3', fvExpr3) <- rnLExpr expr3 631 ; return (FromThenTo expr1' expr2' expr3', 632 plusFVs [fvExpr1, fvExpr2, fvExpr3]) } 633 634{- 635************************************************************************ 636* * 637\subsubsection{@Stmt@s: in @do@ expressions} 638* * 639************************************************************************ 640-} 641 642{- 643Note [Deterministic ApplicativeDo and RecursiveDo desugaring] 644~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 645Both ApplicativeDo and RecursiveDo need to create tuples not 646present in the source text. 647 648For ApplicativeDo we create: 649 650 (a,b,c) <- (\c b a -> (a,b,c)) <$> 651 652For RecursiveDo we create: 653 654 mfix (\ ~(a,b,c) -> do ...; return (a',b',c')) 655 656The order of the components in those tuples needs to be stable 657across recompilations, otherwise they can get optimized differently 658and we end up with incompatible binaries. 659To get a stable order we use nameSetElemsStable. 660See Note [Deterministic UniqFM] to learn more about nondeterminism. 661-} 662 663-- | Rename some Stmts 664rnStmts :: Outputable (body GhcPs) 665 => HsStmtContext Name 666 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) 667 -- ^ How to rename the body of each statement (e.g. rnLExpr) 668 -> [LStmt GhcPs (Located (body GhcPs))] 669 -- ^ Statements 670 -> ([Name] -> RnM (thing, FreeVars)) 671 -- ^ if these statements scope over something, this renames it 672 -- and returns the result. 673 -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) 674rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts 675 676-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts 677rnStmtsWithPostProcessing 678 :: Outputable (body GhcPs) 679 => HsStmtContext Name 680 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) 681 -- ^ How to rename the body of each statement (e.g. rnLExpr) 682 -> (HsStmtContext Name 683 -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] 684 -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) 685 -- ^ postprocess the statements 686 -> [LStmt GhcPs (Located (body GhcPs))] 687 -- ^ Statements 688 -> ([Name] -> RnM (thing, FreeVars)) 689 -- ^ if these statements scope over something, this renames it 690 -- and returns the result. 691 -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) 692rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside 693 = do { ((stmts', thing), fvs) <- 694 rnStmtsWithFreeVars ctxt rnBody stmts thing_inside 695 ; (pp_stmts, fvs') <- ppStmts ctxt stmts' 696 ; return ((pp_stmts, thing), fvs `plusFV` fvs') 697 } 698 699-- | maybe rearrange statements according to the ApplicativeDo transformation 700postProcessStmtsForApplicativeDo 701 :: HsStmtContext Name 702 -> [(ExprLStmt GhcRn, FreeVars)] 703 -> RnM ([ExprLStmt GhcRn], FreeVars) 704postProcessStmtsForApplicativeDo ctxt stmts 705 = do { 706 -- rearrange the statements using ApplicativeStmt if 707 -- -XApplicativeDo is on. Also strip out the FreeVars attached 708 -- to each Stmt body. 709 ado_is_on <- xoptM LangExt.ApplicativeDo 710 ; let is_do_expr | DoExpr <- ctxt = True 711 | otherwise = False 712 -- don't apply the transformation inside TH brackets, because 713 -- DsMeta does not handle ApplicativeDo. 714 ; in_th_bracket <- isBrackStage <$> getStage 715 ; if ado_is_on && is_do_expr && not in_th_bracket 716 then do { traceRn "ppsfa" (ppr stmts) 717 ; rearrangeForApplicativeDo ctxt stmts } 718 else noPostProcessStmts ctxt stmts } 719 720-- | strip the FreeVars annotations from statements 721noPostProcessStmts 722 :: HsStmtContext Name 723 -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] 724 -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) 725noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) 726 727 728rnStmtsWithFreeVars :: Outputable (body GhcPs) 729 => HsStmtContext Name 730 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) 731 -> [LStmt GhcPs (Located (body GhcPs))] 732 -> ([Name] -> RnM (thing, FreeVars)) 733 -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) 734 , FreeVars) 735-- Each Stmt body is annotated with its FreeVars, so that 736-- we can rearrange statements for ApplicativeDo. 737-- 738-- Variables bound by the Stmts, and mentioned in thing_inside, 739-- do not appear in the result FreeVars 740 741rnStmtsWithFreeVars ctxt _ [] thing_inside 742 = do { checkEmptyStmts ctxt 743 ; (thing, fvs) <- thing_inside [] 744 ; return (([], thing), fvs) } 745 746rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo 747 = -- Behave like do { rec { ...all but last... }; last } 748 do { ((stmts1, (stmts2, thing)), fvs) 749 <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> 750 do { last_stmt' <- checkLastStmt MDoExpr last_stmt 751 ; rnStmt MDoExpr rnBody last_stmt' thing_inside } 752 ; return (((stmts1 ++ stmts2), thing), fvs) } 753 where 754 Just (all_but_last, last_stmt) = snocView stmts 755 756rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside 757 | null lstmts 758 = setSrcSpan loc $ 759 do { lstmt' <- checkLastStmt ctxt lstmt 760 ; rnStmt ctxt rnBody lstmt' thing_inside } 761 762 | otherwise 763 = do { ((stmts1, (stmts2, thing)), fvs) 764 <- setSrcSpan loc $ 765 do { checkStmt ctxt lstmt 766 ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> 767 rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> 768 thing_inside (bndrs1 ++ bndrs2) } 769 ; return (((stmts1 ++ stmts2), thing), fvs) } 770 771---------------------- 772 773{- 774Note [Failing pattern matches in Stmts] 775~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 776 777Many things desugar to HsStmts including monadic things like `do` and `mdo` 778statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an 779exhaustive list). How we deal with pattern match failure is context-dependent. 780 781 * In the case of list comprehensions and pattern guards we don't need any 'fail' 782 function; the desugarer ignores the fail function field of 'BindStmt' entirely. 783 * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo 784 expressions) we want pattern match failure to be desugared to the appropriate 785 'fail' function (either that of Monad or MonadFail, depending on whether 786 -XMonadFailDesugaring is enabled.) 787 788At one point we failed to make this distinction, leading to #11216. 789-} 790 791rnStmt :: Outputable (body GhcPs) 792 => HsStmtContext Name 793 -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) 794 -- ^ How to rename the body of the statement 795 -> LStmt GhcPs (Located (body GhcPs)) 796 -- ^ The statement 797 -> ([Name] -> RnM (thing, FreeVars)) 798 -- ^ Rename the stuff that this statement scopes over 799 -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) 800 , FreeVars) 801-- Variables bound by the Stmt, and mentioned in thing_inside, 802-- do not appear in the result FreeVars 803 804rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside 805 = do { (body', fv_expr) <- rnBody body 806 ; (ret_op, fvs1) <- if isMonadCompContext ctxt 807 then lookupStmtName ctxt returnMName 808 else return (noSyntaxExpr, emptyFVs) 809 -- The 'return' in a LastStmt is used only 810 -- for MonadComp; and we don't want to report 811 -- "non in scope: return" in other cases 812 -- #15607 813 814 ; (thing, fvs3) <- thing_inside [] 815 ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] 816 , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } 817 818rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside 819 = do { (body', fv_expr) <- rnBody body 820 ; (then_op, fvs1) <- lookupStmtName ctxt thenMName 821 822 ; (guard_op, fvs2) <- if isComprehensionContext ctxt 823 then lookupStmtName ctxt guardMName 824 else return (noSyntaxExpr, emptyFVs) 825 -- Only list/monad comprehensions use 'guard' 826 -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] 827 -- Here "gd" is a guard 828 829 ; (thing, fvs3) <- thing_inside [] 830 ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] 831 , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } 832 833rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside 834 = do { (body', fv_expr) <- rnBody body 835 -- The binders do not scope over the expression 836 ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName 837 838 ; (fail_op, fvs2) <- monadFailOp pat ctxt 839 840 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do 841 { (thing, fvs3) <- thing_inside (collectPatBinders pat') 842 ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op) 843 , fv_expr )] 844 , thing), 845 fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} 846 -- fv_expr shouldn't really be filtered by the rnPatsAndThen 847 -- but it does not matter because the names are unique 848 849rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside 850 = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do 851 { (thing, fvs) <- thing_inside (collectLocalBinders binds') 852 ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) 853 , fvs) } } 854 855rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside 856 = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName 857 ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName 858 ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName 859 ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op 860 , recS_mfix_fn = mfix_op 861 , recS_bind_fn = bind_op } 862 863 -- Step1: Bring all the binders of the mdo into scope 864 -- (Remember that this also removes the binders from the 865 -- finally-returned free-vars.) 866 -- And rename each individual stmt, making a 867 -- singleton segment. At this stage the FwdRefs field 868 -- isn't finished: it's empty for all except a BindStmt 869 -- for which it's the fwd refs within the bind itself 870 -- (This set may not be empty, because we're in a recursive 871 -- context.) 872 ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do 873 { let bndrs = nameSetElemsStable $ 874 foldr (unionNameSet . (\(ds,_,_,_) -> ds)) 875 emptyNameSet 876 segs 877 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] 878 ; (thing, fvs_later) <- thing_inside bndrs 879 ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later 880 -- We aren't going to try to group RecStmts with 881 -- ApplicativeDo, so attaching empty FVs is fine. 882 ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) 883 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } 884 885rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside 886 = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName 887 ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName 888 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName 889 ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside 890 ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing) 891 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } 892 893rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form 894 , trS_using = using })) thing_inside 895 = do { -- Rename the 'using' expression in the context before the transform is begun 896 (using', fvs1) <- rnLExpr using 897 898 -- Rename the stmts and the 'by' expression 899 -- Keep track of the variables mentioned in the 'by' expression 900 ; ((stmts', (by', used_bndrs, thing)), fvs2) 901 <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> 902 do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by 903 ; (thing, fvs_thing) <- thing_inside bndrs 904 ; let fvs = fvs_by `plusFV` fvs_thing 905 used_bndrs = filter (`elemNameSet` fvs) bndrs 906 -- The paper (Fig 5) has a bug here; we must treat any free variable 907 -- of the "thing inside", **or of the by-expression**, as used 908 ; return ((by', used_bndrs, thing), fvs) } 909 910 -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions 911 ; (return_op, fvs3) <- lookupStmtName ctxt returnMName 912 ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName 913 ; (fmap_op, fvs5) <- case form of 914 ThenForm -> return (noExpr, emptyFVs) 915 _ -> lookupStmtNamePoly ctxt fmapName 916 917 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 918 `plusFV` fvs4 `plusFV` fvs5 919 bndr_map = used_bndrs `zip` used_bndrs 920 -- See Note [TransStmt binder map] in GHC.Hs.Expr 921 922 ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) 923 ; return (([(L loc (TransStmt { trS_ext = noExtField 924 , trS_stmts = stmts', trS_bndrs = bndr_map 925 , trS_by = by', trS_using = using', trS_form = form 926 , trS_ret = return_op, trS_bind = bind_op 927 , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } 928 929rnStmt _ _ (L _ ApplicativeStmt{}) _ = 930 panic "rnStmt: ApplicativeStmt" 931 932rnStmt _ _ (L _ (XStmtLR nec)) _ = 933 noExtCon nec 934 935rnParallelStmts :: forall thing. HsStmtContext Name 936 -> SyntaxExpr GhcRn 937 -> [ParStmtBlock GhcPs GhcPs] 938 -> ([Name] -> RnM (thing, FreeVars)) 939 -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) 940-- Note [Renaming parallel Stmts] 941rnParallelStmts ctxt return_op segs thing_inside 942 = do { orig_lcl_env <- getLocalRdrEnv 943 ; rn_segs orig_lcl_env [] segs } 944 where 945 rn_segs :: LocalRdrEnv 946 -> [Name] -> [ParStmtBlock GhcPs GhcPs] 947 -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) 948 rn_segs _ bndrs_so_far [] 949 = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far 950 ; mapM_ dupErr dups 951 ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') 952 ; return (([], thing), fvs) } 953 954 rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) 955 = do { ((stmts', (used_bndrs, segs', thing)), fvs) 956 <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> 957 setLocalRdrEnv env $ do 958 { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs 959 ; let used_bndrs = filter (`elemNameSet` fvs) bndrs 960 ; return ((used_bndrs, segs', thing), fvs) } 961 962 ; let seg' = ParStmtBlock x stmts' used_bndrs return_op 963 ; return ((seg':segs', thing), fvs) } 964 rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec 965 966 cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 967 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" 968 <+> quotes (ppr (NE.head vs))) 969 970lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) 971-- Like lookupSyntaxName, but respects contexts 972lookupStmtName ctxt n 973 | rebindableContext ctxt 974 = lookupSyntaxName n 975 | otherwise 976 = return (mkRnSyntaxExpr n, emptyFVs) 977 978lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) 979lookupStmtNamePoly ctxt name 980 | rebindableContext ctxt 981 = do { rebindable_on <- xoptM LangExt.RebindableSyntax 982 ; if rebindable_on 983 then do { fm <- lookupOccRn (nameRdrName name) 984 ; return (HsVar noExtField (noLoc fm), unitFV fm) } 985 else not_rebindable } 986 | otherwise 987 = not_rebindable 988 where 989 not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) 990 991-- | Is this a context where we respect RebindableSyntax? 992-- but ListComp are never rebindable 993-- Neither is ArrowExpr, which has its own desugarer in DsArrows 994rebindableContext :: HsStmtContext Name -> Bool 995rebindableContext ctxt = case ctxt of 996 ListComp -> False 997 ArrowExpr -> False 998 PatGuard {} -> False 999 1000 DoExpr -> True 1001 MDoExpr -> True 1002 MonadComp -> True 1003 GhciStmtCtxt -> True -- I suppose? 1004 1005 ParStmtCtxt c -> rebindableContext c -- Look inside to 1006 TransStmtCtxt c -> rebindableContext c -- the parent context 1007 1008{- 1009Note [Renaming parallel Stmts] 1010~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1011Renaming parallel statements is painful. Given, say 1012 [ a+c | a <- as, bs <- bss 1013 | c <- bs, a <- ds ] 1014Note that 1015 (a) In order to report "Defined but not used" about 'bs', we must 1016 rename each group of Stmts with a thing_inside whose FreeVars 1017 include at least {a,c} 1018 1019 (b) We want to report that 'a' is illegally bound in both branches 1020 1021 (c) The 'bs' in the second group must obviously not be captured by 1022 the binding in the first group 1023 1024To satisfy (a) we nest the segements. 1025To satisfy (b) we check for duplicates just before thing_inside. 1026To satisfy (c) we reset the LocalRdrEnv each time. 1027 1028************************************************************************ 1029* * 1030\subsubsection{mdo expressions} 1031* * 1032************************************************************************ 1033-} 1034 1035type FwdRefs = NameSet 1036type Segment stmts = (Defs, 1037 Uses, -- May include defs 1038 FwdRefs, -- A subset of uses that are 1039 -- (a) used before they are bound in this segment, or 1040 -- (b) used here, and bound in subsequent segments 1041 stmts) -- Either Stmt or [Stmt] 1042 1043 1044-- wrapper that does both the left- and right-hand sides 1045rnRecStmtsAndThen :: Outputable (body GhcPs) => 1046 (Located (body GhcPs) 1047 -> RnM (Located (body GhcRn), FreeVars)) 1048 -> [LStmt GhcPs (Located (body GhcPs))] 1049 -- assumes that the FreeVars returned includes 1050 -- the FreeVars of the Segments 1051 -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] 1052 -> RnM (a, FreeVars)) 1053 -> RnM (a, FreeVars) 1054rnRecStmtsAndThen rnBody s cont 1055 = do { -- (A) Make the mini fixity env for all of the stmts 1056 fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) 1057 1058 -- (B) Do the LHSes 1059 ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s 1060 1061 -- ...bring them and their fixities into scope 1062 ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) 1063 -- Fake uses of variables introduced implicitly (warning suppression, see #4404) 1064 rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) 1065 implicit_uses = mkNameSet $ concatMap snd $ rec_uses 1066 ; bindLocalNamesFV bound_names $ 1067 addLocalFixities fix_env bound_names $ do 1068 1069 -- (C) do the right-hand-sides and thing-inside 1070 { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv 1071 ; (res, fvs) <- cont segs 1072 ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns)) 1073 rec_uses 1074 ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) 1075 ; return (res, fvs) }} 1076 1077-- get all the fixity decls in any Let stmt 1078collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] 1079collectRecStmtsFixities l = 1080 foldr (\ s -> \acc -> case s of 1081 (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> 1082 foldr (\ sig -> \ acc -> case sig of 1083 (L loc (FixSig _ s)) -> (L loc s) : acc 1084 _ -> acc) acc sigs 1085 _ -> acc) [] l 1086 1087-- left-hand sides 1088 1089rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv 1090 -> LStmt GhcPs body 1091 -- rename LHS, and return its FVs 1092 -- Warning: we will only need the FreeVars below in the case of a BindStmt, 1093 -- so we don't bother to compute it accurately in the other cases 1094 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] 1095 1096rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) 1097 = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] 1098 1099rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) 1100 = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] 1101 1102rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b)) 1103 = do 1104 -- should the ctxt be MDo instead? 1105 (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat 1106 return [(L loc (BindStmt noExtField pat' body a b), fv_pat)] 1107 1108rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) 1109 = failWith (badIpBinds (text "an mdo expression") binds) 1110 1111rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) 1112 = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds 1113 return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), 1114 -- Warning: this is bogus; see function invariant 1115 emptyFVs 1116 )] 1117 1118-- XXX Do we need to do something with the return and mfix names? 1119rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec 1120 = rn_rec_stmts_lhs fix_env stmts 1121 1122rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo 1123 = pprPanic "rn_rec_stmt" (ppr stmt) 1124 1125rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo 1126 = pprPanic "rn_rec_stmt" (ppr stmt) 1127 1128rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet 1129 = pprPanic "rn_rec_stmt" (ppr stmt) 1130 1131rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) 1132 = panic "rn_rec_stmt LetStmt EmptyLocalBinds" 1133rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec)))) 1134 = noExtCon nec 1135rn_rec_stmt_lhs _ (L _ (XStmtLR nec)) 1136 = noExtCon nec 1137 1138rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv 1139 -> [LStmt GhcPs body] 1140 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] 1141rn_rec_stmts_lhs fix_env stmts 1142 = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts 1143 ; let boundNames = collectLStmtsBinders (map fst ls) 1144 -- First do error checking: we need to check for dups here because we 1145 -- don't bind all of the variables from the Stmt at once 1146 -- with bindLocatedLocals. 1147 ; checkDupNames boundNames 1148 ; return ls } 1149 1150 1151-- right-hand-sides 1152 1153rn_rec_stmt :: (Outputable (body GhcPs)) => 1154 (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) 1155 -> [Name] 1156 -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) 1157 -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] 1158 -- Rename a Stmt that is inside a RecStmt (or mdo) 1159 -- Assumes all binders are already in scope 1160 -- Turns each stmt into a singleton Stmt 1161rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _) 1162 = do { (body', fv_expr) <- rnBody body 1163 ; (ret_op, fvs1) <- lookupSyntaxName returnMName 1164 ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, 1165 L loc (LastStmt noExtField body' noret ret_op))] } 1166 1167rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _) 1168 = do { (body', fvs) <- rnBody body 1169 ; (then_op, fvs1) <- lookupSyntaxName thenMName 1170 ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, 1171 L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } 1172 1173rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) 1174 = do { (body', fv_expr) <- rnBody body 1175 ; (bind_op, fvs1) <- lookupSyntaxName bindMName 1176 1177 ; (fail_op, fvs2) <- getMonadFailOp 1178 1179 ; let bndrs = mkNameSet (collectPatBinders pat') 1180 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 1181 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, 1182 L loc (BindStmt noExtField pat' body' bind_op fail_op))] } 1183 1184rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) 1185 = failWith (badIpBinds (text "an mdo expression") binds) 1186 1187rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) 1188 = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' 1189 -- fixities and unused are handled above in rnRecStmtsAndThen 1190 ; let fvs = allUses du_binds 1191 ; return [(duDefs du_binds, fvs, emptyNameSet, 1192 L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } 1193 1194-- no RecStmt case because they get flattened above when doing the LHSes 1195rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) 1196 = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) 1197 1198rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo 1199 = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) 1200 1201rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo 1202 = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) 1203 1204rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _) 1205 = noExtCon nec 1206 1207rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) 1208 = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" 1209 1210rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) 1211 = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) 1212 1213rn_rec_stmt _ _ (L _ (XStmtLR nec), _) 1214 = noExtCon nec 1215 1216rn_rec_stmts :: Outputable (body GhcPs) => 1217 (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) 1218 -> [Name] 1219 -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] 1220 -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] 1221rn_rec_stmts rnBody bndrs stmts 1222 = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts 1223 ; return (concat segs_s) } 1224 1225--------------------------------------------- 1226segmentRecStmts :: SrcSpan -> HsStmtContext Name 1227 -> Stmt GhcRn body 1228 -> [Segment (LStmt GhcRn body)] -> FreeVars 1229 -> ([LStmt GhcRn body], FreeVars) 1230 1231segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later 1232 | null segs 1233 = ([], fvs_later) 1234 1235 | MDoExpr <- ctxt 1236 = segsToStmts empty_rec_stmt grouped_segs fvs_later 1237 -- Step 4: Turn the segments into Stmts 1238 -- Use RecStmt when and only when there are fwd refs 1239 -- Also gather up the uses from the end towards the 1240 -- start, so we can tell the RecStmt which things are 1241 -- used 'after' the RecStmt 1242 1243 | otherwise 1244 = ([ L loc $ 1245 empty_rec_stmt { recS_stmts = ss 1246 , recS_later_ids = nameSetElemsStable 1247 (defs `intersectNameSet` fvs_later) 1248 , recS_rec_ids = nameSetElemsStable 1249 (defs `intersectNameSet` uses) }] 1250 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] 1251 , uses `plusFV` fvs_later) 1252 1253 where 1254 (defs_s, uses_s, _, ss) = unzip4 segs 1255 defs = plusFVs defs_s 1256 uses = plusFVs uses_s 1257 1258 -- Step 2: Fill in the fwd refs. 1259 -- The segments are all singletons, but their fwd-ref 1260 -- field mentions all the things used by the segment 1261 -- that are bound after their use 1262 segs_w_fwd_refs = addFwdRefs segs 1263 1264 -- Step 3: Group together the segments to make bigger segments 1265 -- Invariant: in the result, no segment uses a variable 1266 -- bound in a later segment 1267 grouped_segs = glomSegments ctxt segs_w_fwd_refs 1268 1269---------------------------- 1270addFwdRefs :: [Segment a] -> [Segment a] 1271-- So far the segments only have forward refs *within* the Stmt 1272-- (which happens for bind: x <- ...x...) 1273-- This function adds the cross-seg fwd ref info 1274 1275addFwdRefs segs 1276 = fst (foldr mk_seg ([], emptyNameSet) segs) 1277 where 1278 mk_seg (defs, uses, fwds, stmts) (segs, later_defs) 1279 = (new_seg : segs, all_defs) 1280 where 1281 new_seg = (defs, uses, new_fwds, stmts) 1282 all_defs = later_defs `unionNameSet` defs 1283 new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) 1284 -- Add the downstream fwd refs here 1285 1286{- 1287Note [Segmenting mdo] 1288~~~~~~~~~~~~~~~~~~~~~ 1289NB. June 7 2012: We only glom segments that appear in an explicit mdo; 1290and leave those found in "do rec"'s intact. See 1291https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion 1292leading to this design choice. Hence the test in segmentRecStmts. 1293 1294Note [Glomming segments] 1295~~~~~~~~~~~~~~~~~~~~~~~~ 1296Glomming the singleton segments of an mdo into minimal recursive groups. 1297 1298At first I thought this was just strongly connected components, but 1299there's an important constraint: the order of the stmts must not change. 1300 1301Consider 1302 mdo { x <- ...y... 1303 p <- z 1304 y <- ...x... 1305 q <- x 1306 z <- y 1307 r <- x } 1308 1309Here, the first stmt mention 'y', which is bound in the third. 1310But that means that the innocent second stmt (p <- z) gets caught 1311up in the recursion. And that in turn means that the binding for 1312'z' has to be included... and so on. 1313 1314Start at the tail { r <- x } 1315Now add the next one { z <- y ; r <- x } 1316Now add one more { q <- x ; z <- y ; r <- x } 1317Now one more... but this time we have to group a bunch into rec 1318 { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } 1319Now one more, which we can add on without a rec 1320 { p <- z ; 1321 rec { y <- ...x... ; q <- x ; z <- y } ; 1322 r <- x } 1323Finally we add the last one; since it mentions y we have to 1324glom it together with the first two groups 1325 { rec { x <- ...y...; p <- z ; y <- ...x... ; 1326 q <- x ; z <- y } ; 1327 r <- x } 1328-} 1329 1330glomSegments :: HsStmtContext Name 1331 -> [Segment (LStmt GhcRn body)] 1332 -> [Segment [LStmt GhcRn body]] 1333 -- Each segment has a non-empty list of Stmts 1334-- See Note [Glomming segments] 1335 1336glomSegments _ [] = [] 1337glomSegments ctxt ((defs,uses,fwds,stmt) : segs) 1338 -- Actually stmts will always be a singleton 1339 = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others 1340 where 1341 segs' = glomSegments ctxt segs 1342 (extras, others) = grab uses segs' 1343 (ds, us, fs, ss) = unzip4 extras 1344 1345 seg_defs = plusFVs ds `plusFV` defs 1346 seg_uses = plusFVs us `plusFV` uses 1347 seg_fwds = plusFVs fs `plusFV` fwds 1348 seg_stmts = stmt : concat ss 1349 1350 grab :: NameSet -- The client 1351 -> [Segment a] 1352 -> ([Segment a], -- Needed by the 'client' 1353 [Segment a]) -- Not needed by the client 1354 -- The result is simply a split of the input 1355 grab uses dus 1356 = (reverse yeses, reverse noes) 1357 where 1358 (noes, yeses) = span not_needed (reverse dus) 1359 not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) 1360 1361---------------------------------------------------- 1362segsToStmts :: Stmt GhcRn body 1363 -- A RecStmt with the SyntaxOps filled in 1364 -> [Segment [LStmt GhcRn body]] 1365 -- Each Segment has a non-empty list of Stmts 1366 -> FreeVars -- Free vars used 'later' 1367 -> ([LStmt GhcRn body], FreeVars) 1368 1369segsToStmts _ [] fvs_later = ([], fvs_later) 1370segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later 1371 = ASSERT( not (null ss) ) 1372 (new_stmt : later_stmts, later_uses `plusFV` uses) 1373 where 1374 (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later 1375 new_stmt | non_rec = head ss 1376 | otherwise = cL (getLoc (head ss)) rec_stmt 1377 rec_stmt = empty_rec_stmt { recS_stmts = ss 1378 , recS_later_ids = nameSetElemsStable used_later 1379 , recS_rec_ids = nameSetElemsStable fwds } 1380 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] 1381 non_rec = isSingleton ss && isEmptyNameSet fwds 1382 used_later = defs `intersectNameSet` later_uses 1383 -- The ones needed after the RecStmt 1384 1385{- 1386************************************************************************ 1387* * 1388ApplicativeDo 1389* * 1390************************************************************************ 1391 1392Note [ApplicativeDo] 1393 1394= Example = 1395 1396For a sequence of statements 1397 1398 do 1399 x <- A 1400 y <- B x 1401 z <- C 1402 return (f x y z) 1403 1404We want to transform this to 1405 1406 (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C 1407 1408It would be easy to notice that "y <- B x" and "z <- C" are 1409independent and do something like this: 1410 1411 do 1412 x <- A 1413 (y,z) <- (,) <$> B x <*> C 1414 return (f x y z) 1415 1416But this isn't enough! A and C were also independent, and this 1417transformation loses the ability to do A and C in parallel. 1418 1419The algorithm works by first splitting the sequence of statements into 1420independent "segments", and a separate "tail" (the final statement). In 1421our example above, the segements would be 1422 1423 [ x <- A 1424 , y <- B x ] 1425 1426 [ z <- C ] 1427 1428and the tail is: 1429 1430 return (f x y z) 1431 1432Then we take these segments and make an Applicative expression from them: 1433 1434 (\(x,y) z -> return (f x y z)) 1435 <$> do { x <- A; y <- B x; return (x,y) } 1436 <*> C 1437 1438Finally, we recursively apply the transformation to each segment, to 1439discover any nested parallelism. 1440 1441= Syntax & spec = 1442 1443 expr ::= ... | do {stmt_1; ..; stmt_n} expr | ... 1444 1445 stmt ::= pat <- expr 1446 | (arg_1 | ... | arg_n) -- applicative composition, n>=1 1447 | ... -- other kinds of statement (e.g. let) 1448 1449 arg ::= pat <- expr 1450 | {stmt_1; ..; stmt_n} {var_1..var_n} 1451 1452(note that in the actual implementation,the expr in a do statement is 1453represented by a LastStmt as the final stmt, this is just a 1454representational issue and may change later.) 1455 1456== Transformation to introduce applicative stmts == 1457 1458ado {} tail = tail 1459ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr' 1460ado {one} tail = one : tail 1461ado stmts tail 1462 | n == 1 = ado before (ado after tail) 1463 where (before,after) = split(stmts_1) 1464 | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail 1465 where 1466 {stmts_1 .. stmts_n} = segments(stmts) 1467 1468segments(stmts) = 1469 -- divide stmts into segments with no interdependencies 1470 1471mkArg({pat <- expr}) = (pat <- expr) 1472mkArg({stmt_1; ...; stmt_n}) = 1473 {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)} 1474 1475split({stmt_1; ..; stmt_n) = 1476 ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n}) 1477 -- 1 <= i <= n 1478 -- i is a good place to insert a bind 1479 1480== Desugaring for do == 1481 1482dsDo {} expr = expr 1483 1484dsDo {pat <- rhs; stmts} expr = 1485 rhs >>= \pat -> dsDo stmts expr 1486 1487dsDo {(arg_1 | ... | arg_n)} (return expr) = 1488 (\argpat (arg_1) .. argpat(arg_n) -> expr) 1489 <$> argexpr(arg_1) 1490 <*> ... 1491 <*> argexpr(arg_n) 1492 1493dsDo {(arg_1 | ... | arg_n); stmts} expr = 1494 join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr) 1495 <$> argexpr(arg_1) 1496 <*> ... 1497 <*> argexpr(arg_n) 1498 1499= Relevant modules in the rest of the compiler = 1500 1501ApplicativeDo touches a few phases in the compiler: 1502 1503* Renamer: The journey begins here in the renamer, where do-blocks are 1504 scheduled as outlined above and transformed into applicative 1505 combinators. However, the code is still represented as a do-block 1506 with special forms of applicative statements. This allows us to 1507 recover the original do-block when e.g. printing type errors, where 1508 we don't want to show any of the applicative combinators since they 1509 don't exist in the source code. 1510 See ApplicativeStmt and ApplicativeArg in HsExpr. 1511 1512* Typechecker: ApplicativeDo passes through the typechecker much like any 1513 other form of expression. The only crux is that the typechecker has to 1514 be aware of the special ApplicativeDo statements in the do-notation, and 1515 typecheck them appropriately. 1516 Relevant module: TcMatches 1517 1518* Desugarer: Any do-block which contains applicative statements is desugared 1519 as outlined above, to use the Applicative combinators. 1520 Relevant module: DsExpr 1521 1522-} 1523 1524-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and 1525-- 'pureName' due to @RebindableSyntax@. 1526data MonadNames = MonadNames { return_name, pure_name :: Name } 1527 1528instance Outputable MonadNames where 1529 ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = 1530 hcat 1531 [text "MonadNames { return_name = " 1532 ,ppr return_name 1533 ,text ", pure_name = " 1534 ,ppr pure_name 1535 ,text "}" 1536 ] 1537 1538-- | rearrange a list of statements using ApplicativeDoStmt. See 1539-- Note [ApplicativeDo]. 1540rearrangeForApplicativeDo 1541 :: HsStmtContext Name 1542 -> [(ExprLStmt GhcRn, FreeVars)] 1543 -> RnM ([ExprLStmt GhcRn], FreeVars) 1544 1545rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) 1546rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) 1547rearrangeForApplicativeDo ctxt stmts0 = do 1548 optimal_ado <- goptM Opt_OptimalApplicativeDo 1549 let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts 1550 | otherwise = mkStmtTreeHeuristic stmts 1551 traceRn "rearrangeForADo" (ppr stmt_tree) 1552 return_name <- lookupSyntaxName' returnMName 1553 pure_name <- lookupSyntaxName' pureAName 1554 let monad_names = MonadNames { return_name = return_name 1555 , pure_name = pure_name } 1556 stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs 1557 where 1558 (stmts,(last,last_fvs)) = findLast stmts0 1559 findLast [] = error "findLast" 1560 findLast [last] = ([],last) 1561 findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs 1562 1563-- | A tree of statements using a mixture of applicative and bind constructs. 1564data StmtTree a 1565 = StmtTreeOne a 1566 | StmtTreeBind (StmtTree a) (StmtTree a) 1567 | StmtTreeApplicative [StmtTree a] 1568 1569instance Outputable a => Outputable (StmtTree a) where 1570 ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x) 1571 ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind") 1572 2 (sep [ppr x, ppr y])) 1573 ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative") 1574 2 (vcat (map ppr xs))) 1575 1576flattenStmtTree :: StmtTree a -> [a] 1577flattenStmtTree t = go t [] 1578 where 1579 go (StmtTreeOne a) as = a : as 1580 go (StmtTreeBind l r) as = go l (go r as) 1581 go (StmtTreeApplicative ts) as = foldr go as ts 1582 1583type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) 1584type Cost = Int 1585 1586-- | Turn a sequence of statements into an ExprStmtTree using a 1587-- heuristic algorithm. /O(n^2)/ 1588mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree 1589mkStmtTreeHeuristic [one] = StmtTreeOne one 1590mkStmtTreeHeuristic stmts = 1591 case segments stmts of 1592 [one] -> split one 1593 segs -> StmtTreeApplicative (map split segs) 1594 where 1595 split [one] = StmtTreeOne one 1596 split stmts = 1597 StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after) 1598 where (before, after) = splitSegment stmts 1599 1600-- | Turn a sequence of statements into an ExprStmtTree optimally, 1601-- using dynamic programming. /O(n^3)/ 1602mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree 1603mkStmtTreeOptimal stmts = 1604 ASSERT(not (null stmts)) -- the empty case is handled by the caller; 1605 -- we don't support empty StmtTrees. 1606 fst (arr ! (0,n)) 1607 where 1608 n = length stmts - 1 1609 stmt_arr = listArray (0,n) stmts 1610 1611 -- lazy cache of optimal trees for subsequences of the input 1612 arr :: Array (Int,Int) (ExprStmtTree, Cost) 1613 arr = array ((0,0),(n,n)) 1614 [ ((lo,hi), tree lo hi) 1615 | lo <- [0..n] 1616 , hi <- [lo..n] ] 1617 1618 -- compute the optimal tree for the sequence [lo..hi] 1619 tree lo hi 1620 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) 1621 | otherwise = 1622 case segments [ stmt_arr ! i | i <- [lo..hi] ] of 1623 [] -> panic "mkStmtTree" 1624 [_one] -> split lo hi 1625 segs -> (StmtTreeApplicative trees, maximum costs) 1626 where 1627 bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs 1628 (trees,costs) = unzip (map (uncurry split) (tail bounds)) 1629 1630 -- find the best place to split the segment [lo..hi] 1631 split :: Int -> Int -> (ExprStmtTree, Cost) 1632 split lo hi 1633 | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) 1634 | otherwise = (StmtTreeBind before after, c1+c2) 1635 where 1636 -- As per the paper, for a sequence s1...sn, we want to find 1637 -- the split with the minimum cost, where the cost is the 1638 -- sum of the cost of the left and right subsequences. 1639 -- 1640 -- As an optimisation (also in the paper) if the cost of 1641 -- s1..s(n-1) is different from the cost of s2..sn, we know 1642 -- that the optimal solution is the lower of the two. Only 1643 -- in the case that these two have the same cost do we need 1644 -- to do the exhaustive search. 1645 -- 1646 ((before,c1),(after,c2)) 1647 | hi - lo == 1 1648 = ((StmtTreeOne (stmt_arr ! lo), 1), 1649 (StmtTreeOne (stmt_arr ! hi), 1)) 1650 | left_cost < right_cost 1651 = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) 1652 | left_cost > right_cost 1653 = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) 1654 | otherwise = minimumBy (comparing cost) alternatives 1655 where 1656 (left, left_cost) = arr ! (lo,hi-1) 1657 (right, right_cost) = arr ! (lo+1,hi) 1658 cost ((_,c1),(_,c2)) = c1 + c2 1659 alternatives = [ (arr ! (lo,k), arr ! (k+1,hi)) 1660 | k <- [lo .. hi-1] ] 1661 1662 1663-- | Turn the ExprStmtTree back into a sequence of statements, using 1664-- ApplicativeStmt where necessary. 1665stmtTreeToStmts 1666 :: MonadNames 1667 -> HsStmtContext Name 1668 -> ExprStmtTree 1669 -> [ExprLStmt GhcRn] -- ^ the "tail" 1670 -> FreeVars -- ^ free variables of the tail 1671 -> RnM ( [ExprLStmt GhcRn] -- ( output statements, 1672 , FreeVars ) -- , things we needed 1673 1674-- If we have a single bind, and we can do it without a join, transform 1675-- to an ApplicativeStmt. This corresponds to the rule 1676-- dsBlock [pat <- rhs] (return expr) = expr <$> rhs 1677-- In the spec, but we do it here rather than in the desugarer, 1678-- because we need the typechecker to typecheck the <$> form rather than 1679-- the bind form, which would give rise to a Monad constraint. 1680stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) 1681 tail _tail_fvs 1682 | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail 1683 -- See Note [ApplicativeDo and strict patterns] 1684 = mkApplicativeStmt ctxt [ApplicativeArgOne 1685 { xarg_app_arg_one = noExtField 1686 , app_arg_pattern = pat 1687 , arg_expr = rhs 1688 , is_body_stmt = False 1689 , fail_operator = fail_op}] 1690 False tail' 1691stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) 1692 tail _tail_fvs 1693 | (False,tail') <- needJoin monad_names tail 1694 = mkApplicativeStmt ctxt 1695 [ApplicativeArgOne 1696 { xarg_app_arg_one = noExtField 1697 , app_arg_pattern = nlWildPatName 1698 , arg_expr = rhs 1699 , is_body_stmt = True 1700 , fail_operator = noSyntaxExpr}] False tail' 1701 1702stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = 1703 return (s : tail, emptyNameSet) 1704 1705stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do 1706 (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs 1707 let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after)) 1708 (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs 1709 return (stmts2, fvs1 `plusFV` fvs2) 1710 1711stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do 1712 pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees 1713 let (stmts', fvss) = unzip pairs 1714 let (need_join, tail') = 1715 -- See Note [ApplicativeDo and refutable patterns] 1716 if any hasRefutablePattern stmts' 1717 then (True, tail) 1718 else needJoin monad_names tail 1719 1720 (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' 1721 return (stmts, unionNameSets (fvs:fvss)) 1722 where 1723 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _)) 1724 = return (ApplicativeArgOne 1725 { xarg_app_arg_one = noExtField 1726 , app_arg_pattern = pat 1727 , arg_expr = exp 1728 , is_body_stmt = False 1729 , fail_operator = fail_op 1730 }, emptyFVs) 1731 stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = 1732 return (ApplicativeArgOne 1733 { xarg_app_arg_one = noExtField 1734 , app_arg_pattern = nlWildPatName 1735 , arg_expr = exp 1736 , is_body_stmt = True 1737 , fail_operator = noSyntaxExpr 1738 }, emptyFVs) 1739 stmtTreeArg ctxt tail_fvs tree = do 1740 let stmts = flattenStmtTree tree 1741 pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) 1742 `intersectNameSet` tail_fvs 1743 pvars = nameSetElemsStable pvarset 1744 -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] 1745 pat = mkBigLHsVarPatTup pvars 1746 tup = mkBigLHsVarTup pvars 1747 (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset 1748 (mb_ret, fvs1) <- 1749 if | L _ ApplicativeStmt{} <- last stmts' -> 1750 return (unLoc tup, emptyNameSet) 1751 | otherwise -> do 1752 ret <- lookupSyntaxName' returnMName 1753 let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup 1754 return (expr, emptyFVs) 1755 return ( ApplicativeArgMany 1756 { xarg_app_arg_many = noExtField 1757 , app_stmts = stmts' 1758 , final_expr = mb_ret 1759 , bv_pattern = pat 1760 } 1761 , fvs1 `plusFV` fvs2) 1762 1763 1764-- | Divide a sequence of statements into segments, where no segment 1765-- depends on any variables defined by a statement in another segment. 1766segments 1767 :: [(ExprLStmt GhcRn, FreeVars)] 1768 -> [[(ExprLStmt GhcRn, FreeVars)]] 1769segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) 1770 where 1771 allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) 1772 1773 -- We would rather not have a segment that just has LetStmts in 1774 -- it, so combine those with an adjacent segment where possible. 1775 merge [] = [] 1776 merge (seg : segs) 1777 = case rest of 1778 [] -> [(seg,all_lets)] 1779 ((s,s_lets):ss) | all_lets || s_lets 1780 -> (seg ++ s, all_lets && s_lets) : ss 1781 _otherwise -> (seg,all_lets) : rest 1782 where 1783 rest = merge segs 1784 all_lets = all (isLetStmt . fst) seg 1785 1786 -- walk splits the statement sequence into segments, traversing 1787 -- the sequence from the back to the front, and keeping track of 1788 -- the set of free variables of the current segment. Whenever 1789 -- this set of free variables is empty, we have a complete segment. 1790 walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] 1791 walk [] = [] 1792 walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest 1793 where (seg,rest) = chunter fvs' stmts 1794 (_, fvs') = stmtRefs stmt fvs 1795 1796 chunter _ [] = ([], []) 1797 chunter vars ((stmt,fvs) : rest) 1798 | not (isEmptyNameSet vars) 1799 || isStrictPatternBind stmt 1800 -- See Note [ApplicativeDo and strict patterns] 1801 = ((stmt,fvs) : chunk, rest') 1802 where (chunk,rest') = chunter vars' rest 1803 (pvars, evars) = stmtRefs stmt fvs 1804 vars' = (vars `minusNameSet` pvars) `unionNameSet` evars 1805 chunter _ rest = ([], rest) 1806 1807 stmtRefs stmt fvs 1808 | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) 1809 | otherwise = (pvars, fvs') 1810 where fvs' = fvs `intersectNameSet` allvars 1811 pvars = mkNameSet (collectStmtBinders (unLoc stmt)) 1812 1813 isStrictPatternBind :: ExprLStmt GhcRn -> Bool 1814 isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat 1815 isStrictPatternBind _ = False 1816 1817{- 1818Note [ApplicativeDo and strict patterns] 1819 1820A strict pattern match is really a dependency. For example, 1821 1822do 1823 (x,y) <- A 1824 z <- B 1825 return C 1826 1827The pattern (_,_) must be matched strictly before we do B. If we 1828allowed this to be transformed into 1829 1830 (\(x,y) -> \z -> C) <$> A <*> B 1831 1832then it could be lazier than the standard desuraging using >>=. See #13875 1833for more examples. 1834 1835Thus, whenever we have a strict pattern match, we treat it as a 1836dependency between that statement and the following one. The 1837dependency prevents those two statements from being performed "in 1838parallel" in an ApplicativeStmt, but doesn't otherwise affect what we 1839can do with the rest of the statements in the same "do" expression. 1840-} 1841 1842isStrictPattern :: LPat (GhcPass p) -> Bool 1843isStrictPattern lpat = 1844 case unLoc lpat of 1845 WildPat{} -> False 1846 VarPat{} -> False 1847 LazyPat{} -> False 1848 AsPat _ _ p -> isStrictPattern p 1849 ParPat _ p -> isStrictPattern p 1850 ViewPat _ _ p -> isStrictPattern p 1851 SigPat _ p _ -> isStrictPattern p 1852 BangPat{} -> True 1853 ListPat{} -> True 1854 TuplePat{} -> True 1855 SumPat{} -> True 1856 ConPatIn{} -> True 1857 ConPatOut{} -> True 1858 LitPat{} -> True 1859 NPat{} -> True 1860 NPlusKPat{} -> True 1861 SplicePat{} -> True 1862 _otherwise -> panic "isStrictPattern" 1863 1864{- 1865Note [ApplicativeDo and refutable patterns] 1866 1867Refutable patterns in do blocks are desugared to use the monadic 'fail' operation. 1868This means that sometimes an applicative block needs to be wrapped in 'join' simply because 1869of a refutable pattern, in order for the types to work out. 1870 1871-} 1872 1873hasRefutablePattern :: ApplicativeArg GhcRn -> Bool 1874hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat 1875 , is_body_stmt = False}) = not (isIrrefutableHsPat pat) 1876hasRefutablePattern _ = False 1877 1878isLetStmt :: LStmt a b -> Bool 1879isLetStmt (L _ LetStmt{}) = True 1880isLetStmt _ = False 1881 1882-- | Find a "good" place to insert a bind in an indivisible segment. 1883-- This is the only place where we use heuristics. The current 1884-- heuristic is to peel off the first group of independent statements 1885-- and put the bind after those. 1886splitSegment 1887 :: [(ExprLStmt GhcRn, FreeVars)] 1888 -> ( [(ExprLStmt GhcRn, FreeVars)] 1889 , [(ExprLStmt GhcRn, FreeVars)] ) 1890splitSegment [one,two] = ([one],[two]) 1891 -- there is no choice when there are only two statements; this just saves 1892 -- some work in a common case. 1893splitSegment stmts 1894 | Just (lets,binds,rest) <- slurpIndependentStmts stmts 1895 = if not (null lets) 1896 then (lets, binds++rest) 1897 else (lets++binds, rest) 1898 | otherwise 1899 = case stmts of 1900 (x:xs) -> ([x],xs) 1901 _other -> (stmts,[]) 1902 1903slurpIndependentStmts 1904 :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] 1905 -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts 1906 , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts 1907 , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) 1908slurpIndependentStmts stmts = go [] [] emptyNameSet stmts 1909 where 1910 -- If we encounter a BindStmt that doesn't depend on a previous BindStmt 1911 -- in this group, then add it to the group. We have to be careful about 1912 -- strict patterns though; splitSegments expects that if we return Just 1913 -- then we have actually done some splitting. Otherwise it will go into 1914 -- an infinite loop (#14163). 1915 go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest) 1916 | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) 1917 = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep) 1918 bndrs' rest 1919 where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) 1920 -- If we encounter a LetStmt that doesn't depend on a BindStmt in this 1921 -- group, then move it to the beginning, so that it doesn't interfere with 1922 -- grouping more BindStmts. 1923 -- TODO: perhaps we shouldn't do this if there are any strict bindings, 1924 -- because we might be moving evaluation earlier. 1925 go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) 1926 | isEmptyNameSet (bndrs `intersectNameSet` fvs) 1927 = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest 1928 go _ [] _ _ = Nothing 1929 go _ [_] _ _ = Nothing 1930 go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) 1931 1932-- | Build an ApplicativeStmt, and strip the "return" from the tail 1933-- if necessary. 1934-- 1935-- For example, if we start with 1936-- do x <- E1; y <- E2; return (f x y) 1937-- then we get 1938-- do (E1[x] | E2[y]); f x y 1939-- 1940-- the LastStmt in this case has the return removed, but we set the 1941-- flag on the LastStmt to indicate this, so that we can print out the 1942-- original statement correctly in error messages. It is easier to do 1943-- it this way rather than try to ignore the return later in both the 1944-- typechecker and the desugarer (I tried it that way first!). 1945mkApplicativeStmt 1946 :: HsStmtContext Name 1947 -> [ApplicativeArg GhcRn] -- ^ The args 1948 -> Bool -- ^ True <=> need a join 1949 -> [ExprLStmt GhcRn] -- ^ The body statements 1950 -> RnM ([ExprLStmt GhcRn], FreeVars) 1951mkApplicativeStmt ctxt args need_join body_stmts 1952 = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName 1953 ; (ap_op, fvs2) <- lookupStmtName ctxt apAName 1954 ; (mb_join, fvs3) <- 1955 if need_join then 1956 do { (join_op, fvs) <- lookupStmtName ctxt joinMName 1957 ; return (Just join_op, fvs) } 1958 else 1959 return (Nothing, emptyNameSet) 1960 ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField 1961 (zip (fmap_op : repeat ap_op) args) 1962 mb_join 1963 ; return ( applicative_stmt : body_stmts 1964 , fvs1 `plusFV` fvs2 `plusFV` fvs3) } 1965 1966-- | Given the statements following an ApplicativeStmt, determine whether 1967-- we need a @join@ or not, and remove the @return@ if necessary. 1968needJoin :: MonadNames 1969 -> [ExprLStmt GhcRn] 1970 -> (Bool, [ExprLStmt GhcRn]) 1971needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg 1972needJoin monad_names [L loc (LastStmt _ e _ t)] 1973 | Just arg <- isReturnApp monad_names e = 1974 (False, [L loc (LastStmt noExtField arg True t)]) 1975needJoin _monad_names stmts = (True, stmts) 1976 1977-- | @Just e@, if the expression is @return e@ or @return $ e@, 1978-- otherwise @Nothing@ 1979isReturnApp :: MonadNames 1980 -> LHsExpr GhcRn 1981 -> Maybe (LHsExpr GhcRn) 1982isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr 1983isReturnApp monad_names (L _ e) = case e of 1984 OpApp _ l op r | is_return l, is_dollar op -> Just r 1985 HsApp _ f arg | is_return f -> Just arg 1986 _otherwise -> Nothing 1987 where 1988 is_var f (L _ (HsPar _ e)) = is_var f e 1989 is_var f (L _ (HsAppType _ e _)) = is_var f e 1990 is_var f (L _ (HsVar _ (L _ r))) = f r 1991 -- TODO: I don't know how to get this right for rebindable syntax 1992 is_var _ _ = False 1993 1994 is_return = is_var (\n -> n == return_name monad_names 1995 || n == pure_name monad_names) 1996 is_dollar = is_var (`hasKey` dollarIdKey) 1997 1998{- 1999************************************************************************ 2000* * 2001\subsubsection{Errors} 2002* * 2003************************************************************************ 2004-} 2005 2006checkEmptyStmts :: HsStmtContext Name -> RnM () 2007-- We've seen an empty sequence of Stmts... is that ok? 2008checkEmptyStmts ctxt 2009 = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) 2010 2011okEmpty :: HsStmtContext a -> Bool 2012okEmpty (PatGuard {}) = True 2013okEmpty _ = False 2014 2015emptyErr :: HsStmtContext Name -> SDoc 2016emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" 2017emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" 2018emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt 2019 2020---------------------- 2021checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name 2022 -> LStmt GhcPs (Located (body GhcPs)) 2023 -> RnM (LStmt GhcPs (Located (body GhcPs))) 2024checkLastStmt ctxt lstmt@(L loc stmt) 2025 = case ctxt of 2026 ListComp -> check_comp 2027 MonadComp -> check_comp 2028 ArrowExpr -> check_do 2029 DoExpr -> check_do 2030 MDoExpr -> check_do 2031 _ -> check_other 2032 where 2033 check_do -- Expect BodyStmt, and change it to LastStmt 2034 = case stmt of 2035 BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) 2036 LastStmt {} -> return lstmt -- "Deriving" clauses may generate a 2037 -- LastStmt directly (unlike the parser) 2038 _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } 2039 last_error = (text "The last statement in" <+> pprAStmtContext ctxt 2040 <+> text "must be an expression") 2041 2042 check_comp -- Expect LastStmt; this should be enforced by the parser! 2043 = case stmt of 2044 LastStmt {} -> return lstmt 2045 _ -> pprPanic "checkLastStmt" (ppr lstmt) 2046 2047 check_other -- Behave just as if this wasn't the last stmt 2048 = do { checkStmt ctxt lstmt; return lstmt } 2049 2050-- Checking when a particular Stmt is ok 2051checkStmt :: HsStmtContext Name 2052 -> LStmt GhcPs (Located (body GhcPs)) 2053 -> RnM () 2054checkStmt ctxt (L _ stmt) 2055 = do { dflags <- getDynFlags 2056 ; case okStmt dflags ctxt stmt of 2057 IsValid -> return () 2058 NotValid extra -> addErr (msg $$ extra) } 2059 where 2060 msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") 2061 , text "in" <+> pprAStmtContext ctxt ] 2062 2063pprStmtCat :: Stmt (GhcPass a) body -> SDoc 2064pprStmtCat (TransStmt {}) = text "transform" 2065pprStmtCat (LastStmt {}) = text "return expression" 2066pprStmtCat (BodyStmt {}) = text "body" 2067pprStmtCat (BindStmt {}) = text "binding" 2068pprStmtCat (LetStmt {}) = text "let" 2069pprStmtCat (RecStmt {}) = text "rec" 2070pprStmtCat (ParStmt {}) = text "parallel" 2071pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" 2072pprStmtCat (XStmtLR nec) = noExtCon nec 2073 2074------------ 2075emptyInvalid :: Validity -- Payload is the empty document 2076emptyInvalid = NotValid Outputable.empty 2077 2078okStmt, okDoStmt, okCompStmt, okParStmt 2079 :: DynFlags -> HsStmtContext Name 2080 -> Stmt GhcPs (Located (body GhcPs)) -> Validity 2081-- Return Nothing if OK, (Just extra) if not ok 2082-- The "extra" is an SDoc that is appended to a generic error message 2083 2084okStmt dflags ctxt stmt 2085 = case ctxt of 2086 PatGuard {} -> okPatGuardStmt stmt 2087 ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt 2088 DoExpr -> okDoStmt dflags ctxt stmt 2089 MDoExpr -> okDoStmt dflags ctxt stmt 2090 ArrowExpr -> okDoStmt dflags ctxt stmt 2091 GhciStmtCtxt -> okDoStmt dflags ctxt stmt 2092 ListComp -> okCompStmt dflags ctxt stmt 2093 MonadComp -> okCompStmt dflags ctxt stmt 2094 TransStmtCtxt ctxt -> okStmt dflags ctxt stmt 2095 2096------------- 2097okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity 2098okPatGuardStmt stmt 2099 = case stmt of 2100 BodyStmt {} -> IsValid 2101 BindStmt {} -> IsValid 2102 LetStmt {} -> IsValid 2103 _ -> emptyInvalid 2104 2105------------- 2106okParStmt dflags ctxt stmt 2107 = case stmt of 2108 LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid 2109 _ -> okStmt dflags ctxt stmt 2110 2111---------------- 2112okDoStmt dflags ctxt stmt 2113 = case stmt of 2114 RecStmt {} 2115 | LangExt.RecursiveDo `xopt` dflags -> IsValid 2116 | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' 2117 | otherwise -> NotValid (text "Use RecursiveDo") 2118 BindStmt {} -> IsValid 2119 LetStmt {} -> IsValid 2120 BodyStmt {} -> IsValid 2121 _ -> emptyInvalid 2122 2123---------------- 2124okCompStmt dflags _ stmt 2125 = case stmt of 2126 BindStmt {} -> IsValid 2127 LetStmt {} -> IsValid 2128 BodyStmt {} -> IsValid 2129 ParStmt {} 2130 | LangExt.ParallelListComp `xopt` dflags -> IsValid 2131 | otherwise -> NotValid (text "Use ParallelListComp") 2132 TransStmt {} 2133 | LangExt.TransformListComp `xopt` dflags -> IsValid 2134 | otherwise -> NotValid (text "Use TransformListComp") 2135 RecStmt {} -> emptyInvalid 2136 LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) 2137 ApplicativeStmt {} -> emptyInvalid 2138 XStmtLR nec -> noExtCon nec 2139 2140--------- 2141checkTupleSection :: [LHsTupArg GhcPs] -> RnM () 2142checkTupleSection args 2143 = do { tuple_section <- xoptM LangExt.TupleSections 2144 ; checkErr (all tupArgPresent args || tuple_section) msg } 2145 where 2146 msg = text "Illegal tuple section: use TupleSections" 2147 2148--------- 2149sectionErr :: HsExpr GhcPs -> SDoc 2150sectionErr expr 2151 = hang (text "A section must be enclosed in parentheses") 2152 2 (text "thus:" <+> (parens (ppr expr))) 2153 2154badIpBinds :: Outputable a => SDoc -> a -> SDoc 2155badIpBinds what binds 2156 = hang (text "Implicit-parameter bindings illegal in" <+> what) 2157 2 (ppr binds) 2158 2159--------- 2160 2161monadFailOp :: LPat GhcPs 2162 -> HsStmtContext Name 2163 -> RnM (SyntaxExpr GhcRn, FreeVars) 2164monadFailOp pat ctxt 2165 -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) 2166 -- we should not need to fail. 2167 | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs) 2168 2169 -- For non-monadic contexts (e.g. guard patterns, list 2170 -- comprehensions, etc.) we should not need to fail. See Note 2171 -- [Failing pattern matches in Stmts] 2172 | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs) 2173 2174 | otherwise = getMonadFailOp 2175 2176{- 2177Note [Monad fail : Rebindable syntax, overloaded strings] 2178~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2179 2180Given the code 2181 foo x = do { Just y <- x; return y } 2182 2183we expect it to desugar as 2184 foo x = x >>= \r -> case r of 2185 Just y -> return y 2186 Nothing -> fail "Pattern match error" 2187 2188But with RebindableSyntax and OverloadedStrings, we really want 2189it to desugar thus: 2190 foo x = x >>= \r -> case r of 2191 Just y -> return y 2192 Nothing -> fail (fromString "Patterm match error") 2193 2194So, in this case, we synthesize the function 2195 \x -> fail (fromString x) 2196 2197(rather than plain 'fail') for the 'fail' operation. This is done in 2198'getMonadFailOp'. 2199-} 2200getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op 2201getMonadFailOp 2202 = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags 2203 ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags 2204 ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings 2205 } 2206 where 2207 reallyGetMonadFailOp rebindableSyntax overloadedStrings 2208 | rebindableSyntax && overloadedStrings = do 2209 (failExpr, failFvs) <- lookupSyntaxName failMName 2210 (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName 2211 let arg_lit = fsLit "arg" 2212 arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit 2213 arg_syn_expr = mkRnSyntaxExpr arg_name 2214 let body :: LHsExpr GhcRn = 2215 nlHsApp (noLoc $ syn_expr failExpr) 2216 (nlHsApp (noLoc $ syn_expr fromStringExpr) 2217 (noLoc $ syn_expr arg_syn_expr)) 2218 let failAfterFromStringExpr :: HsExpr GhcRn = 2219 unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body 2220 let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = 2221 mkSyntaxExpr failAfterFromStringExpr 2222 return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) 2223 | otherwise = lookupSyntaxName failMName 2224