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