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