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, rnLocalValBindsLHS, rnLocalValBindsRHS,
  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, snocView )
  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 rnExpr (OpApp _ other_op _ _)
 150   = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
 151                         2 (ppr other_op)
 152                    , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
 153
 154 rnExpr (NegApp e _)
 155   = rnLExpr e                   `thenM` \ (e', fv_e) ->
 156     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 157     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 158     return (final_e, fv_e `plusFV` fv_neg)
 159
 160 ------------------------------------------
 161 -- Template Haskell extensions
 162 -- Don't ifdef-GHCI them because we want to fail gracefully
 163 -- (not with an rnExpr crash) in a stage-1 compiler.
 164 rnExpr e@(HsBracket br_body)
 165   = checkTH e "bracket"         `thenM_`
 166     rnBracket br_body           `thenM` \ (body', fvs_e) ->
 167     return (HsBracket body', fvs_e)
 168
 169 rnExpr (HsSpliceE splice)
 170   = rnSplice splice             `thenM` \ (splice', fvs) ->
 171     return (HsSpliceE splice', fvs)
 172
 173 #ifndef GHCI
 174 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
 175 #else
 176 rnExpr (HsQuasiQuoteE qq)
 177   = runQuasiQuoteExpr qq        `thenM` \ (L _ expr') ->
 178     rnExpr expr'
 179 #endif  /* GHCI */
 180
 181 ---------------------------------------------
 182 --      Sections
 183 -- See Note [Parsing sections] in Parser.y.pp
 184 rnExpr (HsPar (L loc (section@(SectionL {}))))
 185   = do  { (section', fvs) <- rnSection section
 186         ; return (HsPar (L loc section'), fvs) }
 187
 188 rnExpr (HsPar (L loc (section@(SectionR {}))))
 189   = do  { (section', fvs) <- rnSection section
 190         ; return (HsPar (L loc section'), fvs) }
 191
 192 rnExpr (HsPar e)
 193   = do  { (e', fvs_e) <- rnLExpr e
 194         ; return (HsPar e', fvs_e) }
 195
 196 rnExpr expr@(SectionL {})
 197   = do  { addErr (sectionErr expr); rnSection expr }
 198 rnExpr expr@(SectionR {})
 199   = do  { addErr (sectionErr expr); rnSection expr }
 200
 201 ---------------------------------------------
 202 rnExpr (HsCoreAnn ann expr)
 203   = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
 204     return (HsCoreAnn ann expr', fvs_expr)
 205
 206 rnExpr (HsSCC lbl expr)
 207   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 208     return (HsSCC lbl expr', fvs_expr)
 209 rnExpr (HsTickPragma info expr)
 210   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 211     return (HsTickPragma info expr', fvs_expr)
 212
 213 rnExpr (HsLam matches)
 214   = rnMatchGroup LambdaExpr matches     `thenM` \ (matches', fvMatch) ->
 215     return (HsLam matches', fvMatch)
 216
 217 rnExpr (HsCase expr matches)
 218   = rnLExpr expr                        `thenM` \ (new_expr, e_fvs) ->
 219     rnMatchGroup CaseAlt matches        `thenM` \ (new_matches, ms_fvs) ->
 220     return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
 221
 222 rnExpr (HsLet binds expr)
 223   = rnLocalBindsAndThen binds           $ \ binds' ->
 224     rnLExpr expr                         `thenM` \ (expr',fvExpr) ->
 225     return (HsLet binds' expr', fvExpr)
 226
 227 rnExpr (HsDo do_or_lc stmts _)
 228   = do  { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
 229         ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
 230
 231 rnExpr (ExplicitList _ exps)
 232   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 233     return  (ExplicitList placeHolderType exps', fvs)
 234
 235 rnExpr (ExplicitPArr _ exps)
 236   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 237     return  (ExplicitPArr placeHolderType exps', fvs)
 238
 239 rnExpr (ExplicitTuple tup_args boxity)
 240   = do { checkTupleSection tup_args
 241        ; checkTupSize (length tup_args)
 242        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
 243        ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
 244   where
 245     rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
 246     rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
 247
 248 rnExpr (RecordCon con_id _ rbinds)
 249   = do  { conname <- lookupLocatedOccRn con_id
 250         ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
 251         ; return (RecordCon conname noPostTcExpr rbinds',
 252                   fvRbinds `addOneFV` unLoc conname) }
 253
 254 rnExpr (RecordUpd expr rbinds _ _ _)
 255   = do  { (expr', fvExpr) <- rnLExpr expr
 256         ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
 257         ; return (RecordUpd expr' rbinds' [] [] [],
 258                   fvExpr `plusFV` fvRbinds) }
 259
 260 rnExpr (ExprWithTySig expr pty)
 261   = do  { (pty', fvTy) <- rnHsTypeFVs doc pty
 262         ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
 263                              rnLExpr expr
 264         ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 265   where
 266     doc = text "In an expression type signature"
 267
 268 rnExpr (HsIf _ p b1 b2)
 269   = do { (p', fvP) <- rnLExpr p
 270        ; (b1', fvB1) <- rnLExpr b1
 271        ; (b2', fvB2) <- rnLExpr b2
 272        ; (mb_ite, fvITE) <- lookupIfThenElse
 273        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 274
 275 rnExpr (HsType a)
 276   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 277     return (HsType t, fvT)
 278   where
 279     doc = text "In a type argument"
 280
 281 rnExpr (ArithSeq _ seq)
 282   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 283     return (ArithSeq noPostTcExpr new_seq, fvs)
 284
 285 rnExpr (PArrSeq _ seq)
 286   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 287     return (PArrSeq noPostTcExpr new_seq, fvs)
 288 \end{code}
 289
 290 These three are pattern syntax appearing in expressions.
 291 Since all the symbols are reservedops we can simply reject them.
 292 We return a (bogus) EWildPat in each case.
 293
 294 \begin{code}
 295 rnExpr e@EWildPat      = patSynErr e
 296 rnExpr e@(EAsPat {})   = patSynErr e
 297 rnExpr e@(EViewPat {}) = patSynErr e
 298 rnExpr e@(ELazyPat {}) = patSynErr e
 299 \end{code}
 300
 301 %************************************************************************
 302 %*                                                                      *
 303         Arrow notation
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 \begin{code}
 308 rnExpr (HsProc pat body)
 309   = newArrowScope $
 310     rnPat ProcExpr pat $ \ pat' ->
 311     rnCmdTop body                `thenM` \ (body',fvBody) ->
 312     return (HsProc pat' body', fvBody)
 313
 314 rnExpr (HsArrApp arrow arg _ ho rtl)
 315   = select_arrow_scope (rnLExpr arrow)  `thenM` \ (arrow',fvArrow) ->
 316     rnLExpr arg                         `thenM` \ (arg',fvArg) ->
 317     return (HsArrApp arrow' arg' placeHolderType ho rtl,
 318              fvArrow `plusFV` fvArg)
 319   where
 320     select_arrow_scope tc = case ho of
 321         HsHigherOrderApp -> tc
 322         HsFirstOrderApp  -> escapeArrowScope tc
 323
 324 -- infix form
 325 rnExpr (HsArrForm op (Just _) [arg1, arg2])
 326   = escapeArrowScope (rnLExpr op)
 327                         `thenM` \ (op',fv_op) ->
 328     let L _ (HsVar op_name) = op' in
 329     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
 330     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
 331
 332         -- Deal with fixity
 333
 334     lookupFixityRn op_name              `thenM` \ fixity ->
 335     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e ->
 336
 337     return (final_e,
 338               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
 339
 340 rnExpr (HsArrForm op fixity cmds)
 341   = escapeArrowScope (rnLExpr op)       `thenM` \ (op',fvOp) ->
 342     rnCmdArgs cmds                      `thenM` \ (cmds',fvCmds) ->
 343     return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
 344
 345 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 346         -- HsWrap
 347
 348 ----------------------
 349 -- See Note [Parsing sections] in Parser.y.pp
 350 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 351 rnSection section@(SectionR op expr)
 352   = do  { (op', fvs_op)     <- rnLExpr op
 353         ; (expr', fvs_expr) <- rnLExpr expr
 354         ; checkSectionPrec InfixR section op' expr'
 355         ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
 356
 357 rnSection section@(SectionL expr op)
 358   = do  { (expr', fvs_expr) <- rnLExpr expr
 359         ; (op', fvs_op)     <- rnLExpr op
 360         ; checkSectionPrec InfixL section op' expr'
 361         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
 362
 363 rnSection other = pprPanic "rnSection" (ppr other)
 364 \end{code}
 365
 366 %************************************************************************
 367 %*                                                                      *
 368         Records
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
 374              -> RnM (HsRecordBinds Name, FreeVars)
 375 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
 376   = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
 377        ; (flds', fvss) <- mapAndUnzipM rn_field flds
 378        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
 379                  fvs `plusFV` plusFVs fvss) }
 380   where
 381     rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
 382                       ; return (fld { hsRecFieldArg = arg' }, fvs) }
 383 \end{code}
 384
 385
 386 %************************************************************************
 387 %*                                                                      *
 388         Arrow commands
 389 %*                                                                      *
 390 %************************************************************************
 391
 392 \begin{code}
 393 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
 394 rnCmdArgs [] = return ([], emptyFVs)
 395 rnCmdArgs (arg:args)
 396   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
 397     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
 398     return (arg':args', fvArg `plusFV` fvArgs)
 399
 400 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
 401 rnCmdTop = wrapLocFstM rnCmdTop'
 402  where
 403   rnCmdTop' (HsCmdTop cmd _ _ _)
 404    = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
 405      let
 406         cmd_names = [arrAName, composeAName, firstAName] ++
 407                     nameSetToList (methodNamesCmd (unLoc cmd'))
 408      in
 409         -- Generate the rebindable syntax for the monad
 410      lookupSyntaxTable cmd_names        `thenM` \ (cmd_names', cmd_fvs) ->
 411
 412      return (HsCmdTop cmd' [] placeHolderType cmd_names',
 413              fvCmd `plusFV` cmd_fvs)
 414
 415 ---------------------------------------------------
 416 -- convert OpApp's in a command context to HsArrForm's
 417
 418 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
 419 convertOpFormsLCmd = fmap convertOpFormsCmd
 420
 421 convertOpFormsCmd :: HsCmd id -> HsCmd id
 422
 423 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
 424 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
 425 convertOpFormsCmd (OpApp c1 op fixity c2)
 426   = let
 427         arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
 428         arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
 429     in
 430     HsArrForm op (Just fixity) [arg1, arg2]
 431
 432 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 433
 434 convertOpFormsCmd (HsCase exp matches)
 435   = HsCase exp (convertOpFormsMatch matches)
 436
 437 convertOpFormsCmd (HsIf f exp c1 c2)
 438   = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 439
 440 convertOpFormsCmd (HsLet binds cmd)
 441   = HsLet binds (convertOpFormsLCmd cmd)
 442
 443 convertOpFormsCmd (HsDo ctxt stmts ty)
 444   = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty
 445
 446 -- Anything else is unchanged.  This includes HsArrForm (already done),
 447 -- things with no sub-commands, and illegal commands (which will be
 448 -- caught by the type checker)
 449 convertOpFormsCmd c = c
 450
 451 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
 452 convertOpFormsStmt (BindStmt pat cmd _ _)
 453   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
 454 convertOpFormsStmt (ExprStmt cmd _ _ _)
 455   = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
 456 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
 457   = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
 458 convertOpFormsStmt stmt = stmt
 459
 460 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
 461 convertOpFormsMatch (MatchGroup ms ty)
 462   = MatchGroup (map (fmap convert) ms) ty
 463  where convert (Match pat mty grhss)
 464           = Match pat mty (convertOpFormsGRHSs grhss)
 465
 466 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
 467 convertOpFormsGRHSs (GRHSs grhss binds)
 468   = GRHSs (map convertOpFormsGRHS grhss) binds
 469
 470 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
 471 convertOpFormsGRHS = fmap convert
 472  where
 473    convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
 474
 475 ---------------------------------------------------
 476 type CmdNeeds = FreeVars        -- Only inhabitants are
 477                                 --      appAName, choiceAName, loopAName
 478
 479 -- find what methods the Cmd needs (loop, choice, apply)
 480 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
 481 methodNamesLCmd = methodNamesCmd . unLoc
 482
 483 methodNamesCmd :: HsCmd Name -> CmdNeeds
 484
 485 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
 486   = emptyFVs
 487 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
 488   = unitFV appAName
 489 methodNamesCmd (HsArrForm {}) = emptyFVs
 490
 491 methodNamesCmd (HsPar c) = methodNamesLCmd c
 492
 493 methodNamesCmd (HsIf _ _ c1 c2)
 494   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 495
 496 methodNamesCmd (HsLet _ c)      = methodNamesLCmd c
 497 methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
 498 methodNamesCmd (HsApp c _)      = methodNamesLCmd c
 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 (LastStmt cmd _)                 = methodNamesLCmd cmd
 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 (TransStmt {})                   = emptyFVs
 542    -- ParStmt and TransStmt 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         ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
 623         ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
 624
 625 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 626 \end{code}
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsubsection{@Stmt@s: in @do@ expressions}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
 636         -> ([Name] -> RnM (thing, FreeVars))
 637         -> RnM (([LStmt Name], thing), FreeVars)
 638 -- Variables bound by the Stmts, and mentioned in thing_inside,
 639 -- do not appear in the result FreeVars
 640
 641 rnStmts ctxt [] thing_inside
 642   = do { checkEmptyStmts ctxt
 643        ; (thing, fvs) <- thing_inside []
 644        ; return (([], thing), fvs) }
 645
 646 rnStmts MDoExpr stmts thing_inside    -- Deal with mdo
 647   = -- Behave like do { rec { ...all but last... }; last }
 648     do { ((stmts1, (stmts2, thing)), fvs)
 649            <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
 650               do { last_stmt' <- checkLastStmt MDoExpr last_stmt
 651                  ; rnStmt MDoExpr last_stmt' thing_inside }
 652         ; return (((stmts1 ++ stmts2), thing), fvs) }
 653   where
 654     Just (all_but_last, last_stmt) = snocView stmts
 655
 656 rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
 657   | null lstmts
 658   = setSrcSpan loc $
 659     do { lstmt' <- checkLastStmt ctxt lstmt
 660        ; rnStmt ctxt lstmt' thing_inside }
 661
 662   | otherwise
 663   = do { ((stmts1, (stmts2, thing)), fvs)
 664             <- setSrcSpan loc                         $
 665                do { checkStmt ctxt lstmt
 666                   ; rnStmt ctxt lstmt    $ \ bndrs1 ->
 667                     rnStmts ctxt lstmts  $ \ bndrs2 ->
 668                     thing_inside (bndrs1 ++ bndrs2) }
 669         ; return (((stmts1 ++ stmts2), thing), fvs) }
 670
 671 ----------------------
 672 rnStmt :: HsStmtContext Name
 673        -> LStmt RdrName
 674        -> ([Name] -> RnM (thing, FreeVars))
 675        -> RnM (([LStmt Name], thing), FreeVars)
 676 -- Variables bound by the Stmt, and mentioned in thing_inside,
 677 -- do not appear in the result FreeVars
 678
 679 rnStmt _ (L loc (LastStmt expr _)) thing_inside
 680   = do  { (expr', fv_expr) <- rnLExpr expr
 681         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
 682         ; (thing, fvs3)    <- thing_inside []
 683         ; return (([L loc (LastStmt expr' ret_op)], thing),
 684                   fv_expr `plusFV` fvs1 `plusFV` fvs3) }
 685
 686 rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
 687   = do  { (expr', fv_expr) <- rnLExpr expr
 688         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
 689         ; (guard_op, fvs2) <- if isMonadCompExpr ctxt
 690                                  then lookupSyntaxName guardMName
 691                                  else return (noSyntaxExpr, emptyFVs)
 692         ; (thing, fvs3)    <- thing_inside []
 693         ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
 694                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 695
 696 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
 697   = do  { (expr', fv_expr) <- rnLExpr expr
 698                 -- The binders do not scope over the expression
 699         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 700         ; (fail_op, fvs2) <- lookupSyntaxName failMName
 701         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 702         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
 703         ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
 704                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 705        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 706         -- but it does not matter because the names are unique
 707
 708 rnStmt _ (L loc (LetStmt binds)) thing_inside
 709   = do  { rnLocalBindsAndThen binds $ \binds' -> do
 710         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
 711         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
 712
 713 rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 714   = do  {
 715         -- Step1: Bring all the binders of the mdo into scope
 716         -- (Remember that this also removes the binders from the
 717         -- finally-returned free-vars.)
 718         -- And rename each individual stmt, making a
 719         -- singleton segment.  At this stage the FwdRefs field
 720         -- isn't finished: it's empty for all except a BindStmt
 721         -- for which it's the fwd refs within the bind itself
 722         -- (This set may not be empty, because we're in a recursive
 723         -- context.)
 724         ; rnRecStmtsAndThen rec_stmts   $ \ segs -> do
 725
 726         { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
 727                                             emptyNameSet segs
 728         ; (thing, fvs_later) <- thing_inside bndrs
 729         ; (return_op, fvs1)  <- lookupSyntaxName returnMName
 730         ; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
 731         ; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
 732         ; let
 733                 -- Step 2: Fill in the fwd refs.
 734                 --         The segments are all singletons, but their fwd-ref
 735                 --         field mentions all the things used by the segment
 736                 --         that are bound after their use
 737             segs_w_fwd_refs          = addFwdRefs segs
 738
 739                 -- Step 3: Group together the segments to make bigger segments
 740                 --         Invariant: in the result, no segment uses a variable
 741                 --                    bound in a later segment
 742             grouped_segs = glomSegments segs_w_fwd_refs
 743
 744                 -- Step 4: Turn the segments into Stmts
 745                 --         Use RecStmt when and only when there are fwd refs
 746                 --         Also gather up the uses from the end towards the
 747                 --         start, so we can tell the RecStmt which things are
 748                 --         used 'after' the RecStmt
 749             empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
 750                                           , recS_mfix_fn = mfix_op
 751                                           , recS_bind_fn = bind_op }
 752             (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
 753
 754         ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 755
 756 rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
 757   = do  { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
 758               then (,,) <$> lookupSyntaxName mzipName
 759                         <*> lookupSyntaxName bindMName
 760                         <*> lookupSyntaxName returnMName
 761               else return ( (noSyntaxExpr, emptyFVs)
 762                           , (noSyntaxExpr, emptyFVs)
 763                           , (noSyntaxExpr, emptyFVs) )
 764         ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
 765         ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
 766                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 767
 768 rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
 769                               , trS_using = using })) thing_inside
 770   = do { -- Rename the 'using' expression in the context before the transform is begun
 771          let implicit_name | isMonadCompExpr ctxt = groupMName
 772                            | otherwise            = groupWithName
 773        ; (using', fvs1) <- case form of
 774                              GroupFormB -> do { (e,fvs) <- lookupSyntaxName implicit_name
 775                                                ; return (noLoc e, fvs) }
 776                              _          -> rnLExpr using
 777
 778          -- Rename the stmts and the 'by' expression
 779          -- Keep track of the variables mentioned in the 'by' expression
 780        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 781              <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 782                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 783                    ; (thing, fvs_thing) <- thing_inside bndrs
 784                    ; let fvs = fvs_by `plusFV` fvs_thing
 785                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 786                          -- The paper (Fig 5) has a bug here; we must treat any free varaible of
 787                          -- the "thing inside", **or of the by-expression**, as used
 788                    ; return ((by', used_bndrs, thing), fvs) }
 789
 790        -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
 791        ; (return_op, fvs3) <- lookupSyntaxName returnMName
 792        ; (bind_op,   fvs4) <- lookupSyntaxName bindMName
 793        ; (fmap_op,   fvs5) <- case form of
 794                                 ThenForm -> return (noSyntaxExpr, emptyFVs)
 795                                 _        -> lookupSyntaxName fmapName
 796
 797        ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3
 798                              `plusFV` fvs4 `plusFV` fvs5
 799              bndr_map = used_bndrs `zip` used_bndrs
 800              -- See Note [TransStmt binder map] in HsExpr
 801
 802        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
 803        ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
 804                                     , trS_by = by', trS_using = using', trS_form = form
 805                                     , trS_ret = return_op, trS_bind = bind_op
 806                                     , trS_fmap = fmap_op })], thing), all_fvs) }
 807
 808 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
 809
 810 rnParallelStmts :: forall thing. HsStmtContext Name
 811                 -> [ParSeg RdrName]
 812                 -> ([Name] -> RnM (thing, FreeVars))
 813                 -> RnM (([ParSeg Name], thing), FreeVars)
 814 -- Note [Renaming parallel Stmts]
 815 rnParallelStmts ctxt segs thing_inside
 816   = do { orig_lcl_env <- getLocalRdrEnv
 817        ; rn_segs orig_lcl_env [] segs }
 818   where
 819     rn_segs :: LocalRdrEnv
 820             -> [Name] -> [ParSeg RdrName]
 821             -> RnM (([ParSeg Name], thing), FreeVars)
 822     rn_segs _ bndrs_so_far []
 823       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 824            ; mapM_ dupErr dups
 825            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 826            ; return (([], thing), fvs) }
 827
 828     rn_segs env bndrs_so_far ((stmts,_) : segs)
 829       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 830                     <- rnStmts ctxt stmts $ \ bndrs ->
 831                        setLocalRdrEnv env       $ do
 832                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 833                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 834                        ; return ((used_bndrs, segs', thing), fvs) }
 835
 836            ; let seg' = (stmts', used_bndrs)
 837            ; return ((seg':segs', thing), fvs) }
 838
 839     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 840     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
 841                     <+> quotes (ppr (head vs)))
 842 \end{code}
 843
 844 Note [Renaming parallel Stmts]
 845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 846 Renaming parallel statements is painful.  Given, say
 847      [ a+c | a <- as, bs <- bss
 848            | c <- bs, a <- ds ]
 849 Note that
 850   (a) In order to report "Defined by not used" about 'bs', we must rename
 851       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
 852
 853   (b) We want to report that 'a' is illegally bound in both branches
 854
 855   (c) The 'bs' in the second group must obviously not be captured by
 856       the binding in the first group
 857
 858 To satisfy (a) we nest the segements.
 859 To satisfy (b) we check for duplicates just before thing_inside.
 860 To satisfy (c) we reset the LocalRdrEnv each time.
 861
 862 %************************************************************************
 863 %*                                                                      *
 864 \subsubsection{mdo expressions}
 865 %*                                                                      *
 866 %************************************************************************
 867
 868 \begin{code}
 869 type FwdRefs = NameSet
 870 type Segment stmts = (Defs,
 871                       Uses,     -- May include defs
 872                       FwdRefs,  -- A subset of uses that are
 873                                 --   (a) used before they are bound in this segment, or
 874                                 --   (b) used here, and bound in subsequent segments
 875                       stmts)    -- Either Stmt or [Stmt]
 876
 877
 878 -- wrapper that does both the left- and right-hand sides
 879 rnRecStmtsAndThen :: [LStmt RdrName]
 880                          -- assumes that the FreeVars returned includes
 881                          -- the FreeVars of the Segments
 882                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
 883                       -> RnM (a, FreeVars)
 884 rnRecStmtsAndThen s cont
 885   = do  { -- (A) Make the mini fixity env for all of the stmts
 886           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
 887
 888           -- (B) Do the LHSes
 889         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
 890
 891           --    ...bring them and their fixities into scope
 892         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
 893               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
 894               implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
 895         ; bindLocalNamesFV bound_names $
 896           addLocalFixities fix_env bound_names $ do
 897
 898           -- (C) do the right-hand-sides and thing-inside
 899         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
 900         ; (res, fvs) <- cont segs
 901         ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
 902         ; return (res, fvs) }}
 903
 904 -- get all the fixity decls in any Let stmt
 905 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
 906 collectRecStmtsFixities l =
 907     foldr (\ s -> \acc -> case s of
 908                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
 909                                 foldr (\ sig -> \ acc -> case sig of
 910                                                            (L loc (FixSig s)) -> (L loc s) : acc
 911                                                            _ -> acc) acc sigs
 912                             _ -> acc) [] l
 913
 914 -- left-hand sides
 915
 916 rn_rec_stmt_lhs :: MiniFixityEnv
 917                 -> LStmt RdrName
 918                    -- rename LHS, and return its FVs
 919                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 920                    -- so we don't bother to compute it accurately in the other cases
 921                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 922
 923 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
 924   = return [(L loc (ExprStmt expr a b c), emptyFVs)]
 925
 926 rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
 927   = return [(L loc (LastStmt expr a), emptyFVs)]
 928
 929 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
 930   = do
 931       -- should the ctxt be MDo instead?
 932       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 933       return [(L loc (BindStmt pat' expr a b),
 934                fv_pat)]
 935
 936 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
 937   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 938
 939 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 940     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
 941          return [(L loc (LetStmt (HsValBinds binds')),
 942                  -- Warning: this is bogus; see function invariant
 943                  emptyFVs
 944                  )]
 945
 946 -- XXX Do we need to do something with the return and mfix names?
 947 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
 948     = rn_rec_stmts_lhs fix_env stmts
 949
 950 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _))  -- Syntactically illegal in mdo
 951   = pprPanic "rn_rec_stmt" (ppr stmt)
 952
 953 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
 954   = pprPanic "rn_rec_stmt" (ppr stmt)
 955
 956 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 957   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 958
 959 rn_rec_stmts_lhs :: MiniFixityEnv
 960                  -> [LStmt RdrName]
 961                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
 962 rn_rec_stmts_lhs fix_env stmts
 963   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 964        ; let boundNames = collectLStmtsBinders (map fst ls)
 965             -- First do error checking: we need to check for dups here because we
 966             -- don't bind all of the variables from the Stmt at once
 967             -- with bindLocatedLocals.
 968        ; checkDupNames boundNames
 969        ; return ls }
 970
 971
 972 -- right-hand-sides
 973
 974 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
 975         -- Rename a Stmt that is inside a RecStmt (or mdo)
 976         -- Assumes all binders are already in scope
 977         -- Turns each stmt into a singleton Stmt
 978 rn_rec_stmt _ (L loc (LastStmt expr _)) _
 979   = do  { (expr', fv_expr) <- rnLExpr expr
 980         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
 981         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
 982                    L loc (LastStmt expr' ret_op))] }
 983
 984 rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
 985   = rnLExpr expr `thenM` \ (expr', fvs) ->
 986     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
 987     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 988               L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
 989
 990 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 991   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
 992     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
 993     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
 994     let
 995         bndrs = mkNameSet (collectPatBinders pat')
 996         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
 997     in
 998     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 999               L loc (BindStmt pat' expr' bind_op fail_op))]
1000
1001 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1002   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1003
1004 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1005   (binds', du_binds) <-
1006       -- fixities and unused are handled above in rnRecStmtsAndThen
1007       rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1008   return [(duDefs du_binds, allUses du_binds,
1009            emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1010
1011 -- no RecStmt case becuase they get flattened above when doing the LHSes
1012 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1013   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1014
1015 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1016   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1017
1018 rn_rec_stmt _ stmt@(L _ (TransStmt {})) _       -- Syntactically illegal in mdo
1019   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
1020
1021 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1022   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1023
1024 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1025 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1026                            return (concat segs_s)
1027
1028 ---------------------------------------------
1029 addFwdRefs :: [Segment a] -> [Segment a]
1030 -- So far the segments only have forward refs *within* the Stmt
1031 --      (which happens for bind:  x <- ...x...)
1032 -- This function adds the cross-seg fwd ref info
1033
1034 addFwdRefs pairs
1035   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1036   where
1037     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1038         = (new_seg : segs, all_defs)
1039         where
1040           new_seg = (defs, uses, new_fwds, stmts)
1041           all_defs = later_defs `unionNameSets` defs
1042           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1043                 -- Add the downstream fwd refs here
1044
1045 ----------------------------------------------------
1046 --      Glomming the singleton segments of an mdo into
1047 --      minimal recursive groups.
1048 --
1049 -- At first I thought this was just strongly connected components, but
1050 -- there's an important constraint: the order of the stmts must not change.
1051 --
1052 -- Consider
1053 --      mdo { x <- ...y...
1054 --            p <- z
1055 --            y <- ...x...
1056 --            q <- x
1057 --            z <- y
1058 --            r <- x }
1059 --
1060 -- Here, the first stmt mention 'y', which is bound in the third.
1061 -- But that means that the innocent second stmt (p <- z) gets caught
1062 -- up in the recursion.  And that in turn means that the binding for
1063 -- 'z' has to be included... and so on.
1064 --
1065 -- Start at the tail { r <- x }
1066 -- Now add the next one { z <- y ; r <- x }
1067 -- Now add one more     { q <- x ; z <- y ; r <- x }
1068 -- Now one more... but this time we have to group a bunch into rec
1069 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1070 -- Now one more, which we can add on without a rec
1071 --      { p <- z ;
1072 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1073 --        r <- x }
1074 -- Finally we add the last one; since it mentions y we have to
1075 -- glom it togeher with the first two groups
1076 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1077 --              q <- x ; z <- y } ;
1078 --        r <- x }
1079
1080 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1081
1082 glomSegments [] = []
1083 glomSegments ((defs,uses,fwds,stmt) : segs)
1084         -- Actually stmts will always be a singleton
1085   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1086   where
1087     segs'            = glomSegments segs
1088     (extras, others) = grab uses segs'
1089     (ds, us, fs, ss) = unzip4 extras
1090
1091     seg_defs  = plusFVs ds `plusFV` defs
1092     seg_uses  = plusFVs us `plusFV` uses
1093     seg_fwds  = plusFVs fs `plusFV` fwds
1094     seg_stmts = stmt : concat ss
1095
1096     grab :: NameSet             -- The client
1097          -> [Segment a]
1098          -> ([Segment a],       -- Needed by the 'client'
1099              [Segment a])       -- Not needed by the client
1100         -- The result is simply a split of the input
1101     grab uses dus
1102         = (reverse yeses, reverse noes)
1103         where
1104           (noes, yeses)           = span not_needed (reverse dus)
1105           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1106
1107
1108 ----------------------------------------------------
1109 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1110             -> [Segment [LStmt Name]]
1111             -> FreeVars                 -- Free vars used 'later'
1112             -> ([LStmt Name], FreeVars)
1113
1114 segsToStmts _ [] fvs_later = ([], fvs_later)
1115 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1116   = ASSERT( not (null ss) )
1117     (new_stmt : later_stmts, later_uses `plusFV` uses)
1118   where
1119     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1120     new_stmt | non_rec   = head ss
1121              | otherwise = L (getLoc (head ss)) rec_stmt
1122     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1123                               , recS_later_ids = nameSetToList used_later
1124                               , recS_rec_ids   = nameSetToList fwds }
1125     non_rec    = isSingleton ss && isEmptyNameSet fwds
1126     used_later = defs `intersectNameSet` later_uses
1127                                 -- The ones needed after the RecStmt
1128 \end{code}
1129
1130 %************************************************************************
1131 %*                                                                      *
1132 \subsubsection{Assertion utils}
1133 %*                                                                      *
1134 %************************************************************************
1135
1136 \begin{code}
1137 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1138 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1139
1140 mkAssertErrorExpr :: RnM (HsExpr Name)
1141 -- Return an expression for (assertError "Foo.hs:27")
1142 mkAssertErrorExpr
1143   = getSrcSpanM                         `thenM` \ sloc ->
1144     return (HsApp (L sloc (HsVar assertErrorName))
1145                   (L sloc (srcSpanPrimLit sloc)))
1146 \end{code}
1147
1148 Note [Adding the implicit parameter to 'assert']
1149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1151 By doing this in the renamer we allow the typechecker to just see the
1152 expanded application and do the right thing. But it's not really
1153 the Right Thing because there's no way to "undo" if you want to see
1154 the original source code.  We'll have fix this in due course, when
1155 we care more about being able to reconstruct the exact original
1156 program.
1157
1158 %************************************************************************
1159 %*                                                                      *
1160 \subsubsection{Errors}
1161 %*                                                                      *
1162 %************************************************************************
1163
1164 \begin{code}
1165 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1166 -- We've seen an empty sequence of Stmts... is that ok?
1167 checkEmptyStmts ctxt
1168   = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1169
1170 okEmpty :: HsStmtContext a -> Bool
1171 okEmpty (PatGuard {}) = True
1172 okEmpty _             = False
1173
1174 emptyErr :: HsStmtContext Name -> SDoc
1175 emptyErr (ParStmtCtxt {})       = ptext (sLit "Empty statement group in parallel comprehension")
1176 emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1177 emptyErr ctxt                   = ptext (sLit "Empty") <+> pprStmtContext ctxt
1178
1179 ----------------------
1180 checkLastStmt :: HsStmtContext Name
1181               -> LStmt RdrName
1182               -> RnM (LStmt RdrName)
1183 checkLastStmt ctxt lstmt@(L loc stmt)
1184   = case ctxt of
1185       ListComp  -> check_comp
1186       MonadComp -> check_comp
1187       PArrComp  -> check_comp
1188       DoExpr    -> check_do
1189       MDoExpr   -> check_do
1190       _         -> check_other
1191   where
1192     check_do    -- Expect ExprStmt, and change it to LastStmt
1193       = case stmt of
1194           ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
1195           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
1196                                              -- LastStmt directly (unlike the parser)
1197           _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1198     last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1199                   <+> ptext (sLit "must be an expression"))
1200
1201     check_comp  -- Expect LastStmt; this should be enforced by the parser!
1202       = case stmt of
1203           LastStmt {} -> return lstmt
1204           _           -> pprPanic "checkLastStmt" (ppr lstmt)
1205
1206     check_other -- Behave just as if this wasn't the last stmt
1207       = do { checkStmt ctxt lstmt; return lstmt }
1208
1209 -- Checking when a particular Stmt is ok
1210 checkStmt :: HsStmtContext Name
1211           -> LStmt RdrName
1212           -> RnM ()
1213 checkStmt ctxt (L _ stmt)
1214   = do { dflags <- getDOpts
1215        ; case okStmt dflags ctxt stmt of
1216            Nothing    -> return ()
1217            Just extra -> addErr (msg $$ extra) }
1218   where
1219    msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1220              , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1221
1222 pprStmtCat :: Stmt a -> SDoc
1223 pprStmtCat (TransStmt {})     = ptext (sLit "transform")
1224 pprStmtCat (LastStmt {})      = ptext (sLit "return expression")
1225 pprStmtCat (ExprStmt {})      = ptext (sLit "exprssion")
1226 pprStmtCat (BindStmt {})      = ptext (sLit "binding")
1227 pprStmtCat (LetStmt {})       = ptext (sLit "let")
1228 pprStmtCat (RecStmt {})       = ptext (sLit "rec")
1229 pprStmtCat (ParStmt {})       = ptext (sLit "parallel")
1230
1231 ------------
1232 isOK, notOK :: Maybe SDoc
1233 isOK  = Nothing
1234 notOK = Just empty
1235
1236 okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name
1237                              -> Stmt RdrName -> Maybe SDoc
1238 -- Return Nothing if OK, (Just extra) if not ok
1239 -- The "extra" is an SDoc that is appended to an generic error message
1240 okStmt _ (PatGuard {}) stmt
1241   = case stmt of
1242       ExprStmt {} -> isOK
1243       BindStmt {} -> isOK
1244       LetStmt {}  -> isOK
1245       _           -> notOK
1246
1247 okStmt dflags (ParStmtCtxt ctxt) stmt
1248   = case stmt of
1249       LetStmt (HsIPBinds {}) -> notOK
1250       _                      -> okStmt dflags ctxt stmt
1251
1252 okStmt dflags (TransformStmtCtxt ctxt) stmt
1253   = okStmt dflags ctxt stmt
1254
1255 okStmt dflags ctxt stmt
1256   | isDoExpr       ctxt = okDoStmt   dflags ctxt stmt
1257   | isListCompExpr ctxt = okCompStmt dflags ctxt stmt
1258   | otherwise           = pprPanic "okStmt" (pprStmtContext ctxt)
1259
1260 ----------------
1261 okDoStmt dflags _ stmt
1262   = case stmt of
1263        RecStmt {}
1264          | Opt_DoRec `xopt` dflags -> isOK
1265          | otherwise -> Just (ptext (sLit "Use -XDoRec"))
1266        BindStmt {} -> isOK
1267        LetStmt {}  -> isOK
1268        ExprStmt {} -> isOK
1269        _           -> notOK
1270
1271
1272 ----------------
1273 okCompStmt dflags _ stmt
1274   = case stmt of
1275        BindStmt {} -> isOK
1276        LetStmt {}  -> isOK
1277        ExprStmt {} -> isOK
1278        ParStmt {}
1279          | Opt_ParallelListComp `xopt` dflags -> isOK
1280          | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1281        TransStmt {}
1282          | Opt_TransformListComp `xopt` dflags -> isOK
1283          | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1284        LastStmt {} -> notOK
1285        RecStmt {}  -> notOK
1286
1287 ---------
1288 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1289 checkTupleSection args
1290   = do  { tuple_section <- xoptM Opt_TupleSections
1291         ; checkErr (all tupArgPresent args || tuple_section) msg }
1292   where
1293     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1294
1295 ---------
1296 sectionErr :: HsExpr RdrName -> SDoc
1297 sectionErr expr
1298   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1299        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1300
1301 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1302 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1303                                 nest 4 (ppr e)])
1304                  ; return (EWildPat, emptyFVs) }
1305
1306 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1307 badIpBinds what binds
1308   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1309          2 (ppr binds)
1310 \end{code}