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