compiler/rename/RnExpr.lhs

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