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