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) bndrs
 763                          -- The paper (Fig 5) has a bug here; we must treat any free varaible of
 764                          -- the "thing inside", **or of the by-expression**, as used
 765                    ; return ((by', used_bndrs, thing), fvs) }
 766
 767        ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
 768                  fvs1 `plusFV` fvs2) }
 769
 770 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
 771   = do { checkTransformStmt ctxt
 772
 773          -- Rename the 'using' expression in the context before the transform is begun
 774        ; (using', fvs1) <- case using of
 775                              Left e  -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
 776                              Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
 777                                            ; return (Right e', fvs) }
 778
 779          -- Rename the stmts and the 'by' expression
 780          -- Keep track of the variables mentioned in the 'by' expression
 781        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 782              <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 783                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 784                    ; (thing, fvs_thing) <- thing_inside bndrs
 785                    ; let fvs = fvs_by `plusFV` fvs_thing
 786                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 787                    ; return ((by', used_bndrs, thing), fvs) }
 788
 789        ; let all_fvs  = fvs1 `plusFV` fvs2
 790              bndr_map = used_bndrs `zip` used_bndrs
 791              -- See Note [GroupStmt binder map] in HsExpr
 792
 793        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
 794        ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
 795
 796
 797 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
 798
 799 rnParallelStmts :: forall thing. HsStmtContext Name
 800                 -> [ParSeg RdrName]
 801                 -> ([Name] -> RnM (thing, FreeVars))
 802                 -> RnM (([ParSeg Name], thing), FreeVars)
 803 -- Note [Renaming parallel Stmts]
 804 rnParallelStmts ctxt segs thing_inside
 805   = do { orig_lcl_env <- getLocalRdrEnv
 806        ; rn_segs orig_lcl_env [] segs }
 807   where
 808     rn_segs :: LocalRdrEnv
 809             -> [Name] -> [ParSeg RdrName]
 810             -> RnM (([ParSeg Name], thing), FreeVars)
 811     rn_segs _ bndrs_so_far []
 812       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 813            ; mapM_ dupErr dups
 814            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 815            ; return (([], thing), fvs) }
 816
 817     rn_segs env bndrs_so_far ((stmts,_) : segs)
 818       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 819                     <- rnNormalStmts ctxt stmts $ \ bndrs ->
 820                        setLocalRdrEnv env       $ do
 821                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 822                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 823                        ; return ((used_bndrs, segs', thing), fvs) }
 824
 825            ; let seg' = (stmts', used_bndrs)
 826            ; return ((seg':segs', thing), fvs) }
 827
 828     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 829     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
 830                     <+> quotes (ppr (head vs)))
 831 \end{code}
 832
 833 Note [Renaming parallel Stmts]
 834 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 835 Renaming parallel statements is painful.  Given, say
 836      [ a+c | a <- as, bs <- bss
 837            | c <- bs, a <- ds ]
 838 Note that
 839   (a) In order to report "Defined by not used" about 'bs', we must rename
 840       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
 841
 842   (b) We want to report that 'a' is illegally bound in both branches
 843
 844   (c) The 'bs' in the second group must obviously not be captured by
 845       the binding in the first group
 846
 847 To satisfy (a) we nest the segements.
 848 To satisfy (b) we check for duplicates just before thing_inside.
 849 To satisfy (c) we reset the LocalRdrEnv each time.
 850
 851 %************************************************************************
 852 %*                                                                      *
 853 \subsubsection{mdo expressions}
 854 %*                                                                      *
 855 %************************************************************************
 856
 857 \begin{code}
 858 type FwdRefs = NameSet
 859 type Segment stmts = (Defs,
 860                       Uses,     -- May include defs
 861                       FwdRefs,  -- A subset of uses that are
 862                                 --   (a) used before they are bound in this segment, or
 863                                 --   (b) used here, and bound in subsequent segments
 864                       stmts)    -- Either Stmt or [Stmt]
 865
 866
 867 ----------------------------------------------------
 868
 869 rnMDoStmts :: [LStmt RdrName]
 870            -> RnM (thing, FreeVars)
 871            -> RnM (([LStmt Name], thing), FreeVars)
 872 rnMDoStmts stmts thing_inside
 873   = rn_rec_stmts_and_then stmts $ \ segs -> do
 874     { (thing, fvs_later) <- thing_inside
 875     ; let   segs_w_fwd_refs = addFwdRefs segs
 876             grouped_segs = glomSegments segs_w_fwd_refs
 877             (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
 878     ; return ((stmts', thing), fvs) }
 879
 880 ---------------------------------------------
 881
 882 -- wrapper that does both the left- and right-hand sides
 883 rn_rec_stmts_and_then :: [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 rn_rec_stmts_and_then 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         ; bindLocalNamesFV bound_names $
 898           addLocalFixities fix_env bound_names $ do
 899
 900           -- (C) do the right-hand-sides and thing-inside
 901         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
 902         ; (res, fvs) <- cont segs
 903         ; warnUnusedLocalBinds bound_names fvs
 904         ; return (res, fvs) }}
 905
 906 -- get all the fixity decls in any Let stmt
 907 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
 908 collectRecStmtsFixities l =
 909     foldr (\ s -> \acc -> case s of
 910                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
 911                                 foldr (\ sig -> \ acc -> case sig of
 912                                                            (L loc (FixSig s)) -> (L loc s) : acc
 913                                                            _ -> acc) acc sigs
 914                             _ -> acc) [] l
 915
 916 -- left-hand sides
 917
 918 rn_rec_stmt_lhs :: MiniFixityEnv
 919                 -> LStmt RdrName
 920                    -- rename LHS, and return its FVs
 921                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 922                    -- so we don't bother to compute it accurately in the other cases
 923                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 924
 925 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
 926                                                        -- this is actually correct
 927                                                        emptyFVs)]
 928
 929 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
 930   = do
 931       -- should the ctxt be MDo instead?
 932       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 933       return [(L loc (BindStmt pat' expr a b),
 934                fv_pat)]
 935
 936 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
 937   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 938
 939 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 940     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
 941          return [(L loc (LetStmt (HsValBinds binds')),
 942                  -- Warning: this is bogus; see function invariant
 943                  emptyFVs
 944                  )]
 945
 946 -- XXX Do we need to do something with the return and mfix names?
 947 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
 948     = rn_rec_stmts_lhs fix_env stmts
 949
 950 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _))        -- Syntactically illegal in mdo
 951   = pprPanic "rn_rec_stmt" (ppr stmt)
 952
 953 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
 954   = pprPanic "rn_rec_stmt" (ppr stmt)
 955
 956 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))     -- Syntactically illegal in mdo
 957   = pprPanic "rn_rec_stmt" (ppr stmt)
 958
 959 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 960   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 961
 962 rn_rec_stmts_lhs :: MiniFixityEnv
 963                  -> [LStmt RdrName]
 964                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
 965 rn_rec_stmts_lhs fix_env stmts
 966   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 967        ; let boundNames = collectLStmtsBinders (map fst ls)
 968             -- First do error checking: we need to check for dups here because we
 969             -- don't bind all of the variables from the Stmt at once
 970             -- with bindLocatedLocals.
 971        ; checkDupNames boundNames
 972        ; return ls }
 973
 974
 975 -- right-hand-sides
 976
 977 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
 978         -- Rename a Stmt that is inside a RecStmt (or mdo)
 979         -- Assumes all binders are already in scope
 980         -- Turns each stmt into a singleton Stmt
 981 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
 982   = rnLExpr expr `thenM` \ (expr', fvs) ->
 983     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
 984     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 985               L loc (ExprStmt expr' then_op placeHolderType))]
 986
 987 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 988   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
 989     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
 990     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
 991     let
 992         bndrs = mkNameSet (collectPatBinders pat')
 993         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
 994     in
 995     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 996               L loc (BindStmt pat' expr' bind_op fail_op))]
 997
 998 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
 999   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1000
1001 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1002   (binds', du_binds) <-
1003       -- fixities and unused are handled above in rn_rec_stmts_and_then
1004       rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1005   return [(duDefs du_binds, allUses du_binds,
1006            emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1007
1008 -- no RecStmt case becuase they get flattened above when doing the LHSes
1009 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1010   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1011
1012 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1013   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1014
1015 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _   -- Syntactically illegal in mdo
1016   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1017
1018 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _       -- Syntactically illegal in mdo
1019   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1020
1021 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1022   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1023
1024 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1025 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1026                            return (concat segs_s)
1027
1028 ---------------------------------------------
1029 addFwdRefs :: [Segment a] -> [Segment a]
1030 -- So far the segments only have forward refs *within* the Stmt
1031 --      (which happens for bind:  x <- ...x...)
1032 -- This function adds the cross-seg fwd ref info
1033
1034 addFwdRefs pairs
1035   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1036   where
1037     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1038         = (new_seg : segs, all_defs)
1039         where
1040           new_seg = (defs, uses, new_fwds, stmts)
1041           all_defs = later_defs `unionNameSets` defs
1042           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1043                 -- Add the downstream fwd refs here
1044
1045 ----------------------------------------------------
1046 --      Glomming the singleton segments of an mdo into
1047 --      minimal recursive groups.
1048 --
1049 -- At first I thought this was just strongly connected components, but
1050 -- there's an important constraint: the order of the stmts must not change.
1051 --
1052 -- Consider
1053 --      mdo { x <- ...y...
1054 --            p <- z
1055 --            y <- ...x...
1056 --            q <- x
1057 --            z <- y
1058 --            r <- x }
1059 --
1060 -- Here, the first stmt mention 'y', which is bound in the third.
1061 -- But that means that the innocent second stmt (p <- z) gets caught
1062 -- up in the recursion.  And that in turn means that the binding for
1063 -- 'z' has to be included... and so on.
1064 --
1065 -- Start at the tail { r <- x }
1066 -- Now add the next one { z <- y ; r <- x }
1067 -- Now add one more     { q <- x ; z <- y ; r <- x }
1068 -- Now one more... but this time we have to group a bunch into rec
1069 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1070 -- Now one more, which we can add on without a rec
1071 --      { p <- z ;
1072 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1073 --        r <- x }
1074 -- Finally we add the last one; since it mentions y we have to
1075 -- glom it togeher with the first two groups
1076 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1077 --              q <- x ; z <- y } ;
1078 --        r <- x }
1079
1080 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1081
1082 glomSegments [] = []
1083 glomSegments ((defs,uses,fwds,stmt) : segs)
1084         -- Actually stmts will always be a singleton
1085   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1086   where
1087     segs'            = glomSegments segs
1088     (extras, others) = grab uses segs'
1089     (ds, us, fs, ss) = unzip4 extras
1090
1091     seg_defs  = plusFVs ds `plusFV` defs
1092     seg_uses  = plusFVs us `plusFV` uses
1093     seg_fwds  = plusFVs fs `plusFV` fwds
1094     seg_stmts = stmt : concat ss
1095
1096     grab :: NameSet             -- The client
1097          -> [Segment a]
1098          -> ([Segment a],       -- Needed by the 'client'
1099              [Segment a])       -- Not needed by the client
1100         -- The result is simply a split of the input
1101     grab uses dus
1102         = (reverse yeses, reverse noes)
1103         where
1104           (noes, yeses)           = span not_needed (reverse dus)
1105           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1106
1107
1108 ----------------------------------------------------
1109 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1110             -> [Segment [LStmt Name]]
1111             -> FreeVars                 -- Free vars used 'later'
1112             -> ([LStmt Name], FreeVars)
1113
1114 segsToStmts _ [] fvs_later = ([], fvs_later)
1115 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1116   = ASSERT( not (null ss) )
1117     (new_stmt : later_stmts, later_uses `plusFV` uses)
1118   where
1119     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1120     new_stmt | non_rec   = head ss
1121              | otherwise = L (getLoc (head ss)) rec_stmt
1122     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1123                               , recS_later_ids = nameSetToList used_later
1124                               , recS_rec_ids   = nameSetToList fwds }
1125     non_rec    = isSingleton ss && isEmptyNameSet fwds
1126     used_later = defs `intersectNameSet` later_uses
1127                                 -- The ones needed after the RecStmt
1128 \end{code}
1129
1130 %************************************************************************
1131 %*                                                                      *
1132 \subsubsection{Assertion utils}
1133 %*                                                                      *
1134 %************************************************************************
1135
1136 \begin{code}
1137 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1138 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1139
1140 mkAssertErrorExpr :: RnM (HsExpr Name)
1141 -- Return an expression for (assertError "Foo.hs:27")
1142 mkAssertErrorExpr
1143   = getSrcSpanM                         `thenM` \ sloc ->
1144     return (HsApp (L sloc (HsVar assertErrorName))
1145                   (L sloc (srcSpanPrimLit sloc)))
1146 \end{code}
1147
1148 Note [Adding the implicit parameter to 'assert']
1149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1151 By doing this in the renamer we allow the typechecker to just see the
1152 expanded application and do the right thing. But it's not really
1153 the Right Thing because there's no way to "undo" if you want to see
1154 the original source code.  We'll have fix this in due course, when
1155 we care more about being able to reconstruct the exact original
1156 program.
1157
1158 %************************************************************************
1159 %*                                                                      *
1160 \subsubsection{Errors}
1161 %*                                                                      *
1162 %************************************************************************
1163
1164 \begin{code}
1165
1166 ----------------------
1167 -- Checking when a particular Stmt is ok
1168 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1169 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1170 checkLetStmt _ctxt           _binds            = return ()
1171         -- We do not allow implicit-parameter bindings in a parallel
1172         -- list comprehension.  I'm not sure what it might mean.
1173
1174 ---------
1175 checkRecStmt :: HsStmtContext Name -> RnM ()
1176 checkRecStmt (MDoExpr {}) = return ()   -- Recursive stmt ok in 'mdo'
1177 checkRecStmt (DoExpr {})  = return ()   -- and in 'do'
1178 checkRecStmt ctxt         = addErr msg
1179   where
1180     msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1181
1182 ---------
1183 checkParStmt :: HsStmtContext Name -> RnM ()
1184 checkParStmt _
1185   = do  { parallel_list_comp <- xoptM Opt_ParallelListComp
1186         ; checkErr parallel_list_comp msg }
1187   where
1188     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1189
1190 ---------
1191 checkTransformStmt :: HsStmtContext Name -> RnM ()
1192 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
1193                              -- desugarer will break when we come to operate on a parallel array
1194   = do  { transform_list_comp <- xoptM Opt_TransformListComp
1195         ; checkErr transform_list_comp msg }
1196   where
1197     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1198 checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1199 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1200 checkTransformStmt ctxt = addErr msg
1201   where
1202     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1203
1204 ---------
1205 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1206 checkTupleSection args
1207   = do  { tuple_section <- xoptM Opt_TupleSections
1208         ; checkErr (all tupArgPresent args || tuple_section) msg }
1209   where
1210     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1211
1212 ---------
1213 sectionErr :: HsExpr RdrName -> SDoc
1214 sectionErr expr
1215   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1216        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1217
1218 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1219 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1220                                 nest 4 (ppr e)])
1221                  ; return (EWildPat, emptyFVs) }
1222
1223 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1224 badIpBinds what binds
1225   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1226          2 (ppr binds)
1227 \end{code}