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