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