compiler/rename/RnExpr.lhs

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