compiler/rename/RnExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnExpr]{Renaming of expressions}
   5
   6 Basically dependency analysis.
   7
   8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
   9 general, all of these functions return a renamed thing, and a set of
  10 free variables.
  11
  12 \begin{code}
  13 module RnExpr (
  14         rnLExpr, rnExpr, rnStmts
  15    ) where
  16
  17 #include "HsVersions.h"
  18
  19 #ifdef GHCI
  20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
  21 #endif  /* GHCI */
  22
  23 import RnSource  ( rnSrcDecls, findSplice )
  24 import RnBinds   ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
  25                    rnMatchGroup, makeMiniFixityEnv)
  26 import HsSyn
  27 import TcRnMonad
  28 import TcEnv            ( thRnBrack )
  29 import RnEnv
  30 import RnTypes          ( rnHsTypeFVs, rnSplice, checkTH,
  31                           mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
  32 import RnPat
  33 import DynFlags         ( DynFlag(..) )
  34 import BasicTypes       ( FixityDirection(..) )
  35 import PrelNames
  36
  37 import Name
  38 import NameSet
  39 import RdrName
  40 import LoadIface        ( loadInterfaceForName )
  41 import UniqSet
  42 import Data.List
  43 import Util             ( isSingleton )
  44 import ListSetOps       ( removeDups )
  45 import Outputable
  46 import SrcLoc
  47 import FastString
  48 import Control.Monad
  49 \end{code}
  50
  51
  52 \begin{code}
  53 -- XXX
  54 thenM :: Monad a => a b -> (b -> a c) -> a c
  55 thenM = (>>=)
  56
  57 thenM_ :: Monad a => a b -> a c -> a c
  58 thenM_ = (>>)
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsubsection{Expressions}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
  69 rnExprs ls = rnExprs' ls emptyUniqSet
  70  where
  71   rnExprs' [] acc = return ([], acc)
  72   rnExprs' (expr:exprs) acc
  73    = rnLExpr expr               `thenM` \ (expr', fvExpr) ->
  74
  75         -- Now we do a "seq" on the free vars because typically it's small
  76         -- or empty, especially in very long lists of constants
  77     let
  78         acc' = acc `plusFV` fvExpr
  79     in
  80     acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
  81     return (expr':exprs', fvExprs)
  82 \end{code}
  83
  84 Variables. We look up the variable and return the resulting name.
  85
  86 \begin{code}
  87 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
  88 rnLExpr = wrapLocFstM rnExpr
  89
  90 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
  91
  92 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
  93 -- Separated from rnExpr because it's also used
  94 -- when renaming infix expressions
  95 -- See Note [Adding the implicit parameter to 'assert']
  96 finishHsVar name
  97  = do { ignore_asserts <- doptM Opt_IgnoreAsserts
  98       ; if ignore_asserts || not (name `hasKey` assertIdKey)
  99         then return (HsVar name, unitFV name)
 100         else do { e <- mkAssertErrorExpr
 101                 ; return (e, unitFV name) } }
 102
 103 rnExpr (HsVar v)
 104   = do name <- lookupOccRn v
 105        finishHsVar name
 106
 107 rnExpr (HsIPVar v)
 108   = newIPNameRn v               `thenM` \ name ->
 109     return (HsIPVar name, emptyFVs)
 110
 111 rnExpr (HsLit lit@(HsString s))
 112   = do {
 113          opt_OverloadedStrings <- doptM Opt_OverloadedStrings
 114        ; if opt_OverloadedStrings then
 115             rnExpr (HsOverLit (mkHsIsString s placeHolderType))
 116          else -- Same as below
 117             rnLit lit           `thenM_`
 118             return (HsLit lit, emptyFVs)
 119        }
 120
 121 rnExpr (HsLit lit)
 122   = rnLit lit           `thenM_`
 123     return (HsLit lit, emptyFVs)
 124
 125 rnExpr (HsOverLit lit)
 126   = rnOverLit lit               `thenM` \ (lit', fvs) ->
 127     return (HsOverLit lit', fvs)
 128
 129 rnExpr (HsApp fun arg)
 130   = rnLExpr fun         `thenM` \ (fun',fvFun) ->
 131     rnLExpr arg         `thenM` \ (arg',fvArg) ->
 132     return (HsApp fun' arg', fvFun `plusFV` fvArg)
 133
 134 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
 135   = do  { (e1', fv_e1) <- rnLExpr e1
 136         ; (e2', fv_e2) <- rnLExpr e2
 137         ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
 138         ; (op', fv_op) <- finishHsVar op_name
 139                 -- NB: op' is usually just a variable, but might be
 140                 --     an applicatoin (assert "Foo.hs:47")
 141         -- Deal with fixity
 142         -- When renaming code synthesised from "deriving" declarations
 143         -- we used to avoid fixity stuff, but we can't easily tell any
 144         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
 145         -- should prevent bad things happening.
 146         ; fixity <- lookupFixityRn op_name
 147         ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
 148         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
 149
 150 rnExpr (NegApp e _)
 151   = rnLExpr e                   `thenM` \ (e', fv_e) ->
 152     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 153     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 154     return (final_e, fv_e `plusFV` fv_neg)
 155
 156 ------------------------------------------
 157 -- Template Haskell extensions
 158 -- Don't ifdef-GHCI them because we want to fail gracefully
 159 -- (not with an rnExpr crash) in a stage-1 compiler.
 160 rnExpr e@(HsBracket br_body)
 161   = checkTH e "bracket"         `thenM_`
 162     rnBracket br_body           `thenM` \ (body', fvs_e) ->
 163     return (HsBracket body', fvs_e)
 164
 165 rnExpr (HsSpliceE splice)
 166   = rnSplice splice             `thenM` \ (splice', fvs) ->
 167     return (HsSpliceE splice', fvs)
 168
 169 #ifndef GHCI
 170 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
 171 #else
 172 rnExpr (HsQuasiQuoteE qq)
 173   = runQuasiQuoteExpr qq        `thenM` \ (L _ expr') ->
 174     rnExpr expr'
 175 #endif  /* GHCI */
 176
 177 ---------------------------------------------
 178 --      Sections
 179 -- See Note [Parsing sections] in Parser.y.pp
 180 rnExpr (HsPar (L loc (section@(SectionL {}))))
 181   = do  { (section', fvs) <- rnSection section
 182         ; return (HsPar (L loc section'), fvs) }
 183
 184 rnExpr (HsPar (L loc (section@(SectionR {}))))
 185   = do  { (section', fvs) <- rnSection section
 186         ; return (HsPar (L loc section'), fvs) }
 187
 188 rnExpr (HsPar e)
 189   = do  { (e', fvs_e) <- rnLExpr e
 190         ; return (HsPar e', fvs_e) }
 191
 192 rnExpr expr@(SectionL {})
 193   = do  { addErr (sectionErr expr); rnSection expr }
 194 rnExpr expr@(SectionR {})
 195   = do  { addErr (sectionErr expr); rnSection expr }
 196
 197 ---------------------------------------------
 198 rnExpr (HsCoreAnn ann expr)
 199   = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
 200     return (HsCoreAnn ann expr', fvs_expr)
 201
 202 rnExpr (HsSCC lbl expr)
 203   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 204     return (HsSCC lbl expr', fvs_expr)
 205 rnExpr (HsTickPragma info expr)
 206   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 207     return (HsTickPragma info expr', fvs_expr)
 208
 209 rnExpr (HsLam matches)
 210   = rnMatchGroup LambdaExpr matches     `thenM` \ (matches', fvMatch) ->
 211     return (HsLam matches', fvMatch)
 212
 213 rnExpr (HsCase expr matches)
 214   = rnLExpr expr                        `thenM` \ (new_expr, e_fvs) ->
 215     rnMatchGroup CaseAlt matches        `thenM` \ (new_matches, ms_fvs) ->
 216     return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
 217
 218 rnExpr (HsLet binds expr)
 219   = rnLocalBindsAndThen binds           $ \ binds' ->
 220     rnLExpr expr                         `thenM` \ (expr',fvExpr) ->
 221     return (HsLet binds' expr', fvExpr)
 222
 223 rnExpr (HsDo do_or_lc stmts body _)
 224   = do  { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
 225                                     rnLExpr body
 226         ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
 227
 228 rnExpr (ExplicitList _ exps)
 229   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 230     return  (ExplicitList placeHolderType exps', fvs)
 231
 232 rnExpr (ExplicitPArr _ exps)
 233   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 234     return  (ExplicitPArr placeHolderType exps', fvs)
 235
 236 rnExpr (ExplicitTuple tup_args boxity)
 237   = do { checkTupleSection tup_args
 238        ; checkTupSize (length tup_args)
 239        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
 240        ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
 241   where
 242     rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
 243     rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
 244
 245 rnExpr (RecordCon con_id _ rbinds)
 246   = do  { conname <- lookupLocatedOccRn con_id
 247         ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
 248         ; return (RecordCon conname noPostTcExpr rbinds',
 249                   fvRbinds `addOneFV` unLoc conname) }
 250
 251 rnExpr (RecordUpd expr rbinds _ _ _)
 252   = do  { (expr', fvExpr) <- rnLExpr expr
 253         ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
 254         ; return (RecordUpd expr' rbinds' [] [] [],
 255                   fvExpr `plusFV` fvRbinds) }
 256
 257 rnExpr (ExprWithTySig expr pty)
 258   = do  { (pty', fvTy) <- rnHsTypeFVs doc pty
 259         ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
 260                              rnLExpr expr
 261         ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 262   where
 263     doc = text "In an expression type signature"
 264
 265 rnExpr (HsIf p b1 b2)
 266   = rnLExpr p           `thenM` \ (p', fvP) ->
 267     rnLExpr b1          `thenM` \ (b1', fvB1) ->
 268     rnLExpr b2          `thenM` \ (b2', fvB2) ->
 269     return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
 270
 271 rnExpr (HsType a)
 272   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 273     return (HsType t, fvT)
 274   where
 275     doc = text "In a type argument"
 276
 277 rnExpr (ArithSeq _ seq)
 278   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 279     return (ArithSeq noPostTcExpr new_seq, fvs)
 280
 281 rnExpr (PArrSeq _ seq)
 282   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 283     return (PArrSeq noPostTcExpr new_seq, fvs)
 284 \end{code}
 285
 286 These three are pattern syntax appearing in expressions.
 287 Since all the symbols are reservedops we can simply reject them.
 288 We return a (bogus) EWildPat in each case.
 289
 290 \begin{code}
 291 rnExpr e@EWildPat      = patSynErr e
 292 rnExpr e@(EAsPat {})   = patSynErr e
 293 rnExpr e@(EViewPat {}) = patSynErr e
 294 rnExpr e@(ELazyPat {}) = patSynErr e
 295 \end{code}
 296
 297 %************************************************************************
 298 %*                                                                      *
 299         Arrow notation
 300 %*                                                                      *
 301 %************************************************************************
 302
 303 \begin{code}
 304 rnExpr (HsProc pat body)
 305   = newArrowScope $
 306     rnPat ProcExpr pat $ \ pat' ->
 307     rnCmdTop body                `thenM` \ (body',fvBody) ->
 308     return (HsProc pat' body', fvBody)
 309
 310 rnExpr (HsArrApp arrow arg _ ho rtl)
 311   = select_arrow_scope (rnLExpr arrow)  `thenM` \ (arrow',fvArrow) ->
 312     rnLExpr arg                         `thenM` \ (arg',fvArg) ->
 313     return (HsArrApp arrow' arg' placeHolderType ho rtl,
 314              fvArrow `plusFV` fvArg)
 315   where
 316     select_arrow_scope tc = case ho of
 317         HsHigherOrderApp -> tc
 318         HsFirstOrderApp  -> escapeArrowScope tc
 319
 320 -- infix form
 321 rnExpr (HsArrForm op (Just _) [arg1, arg2])
 322   = escapeArrowScope (rnLExpr op)
 323                         `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
 324     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
 325     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
 326
 327         -- Deal with fixity
 328
 329     lookupFixityRn op_name              `thenM` \ fixity ->
 330     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e ->
 331
 332     return (final_e,
 333               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
 334
 335 rnExpr (HsArrForm op fixity cmds)
 336   = escapeArrowScope (rnLExpr op)       `thenM` \ (op',fvOp) ->
 337     rnCmdArgs cmds                      `thenM` \ (cmds',fvCmds) ->
 338     return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
 339
 340 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 341         -- HsWrap
 342
 343 ----------------------
 344 -- See Note [Parsing sections] in Parser.y.pp
 345 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 346 rnSection section@(SectionR op expr)
 347   = do  { (op', fvs_op)     <- rnLExpr op
 348         ; (expr', fvs_expr) <- rnLExpr expr
 349         ; checkSectionPrec InfixR section op' expr'
 350         ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
 351
 352 rnSection section@(SectionL expr op)
 353   = do  { (expr', fvs_expr) <- rnLExpr expr
 354         ; (op', fvs_op)     <- rnLExpr op
 355         ; checkSectionPrec InfixL section op' expr'
 356         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
 357
 358 rnSection other = pprPanic "rnSection" (ppr other)
 359 \end{code}
 360
 361 %************************************************************************
 362 %*                                                                      *
 363         Records
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 \begin{code}
 368 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
 369              -> RnM (HsRecordBinds Name, FreeVars)
 370 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
 371   = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
 372        ; (flds', fvss) <- mapAndUnzipM rn_field flds
 373        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
 374                  fvs `plusFV` plusFVs fvss) }
 375   where
 376     rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
 377                       ; return (fld { hsRecFieldArg = arg' }, fvs) }
 378 \end{code}
 379
 380
 381 %************************************************************************
 382 %*                                                                      *
 383         Arrow commands
 384 %*                                                                      *
 385 %************************************************************************
 386
 387 \begin{code}
 388 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
 389 rnCmdArgs [] = return ([], emptyFVs)
 390 rnCmdArgs (arg:args)
 391   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
 392     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
 393     return (arg':args', fvArg `plusFV` fvArgs)
 394
 395 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
 396 rnCmdTop = wrapLocFstM rnCmdTop'
 397  where
 398   rnCmdTop' (HsCmdTop cmd _ _ _)
 399    = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
 400      let
 401         cmd_names = [arrAName, composeAName, firstAName] ++
 402                     nameSetToList (methodNamesCmd (unLoc cmd'))
 403      in
 404         -- Generate the rebindable syntax for the monad
 405      lookupSyntaxTable cmd_names        `thenM` \ (cmd_names', cmd_fvs) ->
 406
 407      return (HsCmdTop cmd' [] placeHolderType cmd_names',
 408              fvCmd `plusFV` cmd_fvs)
 409
 410 ---------------------------------------------------
 411 -- convert OpApp's in a command context to HsArrForm's
 412
 413 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
 414 convertOpFormsLCmd = fmap convertOpFormsCmd
 415
 416 convertOpFormsCmd :: HsCmd id -> HsCmd id
 417
 418 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
 419 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
 420 convertOpFormsCmd (OpApp c1 op fixity c2)
 421   = let
 422         arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
 423         arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
 424     in
 425     HsArrForm op (Just fixity) [arg1, arg2]
 426
 427 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 428
 429 convertOpFormsCmd (HsCase exp matches)
 430   = HsCase exp (convertOpFormsMatch matches)
 431
 432 convertOpFormsCmd (HsIf exp c1 c2)
 433   = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 434
 435 convertOpFormsCmd (HsLet binds cmd)
 436   = HsLet binds (convertOpFormsLCmd cmd)
 437
 438 convertOpFormsCmd (HsDo ctxt stmts body ty)
 439   = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
 440               (convertOpFormsLCmd body) ty
 441
 442 -- Anything else is unchanged.  This includes HsArrForm (already done),
 443 -- things with no sub-commands, and illegal commands (which will be
 444 -- caught by the type checker)
 445 convertOpFormsCmd c = c
 446
 447 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
 448 convertOpFormsStmt (BindStmt pat cmd _ _)
 449   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
 450 convertOpFormsStmt (ExprStmt cmd _ _)
 451   = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
 452 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
 453   = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
 454 convertOpFormsStmt stmt = stmt
 455
 456 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
 457 convertOpFormsMatch (MatchGroup ms ty)
 458   = MatchGroup (map (fmap convert) ms) ty
 459  where convert (Match pat mty grhss)
 460           = Match pat mty (convertOpFormsGRHSs grhss)
 461
 462 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
 463 convertOpFormsGRHSs (GRHSs grhss binds)
 464   = GRHSs (map convertOpFormsGRHS grhss) binds
 465
 466 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
 467 convertOpFormsGRHS = fmap convert
 468  where
 469    convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
 470
 471 ---------------------------------------------------
 472 type CmdNeeds = FreeVars        -- Only inhabitants are
 473                                 --      appAName, choiceAName, loopAName
 474
 475 -- find what methods the Cmd needs (loop, choice, apply)
 476 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
 477 methodNamesLCmd = methodNamesCmd . unLoc
 478
 479 methodNamesCmd :: HsCmd Name -> CmdNeeds
 480
 481 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
 482   = emptyFVs
 483 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
 484   = unitFV appAName
 485 methodNamesCmd (HsArrForm {}) = emptyFVs
 486
 487 methodNamesCmd (HsPar c) = methodNamesLCmd c
 488
 489 methodNamesCmd (HsIf _ c1 c2)
 490   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 491
 492 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
 493
 494 methodNamesCmd (HsDo _ stmts body _)
 495   = methodNamesStmts stmts `plusFV` methodNamesLCmd body
 496
 497 methodNamesCmd (HsApp c _) = methodNamesLCmd c
 498
 499 methodNamesCmd (HsLam match) = methodNamesMatch match
 500
 501 methodNamesCmd (HsCase _ matches)
 502   = methodNamesMatch matches `addOneFV` choiceAName
 503
 504 methodNamesCmd _ = emptyFVs
 505    -- Other forms can't occur in commands, but it's not convenient
 506    -- to error here so we just do what's convenient.
 507    -- The type checker will complain later
 508
 509 ---------------------------------------------------
 510 methodNamesMatch :: MatchGroup Name -> FreeVars
 511 methodNamesMatch (MatchGroup ms _)
 512   = plusFVs (map do_one ms)
 513  where
 514     do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
 515
 516 -------------------------------------------------
 517 -- gaw 2004
 518 methodNamesGRHSs :: GRHSs Name -> FreeVars
 519 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
 520
 521 -------------------------------------------------
 522
 523 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
 524 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
 525
 526 ---------------------------------------------------
 527 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
 528 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
 529
 530 ---------------------------------------------------
 531 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
 532 methodNamesLStmt = methodNamesStmt . unLoc
 533
 534 methodNamesStmt :: StmtLR Name Name -> FreeVars
 535 methodNamesStmt (ExprStmt cmd _ _)               = methodNamesLCmd cmd
 536 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
 537 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
 538 methodNamesStmt (LetStmt _)                      = emptyFVs
 539 methodNamesStmt (ParStmt _)                      = emptyFVs
 540 methodNamesStmt (TransformStmt {})               = emptyFVs
 541 methodNamesStmt (GroupStmt {})                   = emptyFVs
 542    -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
 543    -- here so we just do what's convenient
 544 \end{code}
 545
 546
 547 %************************************************************************
 548 %*                                                                      *
 549         Arithmetic sequences
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 \begin{code}
 554 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
 555 rnArithSeq (From expr)
 556  = rnLExpr expr         `thenM` \ (expr', fvExpr) ->
 557    return (From expr', fvExpr)
 558
 559 rnArithSeq (FromThen expr1 expr2)
 560  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 561    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 562    return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 563
 564 rnArithSeq (FromTo expr1 expr2)
 565  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 566    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 567    return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 568
 569 rnArithSeq (FromThenTo expr1 expr2 expr3)
 570  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 571    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 572    rnLExpr expr3        `thenM` \ (expr3', fvExpr3) ->
 573    return (FromThenTo expr1' expr2' expr3',
 574             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 575 \end{code}
 576
 577 %************************************************************************
 578 %*                                                                      *
 579         Template Haskell brackets
 580 %*                                                                      *
 581 %************************************************************************
 582
 583 \begin{code}
 584 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 585 rnBracket (VarBr n) = do { name <- lookupOccRn n
 586                          ; this_mod <- getModule
 587                          ; unless (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
 588                            do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
 589                               ; return () }                             -- only way that is going to happen
 590                          ; return (VarBr name, unitFV name) }
 591                     where
 592                       msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 593
 594 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 595                          ; return (ExpBr e', fvs) }
 596
 597 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
 598
 599 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 600                          ; return (TypBr t', fvs) }
 601                     where
 602                       doc = ptext (sLit "In a Template-Haskell quoted type")
 603
 604 rnBracket (DecBrL decls)
 605   = do { (group, mb_splice) <- findSplice decls
 606        ; case mb_splice of
 607            Nothing -> return ()
 608            Just (SpliceDecl (L loc _), _)
 609               -> setSrcSpan loc $
 610                  addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
 611                 -- Why not?  See Section 7.3 of the TH paper.
 612
 613        ; gbl_env  <- getGblEnv
 614        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
 615                           -- The emptyDUs is so that we just collect uses for this
 616                           -- group alone in the call to rnSrcDecls below
 617        ; (tcg_env, group') <- setGblEnv new_gbl_env $
 618                               setStage thRnBrack $
 619                               rnSrcDecls group
 620
 621        -- Discard the tcg_env; it contains only extra info about fixity
 622         ; return (DecBrG group', allUses (tcg_dus tcg_env)) }
 623
 624 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 625 \end{code}
 626
 627 %************************************************************************
 628 %*                                                                      *
 629 \subsubsection{@Stmt@s: in @do@ expressions}
 630 %*                                                                      *
 631 %************************************************************************
 632
 633 \begin{code}
 634 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
 635         -> RnM (thing, FreeVars)
 636         -> RnM (([LStmt Name], thing), FreeVars)
 637 -- Variables bound by the Stmts, and mentioned in thing_inside,
 638 -- do not appear in the result FreeVars
 639
 640 rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts    stmts thing_inside
 641 rnStmts ctxt        stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
 642
 643 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
 644               -> ([Name] -> RnM (thing, FreeVars))
 645               -> RnM (([LStmt Name], thing), FreeVars)
 646 -- Variables bound by the Stmts, and mentioned in thing_inside,
 647 -- do not appear in the result FreeVars
 648 --
 649 -- Renaming a single RecStmt can give a sequence of smaller Stmts
 650
 651 rnNormalStmts _ [] thing_inside
 652   = do { (res, fvs) <- thing_inside []
 653        ; return (([], res), fvs) }
 654
 655 rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
 656   = do { ((stmts1, (stmts2, thing)), fvs)
 657             <- setSrcSpan loc           $
 658                rnStmt ctxt stmt         $ \ bndrs1 ->
 659                rnNormalStmts ctxt stmts $ \ bndrs2 ->
 660                thing_inside (bndrs1 ++ bndrs2)
 661         ; return (((stmts1 ++ stmts2), thing), fvs) }
 662
 663
 664 rnStmt :: HsStmtContext Name -> LStmt RdrName
 665        -> ([Name] -> RnM (thing, FreeVars))
 666        -> RnM (([LStmt Name], thing), FreeVars)
 667 -- Variables bound by the Stmt, and mentioned in thing_inside,
 668 -- do not appear in the result FreeVars
 669
 670 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
 671   = do  { (expr', fv_expr) <- rnLExpr expr
 672         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
 673         ; (thing, fvs2)    <- thing_inside []
 674         ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
 675                   fv_expr `plusFV` fvs1 `plusFV` fvs2) }
 676
 677 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
 678   = do  { (expr', fv_expr) <- rnLExpr expr
 679                 -- The binders do not scope over the expression
 680         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 681         ; (fail_op, fvs2) <- lookupSyntaxName failMName
 682         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 683         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
 684         ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
 685                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 686        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 687         -- but it does not matter because the names are unique
 688
 689 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
 690   = do  { checkLetStmt ctxt binds
 691         ; rnLocalBindsAndThen binds $ \binds' -> do
 692         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
 693         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
 694
 695 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 696   = do  { checkRecStmt ctxt
 697
 698         -- Step1: Bring all the binders of the mdo into scope
 699         -- (Remember that this also removes the binders from the
 700         -- finally-returned free-vars.)
 701         -- And rename each individual stmt, making a
 702         -- singleton segment.  At this stage the FwdRefs field
 703         -- isn't finished: it's empty for all except a BindStmt
 704         -- for which it's the fwd refs within the bind itself
 705         -- (This set may not be empty, because we're in a recursive
 706         -- context.)
 707         ; rn_rec_stmts_and_then rec_stmts       $ \ segs -> do
 708
 709         { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
 710                                             emptyNameSet segs
 711         ; (thing, fvs_later) <- thing_inside bndrs
 712         ; (return_op, fvs1)  <- lookupSyntaxName returnMName
 713         ; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
 714         ; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
 715         ; let
 716                 -- Step 2: Fill in the fwd refs.
 717                 --         The segments are all singletons, but their fwd-ref
 718                 --         field mentions all the things used by the segment
 719                 --         that are bound after their use
 720             segs_w_fwd_refs          = addFwdRefs segs
 721
 722                 -- Step 3: Group together the segments to make bigger segments
 723                 --         Invariant: in the result, no segment uses a variable
 724                 --                    bound in a later segment
 725             grouped_segs = glomSegments segs_w_fwd_refs
 726
 727                 -- Step 4: Turn the segments into Stmts
 728                 --         Use RecStmt when and only when there are fwd refs
 729                 --         Also gather up the uses from the end towards the
 730                 --         start, so we can tell the RecStmt which things are
 731                 --         used 'after' the RecStmt
 732             empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
 733                                           , recS_mfix_fn = mfix_op
 734                                           , recS_bind_fn = bind_op }
 735             (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
 736
 737         ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 738
 739 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
 740   = do  { checkParStmt ctxt
 741         ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
 742         ; return (([L loc (ParStmt segs')], thing), fvs) }
 743
 744 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
 745   = do { checkTransformStmt ctxt
 746
 747        ; (using', fvs1) <- rnLExpr using
 748
 749        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 750              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 751                 do { (by', fvs_by) <- case by of
 752                                         Nothing -> return (Nothing, emptyFVs)
 753                                         Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
 754                    ; (thing, fvs_thing) <- thing_inside bndrs
 755                    ; let fvs        = fvs_by `plusFV` fvs_thing
 756                          used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
 757                    ; return ((by', used_bndrs, thing), fvs) }
 758
 759        ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
 760                  fvs1 `plusFV` fvs2) }
 761
 762 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
 763   = do { checkTransformStmt ctxt
 764
 765          -- Rename the 'using' expression in the context before the transform is begun
 766        ; (using', fvs1) <- case using of
 767                              Left e  -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
 768                              Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
 769                                            ; return (Right e', fvs) }
 770
 771          -- Rename the stmts and the 'by' expression
 772          -- Keep track of the variables mentioned in the 'by' expression
 773        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 774              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 775                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 776                    ; (thing, fvs_thing) <- thing_inside bndrs
 777                    ; let fvs = fvs_by `plusFV` fvs_thing
 778                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 779                    ; return ((by', used_bndrs, thing), fvs) }
 780
 781        ; let all_fvs  = fvs1 `plusFV` fvs2
 782              bndr_map = used_bndrs `zip` used_bndrs
 783              -- See Note [GroupStmt binder map] in HsExpr
 784
 785        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
 786        ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
 787
 788
 789 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
 790
 791 rnParallelStmts :: forall thing. HsStmtContext Name
 792                 -> [ParSeg RdrName]
 793                 -> ([Name] -> RnM (thing, FreeVars))
 794                 -> RnM (([ParSeg Name], thing), FreeVars)
 795 -- Note [Renaming parallel Stmts]
 796 rnParallelStmts ctxt segs thing_inside
 797   = do { orig_lcl_env <- getLocalRdrEnv
 798        ; rn_segs orig_lcl_env [] segs }
 799   where
 800     rn_segs :: LocalRdrEnv
 801             -> [Name] -> [ParSeg RdrName]
 802             -> RnM (([ParSeg Name], thing), FreeVars)
 803     rn_segs _ bndrs_so_far []
 804       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 805            ; mapM_ dupErr dups
 806            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 807            ; return (([], thing), fvs) }
 808
 809     rn_segs env bndrs_so_far ((stmts,_) : segs)
 810       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 811                     <- rnNormalStmts ctxt stmts $ \ bndrs ->
 812                        setLocalRdrEnv env       $ do
 813                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 814                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 815                        ; return ((used_bndrs, segs', thing), fvs) }
 816
 817            ; let seg' = (stmts', used_bndrs)
 818            ; return ((seg':segs', thing), fvs) }
 819
 820     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 821     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
 822                     <+> quotes (ppr (head vs)))
 823 \end{code}
 824
 825 Note [Renaming parallel Stmts]
 826 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 827 Renaming parallel statements is painful.  Given, say
 828      [ a+c | a <- as, bs <- bss
 829            | c <- bs, a <- ds ]
 830 Note that
 831   (a) In order to report "Defined by not used" about 'bs', we must rename
 832       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
 833
 834   (b) We want to report that 'a' is illegally bound in both branches
 835
 836   (c) The 'bs' in the second group must obviously not be captured by
 837       the binding in the first group
 838
 839 To satisfy (a) we nest the segements.
 840 To satisfy (b) we check for duplicates just before thing_inside.
 841 To satisfy (c) we reset the LocalRdrEnv each time.
 842
 843 %************************************************************************
 844 %*                                                                      *
 845 \subsubsection{mdo expressions}
 846 %*                                                                      *
 847 %************************************************************************
 848
 849 \begin{code}
 850 type FwdRefs = NameSet
 851 type Segment stmts = (Defs,
 852                       Uses,     -- May include defs
 853                       FwdRefs,  -- A subset of uses that are
 854                                 --   (a) used before they are bound in this segment, or
 855                                 --   (b) used here, and bound in subsequent segments
 856                       stmts)    -- Either Stmt or [Stmt]
 857
 858
 859 ----------------------------------------------------
 860
 861 rnMDoStmts :: [LStmt RdrName]
 862            -> RnM (thing, FreeVars)
 863            -> RnM (([LStmt Name], thing), FreeVars)
 864 rnMDoStmts stmts thing_inside
 865   = rn_rec_stmts_and_then stmts $ \ segs -> do
 866     { (thing, fvs_later) <- thing_inside
 867     ; let   segs_w_fwd_refs = addFwdRefs segs
 868             grouped_segs = glomSegments segs_w_fwd_refs
 869             (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
 870     ; return ((stmts', thing), fvs) }
 871
 872 ---------------------------------------------
 873
 874 -- wrapper that does both the left- and right-hand sides
 875 rn_rec_stmts_and_then :: [LStmt RdrName]
 876                          -- assumes that the FreeVars returned includes
 877                          -- the FreeVars of the Segments
 878                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
 879                       -> RnM (a, FreeVars)
 880 rn_rec_stmts_and_then s cont
 881   = do  { -- (A) Make the mini fixity env for all of the stmts
 882           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
 883
 884           -- (B) Do the LHSes
 885         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
 886
 887           --    ...bring them and their fixities into scope
 888         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
 889         ; bindLocalNamesFV bound_names $
 890           addLocalFixities fix_env bound_names $ do
 891
 892           -- (C) do the right-hand-sides and thing-inside
 893         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
 894         ; (res, fvs) <- cont segs
 895         ; warnUnusedLocalBinds bound_names fvs
 896         ; return (res, fvs) }}
 897
 898 -- get all the fixity decls in any Let stmt
 899 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
 900 collectRecStmtsFixities l =
 901     foldr (\ s -> \acc -> case s of
 902                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
 903                                 foldr (\ sig -> \ acc -> case sig of
 904                                                            (L loc (FixSig s)) -> (L loc s) : acc
 905                                                            _ -> acc) acc sigs
 906                             _ -> acc) [] l
 907
 908 -- left-hand sides
 909
 910 rn_rec_stmt_lhs :: MiniFixityEnv
 911                 -> LStmt RdrName
 912                    -- rename LHS, and return its FVs
 913                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 914                    -- so we don't bother to compute it accurately in the other cases
 915                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 916
 917 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
 918                                                        -- this is actually correct
 919                                                        emptyFVs)]
 920
 921 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
 922   = do
 923       -- should the ctxt be MDo instead?
 924       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 925       return [(L loc (BindStmt pat' expr a b),
 926                fv_pat)]
 927
 928 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
 929   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 930
 931 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 932     = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
 933          return [(L loc (LetStmt (HsValBinds binds')),
 934                  -- Warning: this is bogus; see function invariant
 935                  emptyFVs
 936                  )]
 937
 938 -- XXX Do we need to do something with the return and mfix names?
 939 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
 940     = rn_rec_stmts_lhs fix_env stmts
 941
 942 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _))        -- Syntactically illegal in mdo
 943   = pprPanic "rn_rec_stmt" (ppr stmt)
 944
 945 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
 946   = pprPanic "rn_rec_stmt" (ppr stmt)
 947
 948 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))     -- Syntactically illegal in mdo
 949   = pprPanic "rn_rec_stmt" (ppr stmt)
 950
 951 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 952   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 953
 954 rn_rec_stmts_lhs :: MiniFixityEnv
 955                  -> [LStmt RdrName]
 956                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
 957 rn_rec_stmts_lhs fix_env stmts
 958   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 959        ; let boundNames = collectLStmtsBinders (map fst ls)
 960             -- First do error checking: we need to check for dups here because we
 961             -- don't bind all of the variables from the Stmt at once
 962             -- with bindLocatedLocals.
 963        ; checkDupNames boundNames
 964        ; return ls }
 965
 966
 967 -- right-hand-sides
 968
 969 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
 970         -- Rename a Stmt that is inside a RecStmt (or mdo)
 971         -- Assumes all binders are already in scope
 972         -- Turns each stmt into a singleton Stmt
 973 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
 974   = rnLExpr expr `thenM` \ (expr', fvs) ->
 975     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
 976     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 977               L loc (ExprStmt expr' then_op placeHolderType))]
 978
 979 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 980   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
 981     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
 982     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
 983     let
 984         bndrs = mkNameSet (collectPatBinders pat')
 985         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
 986     in
 987     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 988               L loc (BindStmt pat' expr' bind_op fail_op))]
 989
 990 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
 991   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 992
 993 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
 994   (binds', du_binds) <-
 995       -- fixities and unused are handled above in rn_rec_stmts_and_then
 996       rnValBindsRHS (mkNameSet all_bndrs) binds'
 997   return [(duDefs du_binds, duUses du_binds,
 998             emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
 999
1000 -- no RecStmt case becuase they get flattened above when doing the LHSes
1001 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1002   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1003
1004 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1005   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1006
1007 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _   -- Syntactically illegal in mdo
1008   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1009
1010 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _       -- Syntactically illegal in mdo
1011   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1012
1013 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1014   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1015
1016 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1017 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1018                            return (concat segs_s)
1019
1020 ---------------------------------------------
1021 addFwdRefs :: [Segment a] -> [Segment a]
1022 -- So far the segments only have forward refs *within* the Stmt
1023 --      (which happens for bind:  x <- ...x...)
1024 -- This function adds the cross-seg fwd ref info
1025
1026 addFwdRefs pairs
1027   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1028   where
1029     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1030         = (new_seg : segs, all_defs)
1031         where
1032           new_seg = (defs, uses, new_fwds, stmts)
1033           all_defs = later_defs `unionNameSets` defs
1034           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1035                 -- Add the downstream fwd refs here
1036
1037 ----------------------------------------------------
1038 --      Glomming the singleton segments of an mdo into
1039 --      minimal recursive groups.
1040 --
1041 -- At first I thought this was just strongly connected components, but
1042 -- there's an important constraint: the order of the stmts must not change.
1043 --
1044 -- Consider
1045 --      mdo { x <- ...y...
1046 --            p <- z
1047 --            y <- ...x...
1048 --            q <- x
1049 --            z <- y
1050 --            r <- x }
1051 --
1052 -- Here, the first stmt mention 'y', which is bound in the third.
1053 -- But that means that the innocent second stmt (p <- z) gets caught
1054 -- up in the recursion.  And that in turn means that the binding for
1055 -- 'z' has to be included... and so on.
1056 --
1057 -- Start at the tail { r <- x }
1058 -- Now add the next one { z <- y ; r <- x }
1059 -- Now add one more     { q <- x ; z <- y ; r <- x }
1060 -- Now one more... but this time we have to group a bunch into rec
1061 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1062 -- Now one more, which we can add on without a rec
1063 --      { p <- z ;
1064 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1065 --        r <- x }
1066 -- Finally we add the last one; since it mentions y we have to
1067 -- glom it togeher with the first two groups
1068 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1069 --              q <- x ; z <- y } ;
1070 --        r <- x }
1071
1072 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1073
1074 glomSegments [] = []
1075 glomSegments ((defs,uses,fwds,stmt) : segs)
1076         -- Actually stmts will always be a singleton
1077   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1078   where
1079     segs'            = glomSegments segs
1080     (extras, others) = grab uses segs'
1081     (ds, us, fs, ss) = unzip4 extras
1082
1083     seg_defs  = plusFVs ds `plusFV` defs
1084     seg_uses  = plusFVs us `plusFV` uses
1085     seg_fwds  = plusFVs fs `plusFV` fwds
1086     seg_stmts = stmt : concat ss
1087
1088     grab :: NameSet             -- The client
1089          -> [Segment a]
1090          -> ([Segment a],       -- Needed by the 'client'
1091              [Segment a])       -- Not needed by the client
1092         -- The result is simply a split of the input
1093     grab uses dus
1094         = (reverse yeses, reverse noes)
1095         where
1096           (noes, yeses)           = span not_needed (reverse dus)
1097           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1098
1099
1100 ----------------------------------------------------
1101 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1102             -> [Segment [LStmt Name]]
1103             -> FreeVars                 -- Free vars used 'later'
1104             -> ([LStmt Name], FreeVars)
1105
1106 segsToStmts _ [] fvs_later = ([], fvs_later)
1107 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1108   = ASSERT( not (null ss) )
1109     (new_stmt : later_stmts, later_uses `plusFV` uses)
1110   where
1111     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1112     new_stmt | non_rec   = head ss
1113              | otherwise = L (getLoc (head ss)) rec_stmt
1114     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1115                               , recS_later_ids = nameSetToList used_later
1116                               , recS_rec_ids   = nameSetToList fwds }
1117     non_rec    = isSingleton ss && isEmptyNameSet fwds
1118     used_later = defs `intersectNameSet` later_uses
1119                                 -- The ones needed after the RecStmt
1120 \end{code}
1121
1122 %************************************************************************
1123 %*                                                                      *
1124 \subsubsection{Assertion utils}
1125 %*                                                                      *
1126 %************************************************************************
1127
1128 \begin{code}
1129 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1130 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1131
1132 mkAssertErrorExpr :: RnM (HsExpr Name)
1133 -- Return an expression for (assertError "Foo.hs:27")
1134 mkAssertErrorExpr
1135   = getSrcSpanM                         `thenM` \ sloc ->
1136     return (HsApp (L sloc (HsVar assertErrorName))
1137                   (L sloc (srcSpanPrimLit sloc)))
1138 \end{code}
1139
1140 Note [Adding the implicit parameter to 'assert']
1141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1142 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1143 By doing this in the renamer we allow the typechecker to just see the
1144 expanded application and do the right thing. But it's not really
1145 the Right Thing because there's no way to "undo" if you want to see
1146 the original source code.  We'll have fix this in due course, when
1147 we care more about being able to reconstruct the exact original
1148 program.
1149
1150 %************************************************************************
1151 %*                                                                      *
1152 \subsubsection{Errors}
1153 %*                                                                      *
1154 %************************************************************************
1155
1156 \begin{code}
1157
1158 ----------------------
1159 -- Checking when a particular Stmt is ok
1160 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1161 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1162 checkLetStmt _ctxt           _binds            = return ()
1163         -- We do not allow implicit-parameter bindings in a parallel
1164         -- list comprehension.  I'm not sure what it might mean.
1165
1166 ---------
1167 checkRecStmt :: HsStmtContext Name -> RnM ()
1168 checkRecStmt (MDoExpr {}) = return ()   -- Recursive stmt ok in 'mdo'
1169 checkRecStmt (DoExpr {})  = return ()   -- and in 'do'
1170 checkRecStmt ctxt         = addErr msg
1171   where
1172     msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1173
1174 ---------
1175 checkParStmt :: HsStmtContext Name -> RnM ()
1176 checkParStmt _
1177   = do  { parallel_list_comp <- doptM Opt_ParallelListComp
1178         ; checkErr parallel_list_comp msg }
1179   where
1180     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1181
1182 ---------
1183 checkTransformStmt :: HsStmtContext Name -> RnM ()
1184 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
1185                              -- desugarer will break when we come to operate on a parallel array
1186   = do  { transform_list_comp <- doptM Opt_TransformListComp
1187         ; checkErr transform_list_comp msg }
1188   where
1189     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1190 checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1191 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1192 checkTransformStmt ctxt = addErr msg
1193   where
1194     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1195
1196 ---------
1197 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1198 checkTupleSection args
1199   = do  { tuple_section <- doptM Opt_TupleSections
1200         ; checkErr (all tupArgPresent args || tuple_section) msg }
1201   where
1202     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1203
1204 ---------
1205 sectionErr :: HsExpr RdrName -> SDoc
1206 sectionErr expr
1207   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1208        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1209
1210 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1211 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1212                                 nest 4 (ppr e)])
1213                  ; return (EWildPat, emptyFVs) }
1214
1215 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1216 badIpBinds what binds
1217   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1218          2 (ppr binds)
1219 \end{code}