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