compiler/rename/RnExpr.lhs

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