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
  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 <- xoptM 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',fv_op) ->
 324     let L _ (HsVar op_name) = op' in
 325     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
 326     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
 327
 328         -- Deal with fixity
 329
 330     lookupFixityRn op_name              `thenM` \ fixity ->
 331     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e ->
 332
 333     return (final_e,
 334               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
 335
 336 rnExpr (HsArrForm op fixity cmds)
 337   = escapeArrowScope (rnLExpr op)       `thenM` \ (op',fvOp) ->
 338     rnCmdArgs cmds                      `thenM` \ (cmds',fvCmds) ->
 339     return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
 340
 341 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 342         -- HsWrap
 343
 344 ----------------------
 345 -- See Note [Parsing sections] in Parser.y.pp
 346 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 347 rnSection section@(SectionR op expr)
 348   = do  { (op', fvs_op)     <- rnLExpr op
 349         ; (expr', fvs_expr) <- rnLExpr expr
 350         ; checkSectionPrec InfixR section op' expr'
 351         ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
 352
 353 rnSection section@(SectionL expr op)
 354   = do  { (expr', fvs_expr) <- rnLExpr expr
 355         ; (op', fvs_op)     <- rnLExpr op
 356         ; checkSectionPrec InfixL section op' expr'
 357         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
 358
 359 rnSection other = pprPanic "rnSection" (ppr other)
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364         Records
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
 370              -> RnM (HsRecordBinds Name, FreeVars)
 371 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
 372   = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
 373        ; (flds', fvss) <- mapAndUnzipM rn_field flds
 374        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
 375                  fvs `plusFV` plusFVs fvss) }
 376   where
 377     rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
 378                       ; return (fld { hsRecFieldArg = arg' }, fvs) }
 379 \end{code}
 380
 381
 382 %************************************************************************
 383 %*                                                                      *
 384         Arrow commands
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 \begin{code}
 389 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
 390 rnCmdArgs [] = return ([], emptyFVs)
 391 rnCmdArgs (arg:args)
 392   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
 393     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
 394     return (arg':args', fvArg `plusFV` fvArgs)
 395
 396 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
 397 rnCmdTop = wrapLocFstM rnCmdTop'
 398  where
 399   rnCmdTop' (HsCmdTop cmd _ _ _)
 400    = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
 401      let
 402         cmd_names = [arrAName, composeAName, firstAName] ++
 403                     nameSetToList (methodNamesCmd (unLoc cmd'))
 404      in
 405         -- Generate the rebindable syntax for the monad
 406      lookupSyntaxTable cmd_names        `thenM` \ (cmd_names', cmd_fvs) ->
 407
 408      return (HsCmdTop cmd' [] placeHolderType cmd_names',
 409              fvCmd `plusFV` cmd_fvs)
 410
 411 ---------------------------------------------------
 412 -- convert OpApp's in a command context to HsArrForm's
 413
 414 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
 415 convertOpFormsLCmd = fmap convertOpFormsCmd
 416
 417 convertOpFormsCmd :: HsCmd id -> HsCmd id
 418
 419 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
 420 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
 421 convertOpFormsCmd (OpApp c1 op fixity c2)
 422   = let
 423         arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
 424         arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
 425     in
 426     HsArrForm op (Just fixity) [arg1, arg2]
 427
 428 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 429
 430 convertOpFormsCmd (HsCase exp matches)
 431   = HsCase exp (convertOpFormsMatch matches)
 432
 433 convertOpFormsCmd (HsIf exp c1 c2)
 434   = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 435
 436 convertOpFormsCmd (HsLet binds cmd)
 437   = HsLet binds (convertOpFormsLCmd cmd)
 438
 439 convertOpFormsCmd (HsDo ctxt stmts body ty)
 440   = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
 441               (convertOpFormsLCmd body) ty
 442
 443 -- Anything else is unchanged.  This includes HsArrForm (already done),
 444 -- things with no sub-commands, and illegal commands (which will be
 445 -- caught by the type checker)
 446 convertOpFormsCmd c = c
 447
 448 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
 449 convertOpFormsStmt (BindStmt pat cmd _ _)
 450   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
 451 convertOpFormsStmt (ExprStmt cmd _ _)
 452   = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
 453 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
 454   = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
 455 convertOpFormsStmt stmt = stmt
 456
 457 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
 458 convertOpFormsMatch (MatchGroup ms ty)
 459   = MatchGroup (map (fmap convert) ms) ty
 460  where convert (Match pat mty grhss)
 461           = Match pat mty (convertOpFormsGRHSs grhss)
 462
 463 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
 464 convertOpFormsGRHSs (GRHSs grhss binds)
 465   = GRHSs (map convertOpFormsGRHS grhss) binds
 466
 467 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
 468 convertOpFormsGRHS = fmap convert
 469  where
 470    convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
 471
 472 ---------------------------------------------------
 473 type CmdNeeds = FreeVars        -- Only inhabitants are
 474                                 --      appAName, choiceAName, loopAName
 475
 476 -- find what methods the Cmd needs (loop, choice, apply)
 477 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
 478 methodNamesLCmd = methodNamesCmd . unLoc
 479
 480 methodNamesCmd :: HsCmd Name -> CmdNeeds
 481
 482 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
 483   = emptyFVs
 484 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
 485   = unitFV appAName
 486 methodNamesCmd (HsArrForm {}) = emptyFVs
 487
 488 methodNamesCmd (HsPar c) = methodNamesLCmd c
 489
 490 methodNamesCmd (HsIf _ c1 c2)
 491   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 492
 493 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
 494
 495 methodNamesCmd (HsDo _ stmts body _)
 496   = methodNamesStmts stmts `plusFV` methodNamesLCmd body
 497
 498 methodNamesCmd (HsApp c _) = methodNamesLCmd c
 499
 500 methodNamesCmd (HsLam match) = methodNamesMatch match
 501
 502 methodNamesCmd (HsCase _ matches)
 503   = methodNamesMatch matches `addOneFV` choiceAName
 504
 505 methodNamesCmd _ = emptyFVs
 506    -- Other forms can't occur in commands, but it's not convenient
 507    -- to error here so we just do what's convenient.
 508    -- The type checker will complain later
 509
 510 ---------------------------------------------------
 511 methodNamesMatch :: MatchGroup Name -> FreeVars
 512 methodNamesMatch (MatchGroup ms _)
 513   = plusFVs (map do_one ms)
 514  where
 515     do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
 516
 517 -------------------------------------------------
 518 -- gaw 2004
 519 methodNamesGRHSs :: GRHSs Name -> FreeVars
 520 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
 521
 522 -------------------------------------------------
 523
 524 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
 525 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
 526
 527 ---------------------------------------------------
 528 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
 529 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
 530
 531 ---------------------------------------------------
 532 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
 533 methodNamesLStmt = methodNamesStmt . unLoc
 534
 535 methodNamesStmt :: StmtLR Name Name -> FreeVars
 536 methodNamesStmt (ExprStmt cmd _ _)               = methodNamesLCmd cmd
 537 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
 538 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
 539 methodNamesStmt (LetStmt _)                      = emptyFVs
 540 methodNamesStmt (ParStmt _)                      = emptyFVs
 541 methodNamesStmt (TransformStmt {})               = emptyFVs
 542 methodNamesStmt (GroupStmt {})                   = emptyFVs
 543    -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
 544    -- here so we just do what's convenient
 545 \end{code}
 546
 547
 548 %************************************************************************
 549 %*                                                                      *
 550         Arithmetic sequences
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
 556 rnArithSeq (From expr)
 557  = rnLExpr expr         `thenM` \ (expr', fvExpr) ->
 558    return (From expr', fvExpr)
 559
 560 rnArithSeq (FromThen expr1 expr2)
 561  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 562    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 563    return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 564
 565 rnArithSeq (FromTo expr1 expr2)
 566  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 567    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 568    return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 569
 570 rnArithSeq (FromThenTo expr1 expr2 expr3)
 571  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 572    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 573    rnLExpr expr3        `thenM` \ (expr3', fvExpr3) ->
 574    return (FromThenTo expr1' expr2' expr3',
 575             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 576 \end{code}
 577
 578 %************************************************************************
 579 %*                                                                      *
 580         Template Haskell brackets
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 \begin{code}
 585 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 586 rnBracket (VarBr n) = do { name <- lookupOccRn n
 587                          ; this_mod <- getModule
 588                          ; unless (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
 589                            do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
 590                               ; return () }                             -- only way that is going to happen
 591                          ; return (VarBr name, unitFV name) }
 592                     where
 593                       msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 594
 595 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 596                          ; return (ExpBr e', fvs) }
 597
 598 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
 599
 600 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 601                          ; return (TypBr t', fvs) }
 602                     where
 603                       doc = ptext (sLit "In a Template-Haskell quoted type")
 604
 605 rnBracket (DecBrL decls)
 606   = do { (group, mb_splice) <- findSplice decls
 607        ; case mb_splice of
 608            Nothing -> return ()
 609            Just (SpliceDecl (L loc _) _, _)
 610               -> setSrcSpan loc $
 611                  addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
 612                 -- Why not?  See Section 7.3 of the TH paper.
 613
 614        ; gbl_env  <- getGblEnv
 615        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
 616                           -- The emptyDUs is so that we just collect uses for this
 617                           -- group alone in the call to rnSrcDecls below
 618        ; (tcg_env, group') <- setGblEnv new_gbl_env $
 619                               setStage thRnBrack $
 620                               rnSrcDecls group
 621
 622               -- Discard the tcg_env; it contains only extra info about fixity
 623         ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
 624         ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
 625
 626 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 627 \end{code}
 628
 629 %************************************************************************
 630 %*                                                                      *
 631 \subsubsection{@Stmt@s: in @do@ expressions}
 632 %*                                                                      *
 633 %************************************************************************
 634
 635 \begin{code}
 636 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
 637         -> RnM (thing, FreeVars)
 638         -> RnM (([LStmt Name], thing), FreeVars)
 639 -- Variables bound by the Stmts, and mentioned in thing_inside,
 640 -- do not appear in the result FreeVars
 641
 642 rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts    stmts thing_inside
 643 rnStmts ctxt        stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
 644
 645 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
 646               -> ([Name] -> RnM (thing, FreeVars))
 647               -> RnM (([LStmt Name], thing), FreeVars)
 648 -- Variables bound by the Stmts, and mentioned in thing_inside,
 649 -- do not appear in the result FreeVars
 650 --
 651 -- Renaming a single RecStmt can give a sequence of smaller Stmts
 652
 653 rnNormalStmts _ [] thing_inside
 654   = do { (res, fvs) <- thing_inside []
 655        ; return (([], res), fvs) }
 656
 657 rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
 658   = do { ((stmts1, (stmts2, thing)), fvs)
 659             <- setSrcSpan loc           $
 660                rnStmt ctxt stmt         $ \ bndrs1 ->
 661                rnNormalStmts ctxt stmts $ \ bndrs2 ->
 662                thing_inside (bndrs1 ++ bndrs2)
 663         ; return (((stmts1 ++ stmts2), thing), fvs) }
 664
 665
 666 rnStmt :: HsStmtContext Name -> LStmt RdrName
 667        -> ([Name] -> RnM (thing, FreeVars))
 668        -> RnM (([LStmt Name], thing), FreeVars)
 669 -- Variables bound by the Stmt, and mentioned in thing_inside,
 670 -- do not appear in the result FreeVars
 671
 672 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
 673   = do  { (expr', fv_expr) <- rnLExpr expr
 674         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
 675         ; (thing, fvs2)    <- thing_inside []
 676         ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
 677                   fv_expr `plusFV` fvs1 `plusFV` fvs2) }
 678
 679 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
 680   = do  { (expr', fv_expr) <- rnLExpr expr
 681                 -- The binders do not scope over the expression
 682         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 683         ; (fail_op, fvs2) <- lookupSyntaxName failMName
 684         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 685         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
 686         ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
 687                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 688        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 689         -- but it does not matter because the names are unique
 690
 691 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
 692   = do  { checkLetStmt ctxt binds
 693         ; rnLocalBindsAndThen binds $ \binds' -> do
 694         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
 695         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
 696
 697 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 698   = do  { checkRecStmt ctxt
 699
 700         -- Step1: Bring all the binders of the mdo into scope
 701         -- (Remember that this also removes the binders from the
 702         -- finally-returned free-vars.)
 703         -- And rename each individual stmt, making a
 704         -- singleton segment.  At this stage the FwdRefs field
 705         -- isn't finished: it's empty for all except a BindStmt
 706         -- for which it's the fwd refs within the bind itself
 707         -- (This set may not be empty, because we're in a recursive
 708         -- context.)
 709         ; rn_rec_stmts_and_then rec_stmts       $ \ segs -> do
 710
 711         { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
 712                                             emptyNameSet segs
 713         ; (thing, fvs_later) <- thing_inside bndrs
 714         ; (return_op, fvs1)  <- lookupSyntaxName returnMName
 715         ; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
 716         ; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
 717         ; let
 718                 -- Step 2: Fill in the fwd refs.
 719                 --         The segments are all singletons, but their fwd-ref
 720                 --         field mentions all the things used by the segment
 721                 --         that are bound after their use
 722             segs_w_fwd_refs          = addFwdRefs segs
 723
 724                 -- Step 3: Group together the segments to make bigger segments
 725                 --         Invariant: in the result, no segment uses a variable
 726                 --                    bound in a later segment
 727             grouped_segs = glomSegments segs_w_fwd_refs
 728
 729                 -- Step 4: Turn the segments into Stmts
 730                 --         Use RecStmt when and only when there are fwd refs
 731                 --         Also gather up the uses from the end towards the
 732                 --         start, so we can tell the RecStmt which things are
 733                 --         used 'after' the RecStmt
 734             empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
 735                                           , recS_mfix_fn = mfix_op
 736                                           , recS_bind_fn = bind_op }
 737             (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
 738
 739         ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 740
 741 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
 742   = do  { checkParStmt ctxt
 743         ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
 744         ; return (([L loc (ParStmt segs')], thing), fvs) }
 745
 746 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
 747   = do { checkTransformStmt ctxt
 748
 749        ; (using', fvs1) <- rnLExpr using
 750
 751        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 752              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 753                 do { (by', fvs_by) <- case by of
 754                                         Nothing -> return (Nothing, emptyFVs)
 755                                         Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
 756                    ; (thing, fvs_thing) <- thing_inside bndrs
 757                    ; let fvs        = fvs_by `plusFV` fvs_thing
 758                          used_bndrs = filter (`elemNameSet` fvs_thing) bndrs
 759                    ; return ((by', used_bndrs, thing), fvs) }
 760
 761        ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
 762                  fvs1 `plusFV` fvs2) }
 763
 764 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
 765   = do { checkTransformStmt ctxt
 766
 767          -- Rename the 'using' expression in the context before the transform is begun
 768        ; (using', fvs1) <- case using of
 769                              Left e  -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
 770                              Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
 771                                            ; return (Right e', fvs) }
 772
 773          -- Rename the stmts and the 'by' expression
 774          -- Keep track of the variables mentioned in the 'by' expression
 775        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 776              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 777                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 778                    ; (thing, fvs_thing) <- thing_inside bndrs
 779                    ; let fvs = fvs_by `plusFV` fvs_thing
 780                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 781                    ; return ((by', used_bndrs, thing), fvs) }
 782
 783        ; let all_fvs  = fvs1 `plusFV` fvs2
 784              bndr_map = used_bndrs `zip` used_bndrs
 785              -- See Note [GroupStmt binder map] in HsExpr
 786
 787        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
 788        ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
 789
 790
 791 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
 792
 793 rnParallelStmts :: forall thing. HsStmtContext Name
 794                 -> [ParSeg RdrName]
 795                 -> ([Name] -> RnM (thing, FreeVars))
 796                 -> RnM (([ParSeg Name], thing), FreeVars)
 797 -- Note [Renaming parallel Stmts]
 798 rnParallelStmts ctxt segs thing_inside
 799   = do { orig_lcl_env <- getLocalRdrEnv
 800        ; rn_segs orig_lcl_env [] segs }
 801   where
 802     rn_segs :: LocalRdrEnv
 803             -> [Name] -> [ParSeg RdrName]
 804             -> RnM (([ParSeg Name], thing), FreeVars)
 805     rn_segs _ bndrs_so_far []
 806       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 807            ; mapM_ dupErr dups
 808            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 809            ; return (([], thing), fvs) }
 810
 811     rn_segs env bndrs_so_far ((stmts,_) : segs)
 812       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 813                     <- rnNormalStmts ctxt stmts $ \ bndrs ->
 814                        setLocalRdrEnv env       $ do
 815                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 816                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 817                        ; return ((used_bndrs, segs', thing), fvs) }
 818
 819            ; let seg' = (stmts', used_bndrs)
 820            ; return ((seg':segs', thing), fvs) }
 821
 822     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 823     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
 824                     <+> quotes (ppr (head vs)))
 825 \end{code}
 826
 827 Note [Renaming parallel Stmts]
 828 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 829 Renaming parallel statements is painful.  Given, say
 830      [ a+c | a <- as, bs <- bss
 831            | c <- bs, a <- ds ]
 832 Note that
 833   (a) In order to report "Defined by not used" about 'bs', we must rename
 834       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
 835
 836   (b) We want to report that 'a' is illegally bound in both branches
 837
 838   (c) The 'bs' in the second group must obviously not be captured by
 839       the binding in the first group
 840
 841 To satisfy (a) we nest the segements.
 842 To satisfy (b) we check for duplicates just before thing_inside.
 843 To satisfy (c) we reset the LocalRdrEnv each time.
 844
 845 %************************************************************************
 846 %*                                                                      *
 847 \subsubsection{mdo expressions}
 848 %*                                                                      *
 849 %************************************************************************
 850
 851 \begin{code}
 852 type FwdRefs = NameSet
 853 type Segment stmts = (Defs,
 854                       Uses,     -- May include defs
 855                       FwdRefs,  -- A subset of uses that are
 856                                 --   (a) used before they are bound in this segment, or
 857                                 --   (b) used here, and bound in subsequent segments
 858                       stmts)    -- Either Stmt or [Stmt]
 859
 860
 861 ----------------------------------------------------
 862
 863 rnMDoStmts :: [LStmt RdrName]
 864            -> RnM (thing, FreeVars)
 865            -> RnM (([LStmt Name], thing), FreeVars)
 866 rnMDoStmts stmts thing_inside
 867   = rn_rec_stmts_and_then stmts $ \ segs -> do
 868     { (thing, fvs_later) <- thing_inside
 869     ; let   segs_w_fwd_refs = addFwdRefs segs
 870             grouped_segs = glomSegments segs_w_fwd_refs
 871             (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
 872     ; return ((stmts', thing), fvs) }
 873
 874 ---------------------------------------------
 875
 876 -- wrapper that does both the left- and right-hand sides
 877 rn_rec_stmts_and_then :: [LStmt RdrName]
 878                          -- assumes that the FreeVars returned includes
 879                          -- the FreeVars of the Segments
 880                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
 881                       -> RnM (a, FreeVars)
 882 rn_rec_stmts_and_then s cont
 883   = do  { -- (A) Make the mini fixity env for all of the stmts
 884           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
 885
 886           -- (B) Do the LHSes
 887         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
 888
 889           --    ...bring them and their fixities into scope
 890         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
 891         ; bindLocalNamesFV bound_names $
 892           addLocalFixities fix_env bound_names $ do
 893
 894           -- (C) do the right-hand-sides and thing-inside
 895         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
 896         ; (res, fvs) <- cont segs
 897         ; warnUnusedLocalBinds bound_names fvs
 898         ; return (res, fvs) }}
 899
 900 -- get all the fixity decls in any Let stmt
 901 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
 902 collectRecStmtsFixities l =
 903     foldr (\ s -> \acc -> case s of
 904                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
 905                                 foldr (\ sig -> \ acc -> case sig of
 906                                                            (L loc (FixSig s)) -> (L loc s) : acc
 907                                                            _ -> acc) acc sigs
 908                             _ -> acc) [] l
 909
 910 -- left-hand sides
 911
 912 rn_rec_stmt_lhs :: MiniFixityEnv
 913                 -> LStmt RdrName
 914                    -- rename LHS, and return its FVs
 915                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 916                    -- so we don't bother to compute it accurately in the other cases
 917                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 918
 919 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
 920                                                        -- this is actually correct
 921                                                        emptyFVs)]
 922
 923 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
 924   = do
 925       -- should the ctxt be MDo instead?
 926       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 927       return [(L loc (BindStmt pat' expr a b),
 928                fv_pat)]
 929
 930 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
 931   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 932
 933 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 934     = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
 935          return [(L loc (LetStmt (HsValBinds binds')),
 936                  -- Warning: this is bogus; see function invariant
 937                  emptyFVs
 938                  )]
 939
 940 -- XXX Do we need to do something with the return and mfix names?
 941 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
 942     = rn_rec_stmts_lhs fix_env stmts
 943
 944 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _))        -- Syntactically illegal in mdo
 945   = pprPanic "rn_rec_stmt" (ppr stmt)
 946
 947 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
 948   = pprPanic "rn_rec_stmt" (ppr stmt)
 949
 950 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))     -- Syntactically illegal in mdo
 951   = pprPanic "rn_rec_stmt" (ppr stmt)
 952
 953 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 954   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 955
 956 rn_rec_stmts_lhs :: MiniFixityEnv
 957                  -> [LStmt RdrName]
 958                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
 959 rn_rec_stmts_lhs fix_env stmts
 960   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 961        ; let boundNames = collectLStmtsBinders (map fst ls)
 962             -- First do error checking: we need to check for dups here because we
 963             -- don't bind all of the variables from the Stmt at once
 964             -- with bindLocatedLocals.
 965        ; checkDupNames boundNames
 966        ; return ls }
 967
 968
 969 -- right-hand-sides
 970
 971 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
 972         -- Rename a Stmt that is inside a RecStmt (or mdo)
 973         -- Assumes all binders are already in scope
 974         -- Turns each stmt into a singleton Stmt
 975 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
 976   = rnLExpr expr `thenM` \ (expr', fvs) ->
 977     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
 978     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 979               L loc (ExprStmt expr' then_op placeHolderType))]
 980
 981 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 982   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
 983     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
 984     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
 985     let
 986         bndrs = mkNameSet (collectPatBinders pat')
 987         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
 988     in
 989     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 990               L loc (BindStmt pat' expr' bind_op fail_op))]
 991
 992 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
 993   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 994
 995 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
 996   (binds', du_binds) <-
 997       -- fixities and unused are handled above in rn_rec_stmts_and_then
 998       rnValBindsRHS (mkNameSet all_bndrs) binds'
 999   return [(duDefs du_binds, allUses du_binds,
1000            emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1001
1002 -- no RecStmt case becuase they get flattened above when doing the LHSes
1003 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1004   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1005
1006 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1007   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1008
1009 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _   -- Syntactically illegal in mdo
1010   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1011
1012 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _       -- Syntactically illegal in mdo
1013   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1014
1015 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1016   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1017
1018 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1019 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1020                            return (concat segs_s)
1021
1022 ---------------------------------------------
1023 addFwdRefs :: [Segment a] -> [Segment a]
1024 -- So far the segments only have forward refs *within* the Stmt
1025 --      (which happens for bind:  x <- ...x...)
1026 -- This function adds the cross-seg fwd ref info
1027
1028 addFwdRefs pairs
1029   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1030   where
1031     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1032         = (new_seg : segs, all_defs)
1033         where
1034           new_seg = (defs, uses, new_fwds, stmts)
1035           all_defs = later_defs `unionNameSets` defs
1036           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1037                 -- Add the downstream fwd refs here
1038
1039 ----------------------------------------------------
1040 --      Glomming the singleton segments of an mdo into
1041 --      minimal recursive groups.
1042 --
1043 -- At first I thought this was just strongly connected components, but
1044 -- there's an important constraint: the order of the stmts must not change.
1045 --
1046 -- Consider
1047 --      mdo { x <- ...y...
1048 --            p <- z
1049 --            y <- ...x...
1050 --            q <- x
1051 --            z <- y
1052 --            r <- x }
1053 --
1054 -- Here, the first stmt mention 'y', which is bound in the third.
1055 -- But that means that the innocent second stmt (p <- z) gets caught
1056 -- up in the recursion.  And that in turn means that the binding for
1057 -- 'z' has to be included... and so on.
1058 --
1059 -- Start at the tail { r <- x }
1060 -- Now add the next one { z <- y ; r <- x }
1061 -- Now add one more     { q <- x ; z <- y ; r <- x }
1062 -- Now one more... but this time we have to group a bunch into rec
1063 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1064 -- Now one more, which we can add on without a rec
1065 --      { p <- z ;
1066 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1067 --        r <- x }
1068 -- Finally we add the last one; since it mentions y we have to
1069 -- glom it togeher with the first two groups
1070 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1071 --              q <- x ; z <- y } ;
1072 --        r <- x }
1073
1074 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1075
1076 glomSegments [] = []
1077 glomSegments ((defs,uses,fwds,stmt) : segs)
1078         -- Actually stmts will always be a singleton
1079   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1080   where
1081     segs'            = glomSegments segs
1082     (extras, others) = grab uses segs'
1083     (ds, us, fs, ss) = unzip4 extras
1084
1085     seg_defs  = plusFVs ds `plusFV` defs
1086     seg_uses  = plusFVs us `plusFV` uses
1087     seg_fwds  = plusFVs fs `plusFV` fwds
1088     seg_stmts = stmt : concat ss
1089
1090     grab :: NameSet             -- The client
1091          -> [Segment a]
1092          -> ([Segment a],       -- Needed by the 'client'
1093              [Segment a])       -- Not needed by the client
1094         -- The result is simply a split of the input
1095     grab uses dus
1096         = (reverse yeses, reverse noes)
1097         where
1098           (noes, yeses)           = span not_needed (reverse dus)
1099           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1100
1101
1102 ----------------------------------------------------
1103 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1104             -> [Segment [LStmt Name]]
1105             -> FreeVars                 -- Free vars used 'later'
1106             -> ([LStmt Name], FreeVars)
1107
1108 segsToStmts _ [] fvs_later = ([], fvs_later)
1109 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1110   = ASSERT( not (null ss) )
1111     (new_stmt : later_stmts, later_uses `plusFV` uses)
1112   where
1113     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1114     new_stmt | non_rec   = head ss
1115              | otherwise = L (getLoc (head ss)) rec_stmt
1116     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1117                               , recS_later_ids = nameSetToList used_later
1118                               , recS_rec_ids   = nameSetToList fwds }
1119     non_rec    = isSingleton ss && isEmptyNameSet fwds
1120     used_later = defs `intersectNameSet` later_uses
1121                                 -- The ones needed after the RecStmt
1122 \end{code}
1123
1124 %************************************************************************
1125 %*                                                                      *
1126 \subsubsection{Assertion utils}
1127 %*                                                                      *
1128 %************************************************************************
1129
1130 \begin{code}
1131 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1132 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1133
1134 mkAssertErrorExpr :: RnM (HsExpr Name)
1135 -- Return an expression for (assertError "Foo.hs:27")
1136 mkAssertErrorExpr
1137   = getSrcSpanM                         `thenM` \ sloc ->
1138     return (HsApp (L sloc (HsVar assertErrorName))
1139                   (L sloc (srcSpanPrimLit sloc)))
1140 \end{code}
1141
1142 Note [Adding the implicit parameter to 'assert']
1143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1144 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1145 By doing this in the renamer we allow the typechecker to just see the
1146 expanded application and do the right thing. But it's not really
1147 the Right Thing because there's no way to "undo" if you want to see
1148 the original source code.  We'll have fix this in due course, when
1149 we care more about being able to reconstruct the exact original
1150 program.
1151
1152 %************************************************************************
1153 %*                                                                      *
1154 \subsubsection{Errors}
1155 %*                                                                      *
1156 %************************************************************************
1157
1158 \begin{code}
1159
1160 ----------------------
1161 -- Checking when a particular Stmt is ok
1162 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1163 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1164 checkLetStmt _ctxt           _binds            = return ()
1165         -- We do not allow implicit-parameter bindings in a parallel
1166         -- list comprehension.  I'm not sure what it might mean.
1167
1168 ---------
1169 checkRecStmt :: HsStmtContext Name -> RnM ()
1170 checkRecStmt (MDoExpr {}) = return ()   -- Recursive stmt ok in 'mdo'
1171 checkRecStmt (DoExpr {})  = return ()   -- and in 'do'
1172 checkRecStmt ctxt         = addErr msg
1173   where
1174     msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1175
1176 ---------
1177 checkParStmt :: HsStmtContext Name -> RnM ()
1178 checkParStmt _
1179   = do  { parallel_list_comp <- xoptM Opt_ParallelListComp
1180         ; checkErr parallel_list_comp msg }
1181   where
1182     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1183
1184 ---------
1185 checkTransformStmt :: HsStmtContext Name -> RnM ()
1186 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
1187                              -- desugarer will break when we come to operate on a parallel array
1188   = do  { transform_list_comp <- xoptM Opt_TransformListComp
1189         ; checkErr transform_list_comp msg }
1190   where
1191     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1192 checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1193 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1194 checkTransformStmt ctxt = addErr msg
1195   where
1196     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1197
1198 ---------
1199 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1200 checkTupleSection args
1201   = do  { tuple_section <- xoptM Opt_TupleSections
1202         ; checkErr (all tupArgPresent args || tuple_section) msg }
1203   where
1204     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1205
1206 ---------
1207 sectionErr :: HsExpr RdrName -> SDoc
1208 sectionErr expr
1209   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1210        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1211
1212 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1213 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1214                                 nest 4 (ppr e)])
1215                  ; return (EWildPat, emptyFVs) }
1216
1217 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1218 badIpBinds what binds
1219   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1220          2 (ppr binds)
1221 \end{code}