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