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