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