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