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