compiler/rename/RnExpr.lhs

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