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