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