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 (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         -> ([Name] -> 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 ctxt [] thing_inside
 643   = do { checkEmptyStmts ctxt
 644        ; (thing, fvs) <- thing_inside []
 645        ; return (([], thing), fvs) }
 646
 647 rnStmts MDoExpr stmts thing_inside    -- Deal with mdo
 648   = -- Behave like do { rec { ...all but last... }; last }
 649     do { ((stmts1, (stmts2, thing)), fvs)
 650            <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
 651               do { last_stmt' <- checkLastStmt MDoExpr last_stmt
 652                  ; rnStmt MDoExpr last_stmt' thing_inside }
 653         ; return (((stmts1 ++ stmts2), thing), fvs) }
 654   where
 655     Just (all_but_last, last_stmt) = snocView stmts
 656
 657 rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
 658   | null lstmts
 659   = setSrcSpan loc $
 660     do { lstmt' <- checkLastStmt ctxt lstmt
 661        ; rnStmt ctxt lstmt' thing_inside }
 662
 663   | otherwise
 664   = do { ((stmts1, (stmts2, thing)), fvs)
 665             <- setSrcSpan loc                         $
 666                do { checkStmt ctxt lstmt
 667                   ; rnStmt ctxt lstmt    $ \ bndrs1 ->
 668                     rnStmts ctxt lstmts  $ \ bndrs2 ->
 669                     thing_inside (bndrs1 ++ bndrs2) }
 670         ; return (((stmts1 ++ stmts2), thing), fvs) }
 671
 672 ----------------------
 673 rnStmt :: HsStmtContext Name
 674        -> LStmt RdrName
 675        -> ([Name] -> RnM (thing, FreeVars))
 676        -> RnM (([LStmt Name], thing), FreeVars)
 677 -- Variables bound by the Stmt, and mentioned in thing_inside,
 678 -- do not appear in the result FreeVars
 679
 680 rnStmt _ (L loc (LastStmt expr _)) thing_inside
 681   = do  { (expr', fv_expr) <- rnLExpr expr
 682         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
 683         ; (thing, fvs3)    <- thing_inside []
 684         ; return (([L loc (LastStmt expr' ret_op)], thing),
 685                   fv_expr `plusFV` fvs1 `plusFV` fvs3) }
 686
 687 rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
 688   = do  { (expr', fv_expr) <- rnLExpr expr
 689         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
 690         ; (guard_op, fvs2) <- if isMonadCompExpr ctxt
 691                                  then lookupSyntaxName guardMName
 692                                  else return (noSyntaxExpr, emptyFVs)
 693         ; (thing, fvs3)    <- thing_inside []
 694         ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
 695                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 696
 697 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
 698   = do  { (expr', fv_expr) <- rnLExpr expr
 699                 -- The binders do not scope over the expression
 700         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 701         ; (fail_op, fvs2) <- lookupSyntaxName failMName
 702         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 703         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
 704         ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
 705                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 706        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 707         -- but it does not matter because the names are unique
 708
 709 rnStmt _ (L loc (LetStmt binds)) thing_inside
 710   = do  { rnLocalBindsAndThen binds $ \binds' -> do
 711         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
 712         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
 713
 714 rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 715   = do  {
 716         -- Step1: Bring all the binders of the mdo into scope
 717         -- (Remember that this also removes the binders from the
 718         -- finally-returned free-vars.)
 719         -- And rename each individual stmt, making a
 720         -- singleton segment.  At this stage the FwdRefs field
 721         -- isn't finished: it's empty for all except a BindStmt
 722         -- for which it's the fwd refs within the bind itself
 723         -- (This set may not be empty, because we're in a recursive
 724         -- context.)
 725         ; rnRecStmtsAndThen rec_stmts   $ \ segs -> do
 726
 727         { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
 728                                             emptyNameSet segs
 729         ; (thing, fvs_later) <- thing_inside bndrs
 730         ; (return_op, fvs1)  <- lookupSyntaxName returnMName
 731         ; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
 732         ; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
 733         ; let
 734                 -- Step 2: Fill in the fwd refs.
 735                 --         The segments are all singletons, but their fwd-ref
 736                 --         field mentions all the things used by the segment
 737                 --         that are bound after their use
 738             segs_w_fwd_refs          = addFwdRefs segs
 739
 740                 -- Step 3: Group together the segments to make bigger segments
 741                 --         Invariant: in the result, no segment uses a variable
 742                 --                    bound in a later segment
 743             grouped_segs = glomSegments segs_w_fwd_refs
 744
 745                 -- Step 4: Turn the segments into Stmts
 746                 --         Use RecStmt when and only when there are fwd refs
 747                 --         Also gather up the uses from the end towards the
 748                 --         start, so we can tell the RecStmt which things are
 749                 --         used 'after' the RecStmt
 750             empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
 751                                           , recS_mfix_fn = mfix_op
 752                                           , recS_bind_fn = bind_op }
 753             (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
 754
 755         ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 756
 757 rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
 758   = do  { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt
 759               then (,,) <$> lookupSyntaxName mzipName
 760                         <*> lookupSyntaxName bindMName
 761                         <*> lookupSyntaxName returnMName
 762               else return ( (noSyntaxExpr, emptyFVs)
 763                           , (noSyntaxExpr, emptyFVs)
 764                           , (noSyntaxExpr, emptyFVs) )
 765         ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
 766         ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
 767                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 768
 769 rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
 770   = do { (using', fvs1) <- rnLExpr using
 771
 772        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 773              <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 774                 do { (by', fvs_by) <- case by of
 775                                         Nothing -> return (Nothing, emptyFVs)
 776                                         Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
 777                    ; (thing, fvs_thing) <- thing_inside bndrs
 778                    ; let fvs        = fvs_by `plusFV` fvs_thing
 779                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 780                          -- The paper (Fig 5) has a bug here; we must treat any free varaible of
 781                          -- the "thing inside", **or of the by-expression**, as used
 782                    ; return ((by', used_bndrs, thing), fvs) }
 783
 784        -- Lookup `(>>=)` and `fail` for monad comprehensions
 785        ; ((return_op, fvs3), (bind_op, fvs4)) <-
 786              if isMonadCompExpr ctxt
 787                 then (,) <$> lookupSyntaxName returnMName
 788                          <*> lookupSyntaxName bindMName
 789                 else return ( (noSyntaxExpr, emptyFVs)
 790                             , (noSyntaxExpr, emptyFVs) )
 791
 792        ; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
 793                  fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 794
 795 rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit
 796                               , grpS_using = using })) thing_inside
 797   = do { -- Rename the 'using' expression in the context before the transform is begun
 798          let implicit_name | isMonadCompExpr ctxt = groupMName
 799                            | otherwise            = groupWithName
 800        ; (using', fvs1) <- if explicit
 801                            then rnLExpr using
 802                            else do { (e,fvs) <- lookupSyntaxName implicit_name
 803                                    ; return (noLoc e, fvs) }
 804
 805          -- Rename the stmts and the 'by' expression
 806          -- Keep track of the variables mentioned in the 'by' expression
 807        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 808              <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 809                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 810                    ; (thing, fvs_thing) <- thing_inside bndrs
 811                    ; let fvs = fvs_by `plusFV` fvs_thing
 812                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 813                    ; return ((by', used_bndrs, thing), fvs) }
 814
 815        -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
 816        ; ((return_op, fvs3), (bind_op, fvs4), (fmap_op, fvs5)) <-
 817              if isMonadCompExpr ctxt
 818                 then (,,) <$> lookupSyntaxName returnMName
 819                           <*> lookupSyntaxName bindMName
 820                           <*> lookupSyntaxName fmapName
 821                 else return ( (noSyntaxExpr, emptyFVs)
 822                             , (noSyntaxExpr, emptyFVs)
 823                             , (noSyntaxExpr, emptyFVs) )
 824
 825        ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4
 826                              `plusFV` fvs5
 827              bndr_map = used_bndrs `zip` used_bndrs
 828              -- See Note [GroupStmt binder map] in HsExpr
 829
 830        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
 831        ; return (([L loc (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bndr_map
 832                                     , grpS_by = by', grpS_using = using', grpS_explicit = explicit
 833                                     , grpS_ret = return_op, grpS_bind = bind_op
 834                                     , grpS_fmap = fmap_op })], thing), all_fvs) }
 835
 836 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
 837
 838 rnParallelStmts :: forall thing. HsStmtContext Name
 839                 -> [ParSeg RdrName]
 840                 -> ([Name] -> RnM (thing, FreeVars))
 841                 -> RnM (([ParSeg Name], thing), FreeVars)
 842 -- Note [Renaming parallel Stmts]
 843 rnParallelStmts ctxt segs thing_inside
 844   = do { orig_lcl_env <- getLocalRdrEnv
 845        ; rn_segs orig_lcl_env [] segs }
 846   where
 847     rn_segs :: LocalRdrEnv
 848             -> [Name] -> [ParSeg RdrName]
 849             -> RnM (([ParSeg Name], thing), FreeVars)
 850     rn_segs _ bndrs_so_far []
 851       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 852            ; mapM_ dupErr dups
 853            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 854            ; return (([], thing), fvs) }
 855
 856     rn_segs env bndrs_so_far ((stmts,_) : segs)
 857       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 858                     <- rnStmts ctxt stmts $ \ bndrs ->
 859                        setLocalRdrEnv env       $ do
 860                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 861                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 862                        ; return ((used_bndrs, segs', thing), fvs) }
 863
 864            ; let seg' = (stmts', used_bndrs)
 865            ; return ((seg':segs', thing), fvs) }
 866
 867     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 868     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
 869                     <+> quotes (ppr (head vs)))
 870 \end{code}
 871
 872 Note [Renaming parallel Stmts]
 873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 874 Renaming parallel statements is painful.  Given, say
 875      [ a+c | a <- as, bs <- bss
 876            | c <- bs, a <- ds ]
 877 Note that
 878   (a) In order to report "Defined by not used" about 'bs', we must rename
 879       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
 880
 881   (b) We want to report that 'a' is illegally bound in both branches
 882
 883   (c) The 'bs' in the second group must obviously not be captured by
 884       the binding in the first group
 885
 886 To satisfy (a) we nest the segements.
 887 To satisfy (b) we check for duplicates just before thing_inside.
 888 To satisfy (c) we reset the LocalRdrEnv each time.
 889
 890 %************************************************************************
 891 %*                                                                      *
 892 \subsubsection{mdo expressions}
 893 %*                                                                      *
 894 %************************************************************************
 895
 896 \begin{code}
 897 type FwdRefs = NameSet
 898 type Segment stmts = (Defs,
 899                       Uses,     -- May include defs
 900                       FwdRefs,  -- A subset of uses that are
 901                                 --   (a) used before they are bound in this segment, or
 902                                 --   (b) used here, and bound in subsequent segments
 903                       stmts)    -- Either Stmt or [Stmt]
 904
 905
 906 -- wrapper that does both the left- and right-hand sides
 907 rnRecStmtsAndThen :: [LStmt RdrName]
 908                          -- assumes that the FreeVars returned includes
 909                          -- the FreeVars of the Segments
 910                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
 911                       -> RnM (a, FreeVars)
 912 rnRecStmtsAndThen s cont
 913   = do  { -- (A) Make the mini fixity env for all of the stmts
 914           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
 915
 916           -- (B) Do the LHSes
 917         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
 918
 919           --    ...bring them and their fixities into scope
 920         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
 921               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
 922               implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
 923         ; bindLocalNamesFV bound_names $
 924           addLocalFixities fix_env bound_names $ do
 925
 926           -- (C) do the right-hand-sides and thing-inside
 927         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
 928         ; (res, fvs) <- cont segs
 929         ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
 930         ; return (res, fvs) }}
 931
 932 -- get all the fixity decls in any Let stmt
 933 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
 934 collectRecStmtsFixities l =
 935     foldr (\ s -> \acc -> case s of
 936                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
 937                                 foldr (\ sig -> \ acc -> case sig of
 938                                                            (L loc (FixSig s)) -> (L loc s) : acc
 939                                                            _ -> acc) acc sigs
 940                             _ -> acc) [] l
 941
 942 -- left-hand sides
 943
 944 rn_rec_stmt_lhs :: MiniFixityEnv
 945                 -> LStmt RdrName
 946                    -- rename LHS, and return its FVs
 947                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 948                    -- so we don't bother to compute it accurately in the other cases
 949                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 950
 951 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
 952   = return [(L loc (ExprStmt expr a b c), emptyFVs)]
 953
 954 rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
 955   = return [(L loc (LastStmt expr a), emptyFVs)]
 956
 957 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
 958   = do
 959       -- should the ctxt be MDo instead?
 960       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 961       return [(L loc (BindStmt pat' expr a b),
 962                fv_pat)]
 963
 964 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
 965   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 966
 967 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 968     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
 969          return [(L loc (LetStmt (HsValBinds binds')),
 970                  -- Warning: this is bogus; see function invariant
 971                  emptyFVs
 972                  )]
 973
 974 -- XXX Do we need to do something with the return and mfix names?
 975 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
 976     = rn_rec_stmts_lhs fix_env stmts
 977
 978 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _))  -- Syntactically illegal in mdo
 979   = pprPanic "rn_rec_stmt" (ppr stmt)
 980
 981 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
 982   = pprPanic "rn_rec_stmt" (ppr stmt)
 983
 984 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))     -- Syntactically illegal in mdo
 985   = pprPanic "rn_rec_stmt" (ppr stmt)
 986
 987 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 988   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 989
 990 rn_rec_stmts_lhs :: MiniFixityEnv
 991                  -> [LStmt RdrName]
 992                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
 993 rn_rec_stmts_lhs fix_env stmts
 994   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 995        ; let boundNames = collectLStmtsBinders (map fst ls)
 996             -- First do error checking: we need to check for dups here because we
 997             -- don't bind all of the variables from the Stmt at once
 998             -- with bindLocatedLocals.
 999        ; checkDupNames boundNames
1000        ; return ls }
1001
1002
1003 -- right-hand-sides
1004
1005 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
1006         -- Rename a Stmt that is inside a RecStmt (or mdo)
1007         -- Assumes all binders are already in scope
1008         -- Turns each stmt into a singleton Stmt
1009 rn_rec_stmt _ (L loc (LastStmt expr _)) _
1010   = do  { (expr', fv_expr) <- rnLExpr expr
1011         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
1012         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
1013                    L loc (LastStmt expr' ret_op))] }
1014
1015 rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
1016   = rnLExpr expr `thenM` \ (expr', fvs) ->
1017     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
1018     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
1019               L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
1020
1021 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
1022   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
1023     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
1024     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
1025     let
1026         bndrs = mkNameSet (collectPatBinders pat')
1027         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1028     in
1029     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1030               L loc (BindStmt pat' expr' bind_op fail_op))]
1031
1032 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1033   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1034
1035 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1036   (binds', du_binds) <-
1037       -- fixities and unused are handled above in rnRecStmtsAndThen
1038       rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1039   return [(duDefs du_binds, allUses du_binds,
1040            emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1041
1042 -- no RecStmt case becuase they get flattened above when doing the LHSes
1043 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1044   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1045
1046 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1047   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1048
1049 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _   -- Syntactically illegal in mdo
1050   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1051
1052 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _       -- Syntactically illegal in mdo
1053   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1054
1055 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1056   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1057
1058 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1059 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1060                            return (concat segs_s)
1061
1062 ---------------------------------------------
1063 addFwdRefs :: [Segment a] -> [Segment a]
1064 -- So far the segments only have forward refs *within* the Stmt
1065 --      (which happens for bind:  x <- ...x...)
1066 -- This function adds the cross-seg fwd ref info
1067
1068 addFwdRefs pairs
1069   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1070   where
1071     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1072         = (new_seg : segs, all_defs)
1073         where
1074           new_seg = (defs, uses, new_fwds, stmts)
1075           all_defs = later_defs `unionNameSets` defs
1076           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1077                 -- Add the downstream fwd refs here
1078
1079 ----------------------------------------------------
1080 --      Glomming the singleton segments of an mdo into
1081 --      minimal recursive groups.
1082 --
1083 -- At first I thought this was just strongly connected components, but
1084 -- there's an important constraint: the order of the stmts must not change.
1085 --
1086 -- Consider
1087 --      mdo { x <- ...y...
1088 --            p <- z
1089 --            y <- ...x...
1090 --            q <- x
1091 --            z <- y
1092 --            r <- x }
1093 --
1094 -- Here, the first stmt mention 'y', which is bound in the third.
1095 -- But that means that the innocent second stmt (p <- z) gets caught
1096 -- up in the recursion.  And that in turn means that the binding for
1097 -- 'z' has to be included... and so on.
1098 --
1099 -- Start at the tail { r <- x }
1100 -- Now add the next one { z <- y ; r <- x }
1101 -- Now add one more     { q <- x ; z <- y ; r <- x }
1102 -- Now one more... but this time we have to group a bunch into rec
1103 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1104 -- Now one more, which we can add on without a rec
1105 --      { p <- z ;
1106 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1107 --        r <- x }
1108 -- Finally we add the last one; since it mentions y we have to
1109 -- glom it togeher with the first two groups
1110 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1111 --              q <- x ; z <- y } ;
1112 --        r <- x }
1113
1114 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1115
1116 glomSegments [] = []
1117 glomSegments ((defs,uses,fwds,stmt) : segs)
1118         -- Actually stmts will always be a singleton
1119   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1120   where
1121     segs'            = glomSegments segs
1122     (extras, others) = grab uses segs'
1123     (ds, us, fs, ss) = unzip4 extras
1124
1125     seg_defs  = plusFVs ds `plusFV` defs
1126     seg_uses  = plusFVs us `plusFV` uses
1127     seg_fwds  = plusFVs fs `plusFV` fwds
1128     seg_stmts = stmt : concat ss
1129
1130     grab :: NameSet             -- The client
1131          -> [Segment a]
1132          -> ([Segment a],       -- Needed by the 'client'
1133              [Segment a])       -- Not needed by the client
1134         -- The result is simply a split of the input
1135     grab uses dus
1136         = (reverse yeses, reverse noes)
1137         where
1138           (noes, yeses)           = span not_needed (reverse dus)
1139           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1140
1141
1142 ----------------------------------------------------
1143 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1144             -> [Segment [LStmt Name]]
1145             -> FreeVars                 -- Free vars used 'later'
1146             -> ([LStmt Name], FreeVars)
1147
1148 segsToStmts _ [] fvs_later = ([], fvs_later)
1149 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1150   = ASSERT( not (null ss) )
1151     (new_stmt : later_stmts, later_uses `plusFV` uses)
1152   where
1153     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1154     new_stmt | non_rec   = head ss
1155              | otherwise = L (getLoc (head ss)) rec_stmt
1156     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1157                               , recS_later_ids = nameSetToList used_later
1158                               , recS_rec_ids   = nameSetToList fwds }
1159     non_rec    = isSingleton ss && isEmptyNameSet fwds
1160     used_later = defs `intersectNameSet` later_uses
1161                                 -- The ones needed after the RecStmt
1162 \end{code}
1163
1164 %************************************************************************
1165 %*                                                                      *
1166 \subsubsection{Assertion utils}
1167 %*                                                                      *
1168 %************************************************************************
1169
1170 \begin{code}
1171 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1172 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1173
1174 mkAssertErrorExpr :: RnM (HsExpr Name)
1175 -- Return an expression for (assertError "Foo.hs:27")
1176 mkAssertErrorExpr
1177   = getSrcSpanM                         `thenM` \ sloc ->
1178     return (HsApp (L sloc (HsVar assertErrorName))
1179                   (L sloc (srcSpanPrimLit sloc)))
1180 \end{code}
1181
1182 Note [Adding the implicit parameter to 'assert']
1183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1184 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1185 By doing this in the renamer we allow the typechecker to just see the
1186 expanded application and do the right thing. But it's not really
1187 the Right Thing because there's no way to "undo" if you want to see
1188 the original source code.  We'll have fix this in due course, when
1189 we care more about being able to reconstruct the exact original
1190 program.
1191
1192 %************************************************************************
1193 %*                                                                      *
1194 \subsubsection{Errors}
1195 %*                                                                      *
1196 %************************************************************************
1197
1198 \begin{code}
1199 checkEmptyStmts :: HsStmtContext Name -> RnM ()
1200 -- We've seen an empty sequence of Stmts... is that ok?
1201 checkEmptyStmts ctxt
1202   = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
1203
1204 okEmpty :: HsStmtContext a -> Bool
1205 okEmpty (PatGuard {}) = True
1206 okEmpty _             = False
1207
1208 emptyErr :: HsStmtContext Name -> SDoc
1209 emptyErr (ParStmtCtxt {})       = ptext (sLit "Empty statement group in parallel comprehension")
1210 emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
1211 emptyErr ctxt                   = ptext (sLit "Empty") <+> pprStmtContext ctxt
1212
1213 ----------------------
1214 checkLastStmt :: HsStmtContext Name
1215               -> LStmt RdrName
1216               -> RnM (LStmt RdrName)
1217 checkLastStmt ctxt lstmt@(L loc stmt)
1218   = case ctxt of
1219       ListComp  -> check_comp
1220       MonadComp -> check_comp
1221       PArrComp  -> check_comp
1222       DoExpr    -> check_do
1223       MDoExpr   -> check_do
1224       _         -> check_other
1225   where
1226     check_do    -- Expect ExprStmt, and change it to LastStmt
1227       = case stmt of
1228           ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
1229           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
1230                                              -- LastStmt directly (unlike the parser)
1231           _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
1232     last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
1233                   <+> ptext (sLit "must be an expression"))
1234
1235     check_comp  -- Expect LastStmt; this should be enforced by the parser!
1236       = case stmt of
1237           LastStmt {} -> return lstmt
1238           _           -> pprPanic "checkLastStmt" (ppr lstmt)
1239
1240     check_other -- Behave just as if this wasn't the last stmt
1241       = do { checkStmt ctxt lstmt; return lstmt }
1242
1243 -- Checking when a particular Stmt is ok
1244 checkStmt :: HsStmtContext Name
1245           -> LStmt RdrName
1246           -> RnM ()
1247 checkStmt ctxt (L _ stmt)
1248   = do { dflags <- getDOpts
1249        ; case okStmt dflags ctxt stmt of
1250            Nothing    -> return ()
1251            Just extra -> addErr (msg $$ extra) }
1252   where
1253    msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
1254              , ptext (sLit "in") <+> pprAStmtContext ctxt ]
1255
1256 pprStmtCat :: Stmt a -> SDoc
1257 pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
1258 pprStmtCat (GroupStmt {})     = ptext (sLit "group")
1259 pprStmtCat (LastStmt {})      = ptext (sLit "return expression")
1260 pprStmtCat (ExprStmt {})      = ptext (sLit "exprssion")
1261 pprStmtCat (BindStmt {})      = ptext (sLit "binding")
1262 pprStmtCat (LetStmt {})       = ptext (sLit "let")
1263 pprStmtCat (RecStmt {})       = ptext (sLit "rec")
1264 pprStmtCat (ParStmt {})       = ptext (sLit "parallel")
1265
1266 ------------
1267 isOK, notOK :: Maybe SDoc
1268 isOK  = Nothing
1269 notOK = Just empty
1270
1271 okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name
1272                              -> Stmt RdrName -> Maybe SDoc
1273 -- Return Nothing if OK, (Just extra) if not ok
1274 -- The "extra" is an SDoc that is appended to an generic error message
1275 okStmt _ (PatGuard {}) stmt
1276   = case stmt of
1277       ExprStmt {} -> isOK
1278       BindStmt {} -> isOK
1279       LetStmt {}  -> isOK
1280       _           -> notOK
1281
1282 okStmt dflags (ParStmtCtxt ctxt) stmt
1283   = case stmt of
1284       LetStmt (HsIPBinds {}) -> notOK
1285       _                      -> okStmt dflags ctxt stmt
1286
1287 okStmt dflags (TransformStmtCtxt ctxt) stmt
1288   = okStmt dflags ctxt stmt
1289
1290 okStmt dflags ctxt stmt
1291   | isDoExpr       ctxt = okDoStmt   dflags ctxt stmt
1292   | isListCompExpr ctxt = okCompStmt dflags ctxt stmt
1293   | otherwise           = pprPanic "okStmt" (pprStmtContext ctxt)
1294
1295 ----------------
1296 okDoStmt dflags _ stmt
1297   = case stmt of
1298        RecStmt {}
1299          | Opt_DoRec `xopt` dflags -> isOK
1300          | otherwise -> Just (ptext (sLit "Use -XDoRec"))
1301        BindStmt {} -> isOK
1302        LetStmt {}  -> isOK
1303        ExprStmt {} -> isOK
1304        _           -> notOK
1305
1306
1307 ----------------
1308 okCompStmt dflags _ stmt
1309   = case stmt of
1310        BindStmt {} -> isOK
1311        LetStmt {}  -> isOK
1312        ExprStmt {} -> isOK
1313        ParStmt {}
1314          | Opt_ParallelListComp `xopt` dflags -> isOK
1315          | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
1316        TransformStmt {}
1317          | Opt_TransformListComp `xopt` dflags -> isOK
1318          | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1319        GroupStmt {}
1320          | Opt_TransformListComp `xopt` dflags -> isOK
1321          | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
1322        LastStmt {} -> notOK
1323        RecStmt {}  -> notOK
1324
1325 ---------
1326 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1327 checkTupleSection args
1328   = do  { tuple_section <- xoptM Opt_TupleSections
1329         ; checkErr (all tupArgPresent args || tuple_section) msg }
1330   where
1331     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1332
1333 ---------
1334 sectionErr :: HsExpr RdrName -> SDoc
1335 sectionErr expr
1336   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1337        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1338
1339 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1340 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1341                                 nest 4 (ppr e)])
1342                  ; return (EWildPat, emptyFVs) }
1343
1344 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1345 badIpBinds what binds
1346   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1347          2 (ppr binds)
1348 \end{code}