compiler/rename/RnExpr.lhs

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