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