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