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 rnExpr (HsVar v)
 106   = do name           <- lookupOccRn v
 107        ignore_asserts <- doptM Opt_IgnoreAsserts
 108        finish_var ignore_asserts name
 109   where
 110     finish_var ignore_asserts name
 111         | ignore_asserts || not (name `hasKey` assertIdKey)
 112         = return (HsVar name, unitFV name)
 113         | otherwise
 114         = do { (e, fvs) <- mkAssertErrorExpr
 115              ; return (e, fvs `addOneFV` name) }
 116
 117 rnExpr (HsIPVar v)
 118   = newIPNameRn v               `thenM` \ name ->
 119     returnM (HsIPVar name, emptyFVs)
 120
 121 rnExpr (HsLit lit@(HsString s))
 122   = do {
 123          opt_OverloadedStrings <- doptM Opt_OverloadedStrings
 124        ; if opt_OverloadedStrings then
 125             rnExpr (HsOverLit (mkHsIsString s placeHolderType))
 126          else -- Same as below
 127             rnLit lit           `thenM_`
 128             returnM (HsLit lit, emptyFVs)
 129        }
 130
 131 rnExpr (HsLit lit)
 132   = rnLit lit           `thenM_`
 133     returnM (HsLit lit, emptyFVs)
 134
 135 rnExpr (HsOverLit lit)
 136   = rnOverLit lit               `thenM` \ (lit', fvs) ->
 137     returnM (HsOverLit lit', fvs)
 138
 139 rnExpr (HsApp fun arg)
 140   = rnLExpr fun         `thenM` \ (fun',fvFun) ->
 141     rnLExpr arg         `thenM` \ (arg',fvArg) ->
 142     returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
 143
 144 rnExpr (OpApp e1 op _ e2)
 145   = rnLExpr e1                          `thenM` \ (e1', fv_e1) ->
 146     rnLExpr e2                          `thenM` \ (e2', fv_e2) ->
 147     rnLExpr op                          `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) ->
 148
 149         -- Deal with fixity
 150         -- When renaming code synthesised from "deriving" declarations
 151         -- we used to avoid fixity stuff, but we can't easily tell any
 152         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
 153         -- should prevent bad things happening.
 154     lookupFixityRn op_name              `thenM` \ fixity ->
 155     mkOpAppRn e1' op' fixity e2'        `thenM` \ final_e ->
 156
 157     returnM (final_e,
 158               fv_e1 `plusFV` fv_op `plusFV` fv_e2)
 159
 160 rnExpr (NegApp e _)
 161   = rnLExpr e                   `thenM` \ (e', fv_e) ->
 162     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 163     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 164     returnM (final_e, fv_e `plusFV` fv_neg)
 165
 166 rnExpr (HsPar e)
 167   = rnLExpr e           `thenM` \ (e', fvs_e) ->
 168     returnM (HsPar e', fvs_e)
 169
 170 -- Template Haskell extensions
 171 -- Don't ifdef-GHCI them because we want to fail gracefully
 172 -- (not with an rnExpr crash) in a stage-1 compiler.
 173 rnExpr e@(HsBracket br_body)
 174   = checkTH e "bracket"         `thenM_`
 175     rnBracket br_body           `thenM` \ (body', fvs_e) ->
 176     returnM (HsBracket body', fvs_e)
 177
 178 rnExpr (HsSpliceE splice)
 179   = rnSplice splice             `thenM` \ (splice', fvs) ->
 180     returnM (HsSpliceE splice', fvs)
 181
 182 #ifndef GHCI
 183 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
 184 #else
 185 rnExpr (HsQuasiQuoteE qq)
 186   = rnQuasiQuote qq             `thenM` \ (qq', fvs_qq) ->
 187     runQuasiQuoteExpr qq'       `thenM` \ (L _ expr') ->
 188     rnExpr expr'                `thenM` \ (expr'', fvs_expr) ->
 189     returnM (expr'', fvs_qq `plusFV` fvs_expr)
 190 #endif  /* GHCI */
 191
 192 rnExpr section@(SectionL expr op)
 193   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 194     rnLExpr op                  `thenM` \ (op', fvs_op) ->
 195     checkSectionPrec InfixL section op' expr' `thenM_`
 196     returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 197
 198 rnExpr section@(SectionR op expr)
 199   = rnLExpr op                                  `thenM` \ (op',   fvs_op) ->
 200     rnLExpr expr                                        `thenM` \ (expr', fvs_expr) ->
 201     checkSectionPrec InfixR section op' expr'   `thenM_`
 202     returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 203
 204 rnExpr (HsCoreAnn ann expr)
 205   = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
 206     returnM (HsCoreAnn ann expr', fvs_expr)
 207
 208 rnExpr (HsSCC lbl expr)
 209   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 210     returnM (HsSCC lbl expr', fvs_expr)
 211 rnExpr (HsTickPragma info expr)
 212   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 213     returnM (HsTickPragma info expr', fvs_expr)
 214
 215 rnExpr (HsLam matches)
 216   = rnMatchGroup LambdaExpr matches     `thenM` \ (matches', fvMatch) ->
 217     returnM (HsLam matches', fvMatch)
 218
 219 rnExpr (HsCase expr matches)
 220   = rnLExpr expr                        `thenM` \ (new_expr, e_fvs) ->
 221     rnMatchGroup CaseAlt matches        `thenM` \ (new_matches, ms_fvs) ->
 222     returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
 223
 224 rnExpr (HsLet binds expr)
 225   = rnLocalBindsAndThen binds           $ \ binds' ->
 226     rnLExpr expr                         `thenM` \ (expr',fvExpr) ->
 227     returnM (HsLet binds' expr', fvExpr)
 228
 229 rnExpr (HsDo do_or_lc stmts body _)
 230   = do  { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
 231                                     rnLExpr body
 232         ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
 233
 234 rnExpr (ExplicitList _ exps)
 235   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 236     returnM  (ExplicitList placeHolderType exps', fvs)
 237
 238 rnExpr (ExplicitPArr _ exps)
 239   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 240     returnM  (ExplicitPArr placeHolderType exps', fvs)
 241
 242 rnExpr (ExplicitTuple exps boxity)
 243   = checkTupSize (length exps)                  `thenM_`
 244     rnExprs exps                                `thenM` \ (exps', fvs) ->
 245     returnM (ExplicitTuple exps' boxity, fvs)
 246
 247 rnExpr (RecordCon con_id _ rbinds)
 248   = do  { conname <- lookupLocatedOccRn con_id
 249         ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
 250         ; return (RecordCon conname noPostTcExpr rbinds',
 251                   fvRbinds `addOneFV` unLoc conname) }
 252
 253 rnExpr (RecordUpd expr rbinds _ _ _)
 254   = do  { (expr', fvExpr) <- rnLExpr expr
 255         ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
 256         ; return (RecordUpd expr' rbinds' [] [] [],
 257                   fvExpr `plusFV` fvRbinds) }
 258
 259 rnExpr (ExprWithTySig expr pty)
 260   = do  { (pty', fvTy) <- rnHsTypeFVs doc pty
 261         ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
 262                              rnLExpr expr
 263         ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 264   where
 265     doc = text "In an expression type signature"
 266
 267 rnExpr (HsIf p b1 b2)
 268   = rnLExpr p           `thenM` \ (p', fvP) ->
 269     rnLExpr b1          `thenM` \ (b1', fvB1) ->
 270     rnLExpr b2          `thenM` \ (b2', fvB2) ->
 271     returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2])
 272
 273 rnExpr (HsType a)
 274   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 275     returnM (HsType t, fvT)
 276   where
 277     doc = text "In a type argument"
 278
 279 rnExpr (ArithSeq _ seq)
 280   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 281     returnM (ArithSeq noPostTcExpr new_seq, fvs)
 282
 283 rnExpr (PArrSeq _ seq)
 284   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 285     returnM (PArrSeq noPostTcExpr new_seq, fvs)
 286 \end{code}
 287
 288 These three are pattern syntax appearing in expressions.
 289 Since all the symbols are reservedops we can simply reject them.
 290 We return a (bogus) EWildPat in each case.
 291
 292 \begin{code}
 293 rnExpr e@EWildPat      = patSynErr e
 294 rnExpr e@(EAsPat {})   = patSynErr e
 295 rnExpr e@(EViewPat {}) = patSynErr e
 296 rnExpr e@(ELazyPat {}) = patSynErr e
 297 \end{code}
 298
 299 %************************************************************************
 300 %*                                                                      *
 301         Arrow notation
 302 %*                                                                      *
 303 %************************************************************************
 304
 305 \begin{code}
 306 rnExpr (HsProc pat body)
 307   = newArrowScope $
 308     rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
 309     rnCmdTop body                `thenM` \ (body',fvBody) ->
 310     returnM (HsProc pat' body', fvBody)
 311
 312 rnExpr (HsArrApp arrow arg _ ho rtl)
 313   = select_arrow_scope (rnLExpr arrow)  `thenM` \ (arrow',fvArrow) ->
 314     rnLExpr arg                         `thenM` \ (arg',fvArg) ->
 315     returnM (HsArrApp arrow' arg' placeHolderType ho rtl,
 316              fvArrow `plusFV` fvArg)
 317   where
 318     select_arrow_scope tc = case ho of
 319         HsHigherOrderApp -> tc
 320         HsFirstOrderApp  -> escapeArrowScope tc
 321
 322 -- infix form
 323 rnExpr (HsArrForm op (Just _) [arg1, arg2])
 324   = escapeArrowScope (rnLExpr op)
 325                         `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) ->
 326     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
 327     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
 328
 329         -- Deal with fixity
 330
 331     lookupFixityRn op_name              `thenM` \ fixity ->
 332     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e ->
 333
 334     returnM (final_e,
 335               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
 336
 337 rnExpr (HsArrForm op fixity cmds)
 338   = escapeArrowScope (rnLExpr op)       `thenM` \ (op',fvOp) ->
 339     rnCmdArgs cmds                      `thenM` \ (cmds',fvCmds) ->
 340     returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
 341
 342 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 343         -- HsWrap
 344 \end{code}
 345
 346
 347 %************************************************************************
 348 %*                                                                      *
 349         Arrow commands
 350 %*                                                                      *
 351 %************************************************************************
 352
 353 \begin{code}
 354 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
 355 rnCmdArgs [] = returnM ([], emptyFVs)
 356 rnCmdArgs (arg:args)
 357   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
 358     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
 359     returnM (arg':args', fvArg `plusFV` fvArgs)
 360
 361 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
 362 rnCmdTop = wrapLocFstM rnCmdTop'
 363  where
 364   rnCmdTop' (HsCmdTop cmd _ _ _)
 365    = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
 366      let
 367         cmd_names = [arrAName, composeAName, firstAName] ++
 368                     nameSetToList (methodNamesCmd (unLoc cmd'))
 369      in
 370         -- Generate the rebindable syntax for the monad
 371      lookupSyntaxTable cmd_names        `thenM` \ (cmd_names', cmd_fvs) ->
 372
 373      returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
 374              fvCmd `plusFV` cmd_fvs)
 375
 376 ---------------------------------------------------
 377 -- convert OpApp's in a command context to HsArrForm's
 378
 379 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
 380 convertOpFormsLCmd = fmap convertOpFormsCmd
 381
 382 convertOpFormsCmd :: HsCmd id -> HsCmd id
 383
 384 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
 385 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
 386 convertOpFormsCmd (OpApp c1 op fixity c2)
 387   = let
 388         arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
 389         arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
 390     in
 391     HsArrForm op (Just fixity) [arg1, arg2]
 392
 393 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 394
 395 convertOpFormsCmd (HsCase exp matches)
 396   = HsCase exp (convertOpFormsMatch matches)
 397
 398 convertOpFormsCmd (HsIf exp c1 c2)
 399   = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 400
 401 convertOpFormsCmd (HsLet binds cmd)
 402   = HsLet binds (convertOpFormsLCmd cmd)
 403
 404 convertOpFormsCmd (HsDo ctxt stmts body ty)
 405   = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
 406               (convertOpFormsLCmd body) ty
 407
 408 -- Anything else is unchanged.  This includes HsArrForm (already done),
 409 -- things with no sub-commands, and illegal commands (which will be
 410 -- caught by the type checker)
 411 convertOpFormsCmd c = c
 412
 413 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
 414 convertOpFormsStmt (BindStmt pat cmd _ _)
 415   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
 416 convertOpFormsStmt (ExprStmt cmd _ _)
 417   = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
 418 convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
 419   = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
 420 convertOpFormsStmt stmt = stmt
 421
 422 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
 423 convertOpFormsMatch (MatchGroup ms ty)
 424   = MatchGroup (map (fmap convert) ms) ty
 425  where convert (Match pat mty grhss)
 426           = Match pat mty (convertOpFormsGRHSs grhss)
 427
 428 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
 429 convertOpFormsGRHSs (GRHSs grhss binds)
 430   = GRHSs (map convertOpFormsGRHS grhss) binds
 431
 432 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
 433 convertOpFormsGRHS = fmap convert
 434  where
 435    convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
 436
 437 ---------------------------------------------------
 438 type CmdNeeds = FreeVars        -- Only inhabitants are
 439                                 --      appAName, choiceAName, loopAName
 440
 441 -- find what methods the Cmd needs (loop, choice, apply)
 442 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
 443 methodNamesLCmd = methodNamesCmd . unLoc
 444
 445 methodNamesCmd :: HsCmd Name -> CmdNeeds
 446
 447 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
 448   = emptyFVs
 449 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
 450   = unitFV appAName
 451 methodNamesCmd (HsArrForm {}) = emptyFVs
 452
 453 methodNamesCmd (HsPar c) = methodNamesLCmd c
 454
 455 methodNamesCmd (HsIf _ c1 c2)
 456   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 457
 458 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
 459
 460 methodNamesCmd (HsDo _ stmts body _)
 461   = methodNamesStmts stmts `plusFV` methodNamesLCmd body
 462
 463 methodNamesCmd (HsApp c _) = methodNamesLCmd c
 464
 465 methodNamesCmd (HsLam match) = methodNamesMatch match
 466
 467 methodNamesCmd (HsCase _ matches)
 468   = methodNamesMatch matches `addOneFV` choiceAName
 469
 470 methodNamesCmd _ = emptyFVs
 471    -- Other forms can't occur in commands, but it's not convenient
 472    -- to error here so we just do what's convenient.
 473    -- The type checker will complain later
 474
 475 ---------------------------------------------------
 476 methodNamesMatch :: MatchGroup Name -> FreeVars
 477 methodNamesMatch (MatchGroup ms _)
 478   = plusFVs (map do_one ms)
 479  where
 480     do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
 481
 482 -------------------------------------------------
 483 -- gaw 2004
 484 methodNamesGRHSs :: GRHSs Name -> FreeVars
 485 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
 486
 487 -------------------------------------------------
 488
 489 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
 490 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
 491
 492 ---------------------------------------------------
 493 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
 494 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
 495
 496 ---------------------------------------------------
 497 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
 498 methodNamesLStmt = methodNamesStmt . unLoc
 499
 500 methodNamesStmt :: StmtLR Name Name -> FreeVars
 501 methodNamesStmt (ExprStmt cmd _ _)     = methodNamesLCmd cmd
 502 methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
 503 methodNamesStmt (RecStmt stmts _ _ _ _)
 504   = methodNamesStmts stmts `addOneFV` loopAName
 505 methodNamesStmt (LetStmt _)  = emptyFVs
 506 methodNamesStmt (ParStmt _) = emptyFVs
 507 methodNamesStmt (TransformStmt _ _ _) = emptyFVs
 508 methodNamesStmt (GroupStmt _ _) = emptyFVs
 509    -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
 510    -- here so we just do what's convenient
 511 \end{code}
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516         Arithmetic sequences
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521 rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
 522 rnArithSeq (From expr)
 523  = rnLExpr expr         `thenM` \ (expr', fvExpr) ->
 524    returnM (From expr', fvExpr)
 525
 526 rnArithSeq (FromThen expr1 expr2)
 527  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 528    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 529    returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 530
 531 rnArithSeq (FromTo expr1 expr2)
 532  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 533    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 534    returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 535
 536 rnArithSeq (FromThenTo expr1 expr2 expr3)
 537  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 538    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 539    rnLExpr expr3        `thenM` \ (expr3', fvExpr3) ->
 540    returnM (FromThenTo expr1' expr2' expr3',
 541             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 542 \end{code}
 543
 544 %************************************************************************
 545 %*                                                                      *
 546         Template Haskell brackets
 547 %*                                                                      *
 548 %************************************************************************
 549
 550 \begin{code}
 551 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 552 rnBracket (VarBr n) = do { name <- lookupOccRn n
 553                          ; this_mod <- getModule
 554                          ; checkM (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
 555                            do { loadInterfaceForName msg name           -- home interface is loaded, and this is the
 556                               ; return () }                             -- only way that is going to happen
 557                          ; returnM (VarBr name, unitFV name) }
 558                     where
 559                       msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 560
 561 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 562                          ; return (ExpBr e', fvs) }
 563
 564 rnBracket (PatBr _) = do { addErr (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"));
 565                            failM }
 566
 567 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 568                          ; return (TypBr t', fvs) }
 569                     where
 570                       doc = ptext (sLit "In a Template-Haskell quoted type")
 571 rnBracket (DecBr group)
 572   = do { gbl_env  <- getGblEnv
 573
 574         ; let new_gbl_env = gbl_env { -- Set the module to thFAKE.  The top-level names from the bracketed
 575                                       -- declarations will go into the name cache, and we don't want them to
 576                                       -- confuse the Names for the current module.
 577                                       -- By using a pretend module, thFAKE, we keep them safely out of the way.
 578                                      tcg_mod = thFAKE,
 579
 580                                      -- The emptyDUs is so that we just collect uses for this group alone
 581                                      -- in the call to rnSrcDecls below
 582                                      tcg_dus = emptyDUs }
 583        ; setGblEnv new_gbl_env $ do {
 584
 585         -- In this situation we want to *shadow* top-level bindings.
 586         --      foo = 1
 587         --      bar = [d| foo = 1 |]
 588         -- If we don't shadow, we'll get an ambiguity complaint when we do
 589         -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
 590         --
 591         -- Furthermore, arguably if the splice does define foo, that should hide
 592         -- any foo's further out
 593         --
 594         -- The shadowing is acheived by calling rnSrcDecls with True as the shadowing flag
 595        ; (tcg_env, group') <- rnSrcDecls True 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             mappM 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   = do  { addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
 931         ; failM }
 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   = do  { addErr (badIpBinds (ptext (sLit "an mdo expression")) binds)
 994         ; failM }
 995
 996 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
 997   (binds', du_binds) <-
 998       -- fixities and unused are handled above in rn_rec_stmts_and_then
 999       rnValBindsRHS all_bndrs binds'
1000   returnM [(duDefs du_binds, duUses du_binds,
1001             emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1002
1003 -- no RecStmt case becuase they get flattened above when doing the LHSes
1004 rn_rec_stmt _ stmt@(L _ (RecStmt _ _ _ _ _)) _
1005   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1006
1007 rn_rec_stmt _ stmt@(L _ (ParStmt _)) _  -- Syntactically illegal in mdo
1008   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1009
1010 rn_rec_stmt _ stmt@(L _ (TransformStmt _ _ _)) _        -- Syntactically illegal in mdo
1011   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1012
1013 rn_rec_stmt _ stmt@(L _ (GroupStmt _ _)) _      -- Syntactically illegal in mdo
1014   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1015
1016 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1017   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1018
1019 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1020 rn_rec_stmts bndrs stmts = mappM (uncurry (rn_rec_stmt bndrs)) stmts    `thenM` \ segs_s ->
1021                            returnM (concat segs_s)
1022
1023 ---------------------------------------------
1024 addFwdRefs :: [Segment a] -> [Segment a]
1025 -- So far the segments only have forward refs *within* the Stmt
1026 --      (which happens for bind:  x <- ...x...)
1027 -- This function adds the cross-seg fwd ref info
1028
1029 addFwdRefs pairs
1030   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1031   where
1032     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1033         = (new_seg : segs, all_defs)
1034         where
1035           new_seg = (defs, uses, new_fwds, stmts)
1036           all_defs = later_defs `unionNameSets` defs
1037           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1038                 -- Add the downstream fwd refs here
1039
1040 ----------------------------------------------------
1041 --      Glomming the singleton segments of an mdo into
1042 --      minimal recursive groups.
1043 --
1044 -- At first I thought this was just strongly connected components, but
1045 -- there's an important constraint: the order of the stmts must not change.
1046 --
1047 -- Consider
1048 --      mdo { x <- ...y...
1049 --            p <- z
1050 --            y <- ...x...
1051 --            q <- x
1052 --            z <- y
1053 --            r <- x }
1054 --
1055 -- Here, the first stmt mention 'y', which is bound in the third.
1056 -- But that means that the innocent second stmt (p <- z) gets caught
1057 -- up in the recursion.  And that in turn means that the binding for
1058 -- 'z' has to be included... and so on.
1059 --
1060 -- Start at the tail { r <- x }
1061 -- Now add the next one { z <- y ; r <- x }
1062 -- Now add one more     { q <- x ; z <- y ; r <- x }
1063 -- Now one more... but this time we have to group a bunch into rec
1064 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1065 -- Now one more, which we can add on without a rec
1066 --      { p <- z ;
1067 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1068 --        r <- x }
1069 -- Finally we add the last one; since it mentions y we have to
1070 -- glom it togeher with the first two groups
1071 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1072 --              q <- x ; z <- y } ;
1073 --        r <- x }
1074
1075 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1076
1077 glomSegments [] = []
1078 glomSegments ((defs,uses,fwds,stmt) : segs)
1079         -- Actually stmts will always be a singleton
1080   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1081   where
1082     segs'            = glomSegments segs
1083     (extras, others) = grab uses segs'
1084     (ds, us, fs, ss) = unzip4 extras
1085
1086     seg_defs  = plusFVs ds `plusFV` defs
1087     seg_uses  = plusFVs us `plusFV` uses
1088     seg_fwds  = plusFVs fs `plusFV` fwds
1089     seg_stmts = stmt : concat ss
1090
1091     grab :: NameSet             -- The client
1092          -> [Segment a]
1093          -> ([Segment a],       -- Needed by the 'client'
1094              [Segment a])       -- Not needed by the client
1095         -- The result is simply a split of the input
1096     grab uses dus
1097         = (reverse yeses, reverse noes)
1098         where
1099           (noes, yeses)           = span not_needed (reverse dus)
1100           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1101
1102
1103 ----------------------------------------------------
1104 segsToStmts :: [Segment [LStmt Name]]
1105             -> FreeVars                 -- Free vars used 'later'
1106             -> ([LStmt Name], FreeVars)
1107
1108 segsToStmts [] fvs_later = ([], fvs_later)
1109 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
1110   = ASSERT( not (null ss) )
1111     (new_stmt : later_stmts, later_uses `plusFV` uses)
1112   where
1113     (later_stmts, later_uses) = segsToStmts segs fvs_later
1114     new_stmt | non_rec   = head ss
1115              | otherwise = L (getLoc (head ss)) $
1116                            RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
1117                                       [] emptyLHsBinds
1118              where
1119                non_rec    = isSingleton ss && isEmptyNameSet fwds
1120                used_later = defs `intersectNameSet` later_uses
1121                                 -- The ones needed after the RecStmt
1122 \end{code}
1123
1124 %************************************************************************
1125 %*                                                                      *
1126 \subsubsection{Assertion utils}
1127 %*                                                                      *
1128 %************************************************************************
1129
1130 \begin{code}
1131 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1132 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
1133
1134 mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
1135 -- Return an expression for (assertError "Foo.hs:27")
1136 mkAssertErrorExpr
1137   = getSrcSpanM                         `thenM` \ sloc ->
1138     let
1139         expr = HsApp (L sloc (HsVar assertErrorName))
1140                      (L sloc (srcSpanPrimLit sloc))
1141     in
1142     returnM (expr, emptyFVs)
1143 \end{code}
1144
1145 %************************************************************************
1146 %*                                                                      *
1147 \subsubsection{Errors}
1148 %*                                                                      *
1149 %************************************************************************
1150
1151 \begin{code}
1152
1153 ----------------------
1154 -- Checking when a particular Stmt is ok
1155 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1156 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1157 checkLetStmt _ctxt           _binds            = return ()
1158         -- We do not allow implicit-parameter bindings in a parallel
1159         -- list comprehension.  I'm not sure what it might mean.
1160
1161 ---------
1162 checkRecStmt :: HsStmtContext Name -> RnM ()
1163 checkRecStmt (MDoExpr {}) = return ()   -- Recursive stmt ok in 'mdo'
1164 checkRecStmt (DoExpr {})  = return ()   -- ..and in 'do' but only because of arrows:
1165                                         --   proc x -> do { ...rec... }
1166                                         -- We don't have enough context to distinguish this situation here
1167                                         --      so we leave it to the type checker
1168 checkRecStmt ctxt         = addErr msg
1169   where
1170     msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1171
1172 ---------
1173 checkParStmt :: HsStmtContext Name -> RnM ()
1174 checkParStmt _
1175   = do  { parallel_list_comp <- doptM Opt_ParallelListComp
1176         ; checkErr parallel_list_comp msg }
1177   where
1178     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1179
1180 ---------
1181 checkTransformStmt :: HsStmtContext Name -> RnM ()
1182 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
1183                              -- desugarer will break when we come to operate on a parallel array
1184   = do  { transform_list_comp <- doptM Opt_TransformListComp
1185         ; checkErr transform_list_comp msg }
1186   where
1187     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1188 checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1189 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1190 checkTransformStmt ctxt = addErr msg
1191   where
1192     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1193
1194 ---------
1195 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1196 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1197                                 nest 4 (ppr e)])
1198                  ; return (EWildPat, emptyFVs) }
1199
1200 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1201 badIpBinds what binds
1202   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1203          2 (ppr binds)
1204 \end{code}