RnExpr.hs 81.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4 5 6 7
\section[RnExpr]{Renaming of expressions}

Basically dependency analysis.

8
Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
9 10
general, all of these functions return a renamed thing, and a set of
free variables.
Austin Seipp's avatar
Austin Seipp committed
11
-}
12

quchen's avatar
quchen committed
13 14
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
15
{-# LANGUAGE MultiWayIf #-}
16
{-# LANGUAGE TypeFamilies #-}
17

18
module RnExpr (
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
19
        rnLExpr, rnExpr, rnStmts
20 21
   ) where

22 23
#include "HsVersions.h"

24
import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
25
                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)
26
import HsSyn
27
import TcRnMonad
28
import Module           ( getModule )
29
import RnEnv
30 31 32 33 34 35
import RnFixity
import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames
                        , bindLocalNames
                        , mapMaybeFvRn, mapFvRn
                        , warnUnusedLocalBinds )
import RnUnbound        ( reportUnboundName )
36
import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
37
import RnTypes
Ian Lynagh's avatar
Ian Lynagh committed
38
import RnPat
39
import DynFlags
40
import PrelNames
mnislaih's avatar
mnislaih committed
41

Simon Marlow's avatar
Simon Marlow committed
42
import BasicTypes
Ian Lynagh's avatar
Ian Lynagh committed
43
import Name
44
import NameSet
Ian Lynagh's avatar
Ian Lynagh committed
45 46
import RdrName
import UniqSet
Ian Lynagh's avatar
Ian Lynagh committed
47
import Data.List
48
import Util
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
49
import ListSetOps       ( removeDups )
50
import ErrUtils
sof's avatar
sof committed
51
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
52
import SrcLoc
53
import FastString
54
import Control.Monad
55
import TysWiredIn       ( nilDataConName )
56
import qualified GHC.LanguageExtensions as LangExt
57

Simon Marlow's avatar
Simon Marlow committed
58 59 60
import Data.Ord
import Data.Array

Austin Seipp's avatar
Austin Seipp committed
61 62 63
{-
************************************************************************
*                                                                      *
64
\subsubsection{Expressions}
Austin Seipp's avatar
Austin Seipp committed
65 66 67
*                                                                      *
************************************************************************
-}
68

69
rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
sof's avatar
sof committed
70 71
rnExprs ls = rnExprs' ls emptyUniqSet
 where
72
  rnExprs' [] acc = return ([], acc)
73 74
  rnExprs' (expr:exprs) acc =
   do { (expr', fvExpr) <- rnLExpr expr
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
75 76
        -- Now we do a "seq" on the free vars because typically it's small
        -- or empty, especially in very long lists of constants
77 78 79
      ; let  acc' = acc `plusFV` fvExpr
      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
      ; return (expr':exprs', fvExprs) }
80

Austin Seipp's avatar
Austin Seipp committed
81
-- Variables. We look up the variable and return the resulting name.
82

83
rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
84 85
rnLExpr = wrapLocFstM rnExpr

86
rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
87

88
finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
89 90
-- Separated from rnExpr because it's also used
-- when renaming infix expressions
91
finishHsVar (L l name)
92 93 94
 = do { this_mod <- getModule
      ; when (nameIsLocalOrFrom this_mod name) $
        checkThLocalName name
95
      ; return (HsVar (L l name), unitFV name) }
96

97
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
98
rnUnboundVar v
99
 = do { if isUnqual v
100 101 102
        then -- Treat this as a "hole"
             -- Do not fail right now; instead, return HsUnboundVar
             -- and let the type checker report the error
103 104 105 106 107
             do { let occ = rdrNameOcc v
                ; uv <- if startsWithUnderscore occ
                        then return (TrueExprHole occ)
                        else OutOfScope occ <$> getGlobalRdrEnv
                ; return (HsUnboundVar uv, emptyFVs) }
108

109
        else -- Fail immediately (qualified name)
110
             do { n <- reportUnboundName v
111
                ; return (HsVar (noLoc n), emptyFVs) } }
112

113
rnExpr (HsVar (L l v))
114
  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
115
       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
116
       ; case mb_name of {
117
           Nothing -> rnUnboundVar v ;
Adam Gundry's avatar
Adam Gundry committed
118
           Just (Left name)
119 120 121
              | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
              -> rnExpr (ExplicitList placeHolderType Nothing [])
122

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
123
              | otherwise
124
              -> finishHsVar (L l name) ;
Matthew Pickering's avatar
Matthew Pickering committed
125 126 127 128 129 130
            Just (Right [s]) ->
              return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s))
                     , unitFV s) ;
           Just (Right fs@(_:_:_)) ->
              return ( HsRecFld (Ambiguous (L l v) PlaceHolder)
                     , mkFVs fs);
131
           Just (Right [])         -> panic "runExpr/HsVar" } }
132

133
rnExpr (HsIPVar v)
134
  = return (HsIPVar v, emptyFVs)
135

136 137 138 139 140 141
rnExpr (HsOverLabel _ v)
  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
       ; if rebindable_on
         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
                 ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
         else return (HsOverLabel Nothing v, emptyFVs) }
Adam Gundry's avatar
Adam Gundry committed
142

143
rnExpr (HsLit lit@(HsString src s))
144
  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
145
       ; if opt_OverloadedStrings then
146
            rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
147 148
         else do {
            ; rnLit lit
149
            ; return (HsLit (convertLit lit), emptyFVs) } }
150

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
151
rnExpr (HsLit lit)
152
  = do { rnLit lit
153
       ; return (HsLit (convertLit lit), emptyFVs) }
154

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
155
rnExpr (HsOverLit lit)
156 157 158 159 160
  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
       ; case mb_neg of
              Nothing -> return (HsOverLit lit', fvs)
              Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit'))
                                 , fvs ) }
161

162
rnExpr (HsApp fun arg)
163 164 165
  = do { (fun',fvFun) <- rnLExpr fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
166

167 168 169 170 171
rnExpr (HsAppType fun arg)
  = do { (fun',fvFun) <- rnLExpr fun
       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
       ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }

172
rnExpr (OpApp e1 op  _ e2)
173
  = do  { (e1', fv_e1) <- rnLExpr e1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
174
        ; (e2', fv_e2) <- rnLExpr e2
175 176
        ; (op', fv_op) <- rnLExpr op

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
177 178 179 180 181
        -- Deal with fixity
        -- When renaming code synthesised from "deriving" declarations
        -- we used to avoid fixity stuff, but we can't easily tell any
        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
        -- should prevent bad things happening.
182
        ; fixity <- case op' of
183 184
              L _ (HsVar (L _ n)) -> lookupFixityRn n
              L _ (HsRecFld f)    -> lookupFieldFixityRn f
Alan Zimmerman's avatar
Alan Zimmerman committed
185
              _ -> return (Fixity NoSourceText minPrecedence InfixL)
186
                   -- c.f. lookupFixity for unbound
187 188

        ; final_e <- mkOpAppRn e1' op' fixity e2'
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
189
        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
190

191
rnExpr (NegApp e _)
192 193 194 195
  = do { (e', fv_e)         <- rnLExpr e
       ; (neg_name, fv_neg) <- lookupSyntaxName negateName
       ; final_e            <- mkNegAppRn e' neg_name
       ; return (final_e, fv_e `plusFV` fv_neg) }
196

197
------------------------------------------
198
-- Template Haskell extensions
199 200
-- Don't ifdef-GHCI them because we want to fail gracefully
-- (not with an rnExpr crash) in a stage-1 compiler.
gmainland's avatar
gmainland committed
201 202
rnExpr e@(HsBracket br_body) = rnBracket e br_body

203
rnExpr (HsSpliceE splice) = rnSpliceExpr splice
204

205
---------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
206
--      Sections
thomie's avatar
thomie committed
207
-- See Note [Parsing sections] in Parser.y
208
rnExpr (HsPar (L loc (section@(SectionL {}))))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
209 210
  = do  { (section', fvs) <- rnSection section
        ; return (HsPar (L loc section'), fvs) }
211 212

rnExpr (HsPar (L loc (section@(SectionR {}))))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
213 214
  = do  { (section', fvs) <- rnSection section
        ; return (HsPar (L loc section'), fvs) }
215

216
rnExpr (HsPar e)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
217 218
  = do  { (e', fvs_e) <- rnLExpr e
        ; return (HsPar e', fvs_e) }
219

220
rnExpr expr@(SectionL {})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
221
  = do  { addErr (sectionErr expr); rnSection expr }
222
rnExpr expr@(SectionR {})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
223
  = do  { addErr (sectionErr expr); rnSection expr }
224 225

---------------------------------------------
Alan Zimmerman's avatar
Alan Zimmerman committed
226
rnExpr (HsCoreAnn src ann expr)
227
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
228
       ; return (HsCoreAnn src ann expr', fvs_expr) }
229

Alan Zimmerman's avatar
Alan Zimmerman committed
230
rnExpr (HsSCC src lbl expr)
231
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
232
       ; return (HsSCC src lbl expr', fvs_expr) }
233
rnExpr (HsTickPragma src info srcInfo expr)
234
  = do { (expr', fvs_expr) <- rnLExpr expr
235
       ; return (HsTickPragma src info srcInfo expr', fvs_expr) }
236

237
rnExpr (HsLam matches)
238 239
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
       ; return (HsLam matches', fvMatch) }
240

Simon Peyton Jones's avatar
Simon Peyton Jones committed
241
rnExpr (HsLamCase matches)
242
  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
Simon Peyton Jones's avatar
Simon Peyton Jones committed
243
       ; return (HsLamCase matches', fvs_ms) }
244

245
rnExpr (HsCase expr matches)
246 247 248
  = do { (new_expr, e_fvs) <- rnLExpr expr
       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
       ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
249

250
rnExpr (HsLet (L l binds) expr)
Simon Marlow's avatar
Simon Marlow committed
251
  = rnLocalBindsAndThen binds $ \binds' _ -> do
252
      { (expr',fvExpr) <- rnLExpr expr
253
      ; return (HsLet (L l binds') expr', fvExpr) }
254

255
rnExpr (HsDo do_or_lc (L l stmts) _)
Simon Marlow's avatar
Simon Marlow committed
256 257 258 259
  = do  { ((stmts', _), fvs) <-
           rnStmtsWithPostProcessing do_or_lc rnLExpr
             postProcessStmtsForApplicativeDo stmts
             (\ _ -> return ((), emptyFVs))
260
        ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
261

262
rnExpr (ExplicitList _ _  exps)
263
  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
264
        ; (exps', fvs) <- rnExprs exps
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
265
        ; if opt_OverloadedLists
266
           then do {
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
267
            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
268 269
            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
                     , fvs `plusFV` fvs') }
270 271
           else
            return  (ExplicitList placeHolderType Nothing exps', fvs) }
272

chak's avatar
chak committed
273
rnExpr (ExplicitPArr _ exps)
274 275
  = do { (exps', fvs) <- rnExprs exps
       ; return  (ExplicitPArr placeHolderType exps', fvs) }
chak's avatar
chak committed
276

277 278 279 280 281 282
rnExpr (ExplicitTuple tup_args boxity)
  = do { checkTupleSection tup_args
       ; checkTupSize (length tup_args)
       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
       ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
  where
283 284 285 286
    rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
                                    ; return (L l (Present e'), fvs) }
    rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
                                        , emptyFVs)
287

288 289 290 291
rnExpr (ExplicitSum alt arity expr _)
  = do { (expr', fvs) <- rnLExpr expr
       ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }

292 293 294 295 296 297 298 299 300 301 302 303 304
rnExpr (RecordCon { rcon_con_name = con_id
                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
       ; (flds', fvss) <- mapAndUnzipM rn_field flds
       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
       ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
                           , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
  where
    mk_hs_var l n = HsVar (L l n)
    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
305

306
rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
307
  = do  { (expr', fvExpr) <- rnLExpr expr
Adam Gundry's avatar
Adam Gundry committed
308
        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
309 310 311
        ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
                            , rupd_cons    = PlaceHolder, rupd_in_tys = PlaceHolder
                            , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }
Matthew Pickering's avatar
Matthew Pickering committed
312
                 , fvExpr `plusFV` fvRbinds) }
313

314 315 316 317 318
rnExpr (ExprWithTySig expr pty)
  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                             rnLExpr expr
        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
319

320 321
rnExpr (HsIf _ p b1 b2)
  = do { (p', fvP) <- rnLExpr p
322 323 324 325
       ; (b1', fvB1) <- rnLExpr b1
       ; (b2', fvB2) <- rnLExpr b2
       ; (mb_ite, fvITE) <- lookupIfThenElse
       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
326

327
rnExpr (HsMultiIf _ty alts)
328
  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
329 330
       -- ; return (HsMultiIf ty alts', fvs) }
       ; return (HsMultiIf placeHolderType alts', fvs) }
331

332
rnExpr (ArithSeq _ _ seq)
333
  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
334
       ; (new_seq, fvs) <- rnArithSeq seq
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
335
       ; if opt_OverloadedLists
336
           then do {
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
337 338
            ; (from_list_name, fvs') <- lookupSyntaxName fromListName
            ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
339 340
           else
            return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
chak's avatar
chak committed
341

342
rnExpr (PArrSeq _ seq)
343 344
  = do { (new_seq, fvs) <- rnArithSeq seq
       ; return (PArrSeq noPostTcExpr new_seq, fvs) }
345

Austin Seipp's avatar
Austin Seipp committed
346
{-
347 348 349
These three are pattern syntax appearing in expressions.
Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.
Austin Seipp's avatar
Austin Seipp committed
350
-}
351

352
rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
353 354 355 356 357 358 359 360
rnExpr e@(EAsPat {})
  = do { opt_TypeApplications <- xoptM LangExt.TypeApplications
       ; let msg | opt_TypeApplications
                    = "Type application syntax requires a space before '@'"
                 | otherwise
                    = "Did you mean to enable TypeApplications?"
       ; patSynErr e (text msg)
       }
361 362
rnExpr e@(EViewPat {}) = patSynErr e empty
rnExpr e@(ELazyPat {}) = patSynErr e empty
363

Facundo Domínguez's avatar
Facundo Domínguez committed
364 365 366 367 368 369 370 371 372
{-
************************************************************************
*                                                                      *
        Static values
*                                                                      *
************************************************************************

For the static form we check that the free variables are all top-level
value bindings. This is done by checking that the name is external or
373
wired-in. See the Notes about the NameSorts in Name.hs.
Facundo Domínguez's avatar
Facundo Domínguez committed
374 375
-}

376
rnExpr e@(HsStatic _ expr) = do
Facundo Domínguez's avatar
Facundo Domínguez committed
377 378 379 380 381 382 383
    (expr',fvExpr) <- rnLExpr expr
    stage <- getStage
    case stage of
      Splice _ -> addErr $ sep
             [ text "static forms cannot be used in splices:"
             , nest 2 $ ppr e
             ]
384 385 386 387
      _ -> return ()
    mod <- getModule
    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
    return (HsStatic fvExpr' expr', fvExpr)
Facundo Domínguez's avatar
Facundo Domínguez committed
388

Austin Seipp's avatar
Austin Seipp committed
389 390 391
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
392
        Arrow notation
Austin Seipp's avatar
Austin Seipp committed
393 394 395
*                                                                      *
************************************************************************
-}
396

397
rnExpr (HsProc pat body)
ross's avatar
ross committed
398
  = newArrowScope $
399 400 401
    rnPat ProcExpr pat $ \ pat' -> do
      { (body',fvBody) <- rnCmdTop body
      ; return (HsProc pat' body', fvBody) }
402

403 404 405
-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
rnExpr e@(HsArrApp {})  = arrowFail e
rnExpr e@(HsArrForm {}) = arrowFail e
406

407
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
408
        -- HsWrap
409

410
hsHoleExpr :: HsExpr id
411
hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
412

413
arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
414
arrowFail e
415
  = do { addErr (vcat [ text "Arrow command found where an expression was expected:"
416 417 418
                      , nest 2 (ppr e) ])
         -- Return a place-holder hole, so that we can carry on
         -- to report other errors
419
       ; return (hsHoleExpr, emptyFVs) }
420

421
----------------------
thomie's avatar
thomie committed
422
-- See Note [Parsing sections] in Parser.y
423
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
424
rnSection section@(SectionR op expr)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
425 426 427 428
  = do  { (op', fvs_op)     <- rnLExpr op
        ; (expr', fvs_expr) <- rnLExpr expr
        ; checkSectionPrec InfixR section op' expr'
        ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
429 430

rnSection section@(SectionL expr op)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
431 432 433 434
  = do  { (expr', fvs_expr) <- rnLExpr expr
        ; (op', fvs_op)     <- rnLExpr op
        ; checkSectionPrec InfixL section op' expr'
        ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
435 436

rnSection other = pprPanic "rnSection" (ppr other)
437

Austin Seipp's avatar
Austin Seipp committed
438 439 440
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
441
        Arrow commands
Austin Seipp's avatar
Austin Seipp committed
442 443 444
*                                                                      *
************************************************************************
-}
445

446
rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
447
rnCmdArgs [] = return ([], emptyFVs)
448
rnCmdArgs (arg:args)
449 450 451
  = do { (arg',fvArg) <- rnCmdTop arg
       ; (args',fvArgs) <- rnCmdArgs args
       ; return (arg':args', fvArg `plusFV` fvArgs) }
452

453
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
454 455
rnCmdTop = wrapLocFstM rnCmdTop'
 where
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
456
  rnCmdTop' (HsCmdTop cmd _ _ _)
457 458
   = do { (cmd', fvCmd) <- rnLCmd cmd
        ; let cmd_names = [arrAName, composeAName, firstAName] ++
niteria's avatar
niteria committed
459
                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
460
        -- Generate the rebindable syntax for the monad
461
        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
462

463 464
        ; return (HsCmdTop cmd' placeHolderType placeHolderType
                  (cmd_names `zip` cmd_names'),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
465
                  fvCmd `plusFV` cmd_fvs) }
466

467
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
468 469
rnLCmd = wrapLocFstM rnCmd

470
rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
471 472

rnCmd (HsCmdArrApp arrow arg _ ho rtl)
473 474 475 476
  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
                 fvArrow `plusFV` fvArg) }
477 478 479 480 481
  where
    select_arrow_scope tc = case ho of
        HsHigherOrderApp -> tc
        HsFirstOrderApp  -> escapeArrowScope tc
        -- See Note [Escaping the arrow scope] in TcRnTypes
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
482 483 484 485
        -- Before renaming 'arrow', use the environment of the enclosing
        -- proc for the (-<) case.
        -- Local bindings, inside the enclosing proc, are not in scope
        -- inside 'arrow'.  In the higher-order case (-<<), they are.
486

487
-- infix form
Alan Zimmerman's avatar
Alan Zimmerman committed
488
rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
489
  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
490
       ; let L _ (HsVar (L _ op_name)) = op'
491 492
       ; (arg1',fv_arg1) <- rnCmdTop arg1
       ; (arg2',fv_arg2) <- rnCmdTop arg2
493
        -- Deal with fixity
494 495 496
       ; fixity <- lookupFixityRn op_name
       ; final_e <- mkOpFormRn arg1' op' fixity arg2'
       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
497

Alan Zimmerman's avatar
Alan Zimmerman committed
498
rnCmd (HsCmdArrForm op f fixity cmds)
499 500
  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
       ; (cmds',fvCmds) <- rnCmdArgs cmds
Alan Zimmerman's avatar
Alan Zimmerman committed
501
       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
502

503
rnCmd (HsCmdApp fun arg)
504 505 506
  = do { (fun',fvFun) <- rnLCmd  fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
507

508
rnCmd (HsCmdLam matches)
509 510
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
       ; return (HsCmdLam matches', fvMatch) }
511

512 513 514
rnCmd (HsCmdPar e)
  = do  { (e', fvs_e) <- rnLCmd e
        ; return (HsCmdPar e', fvs_e) }
515

516
rnCmd (HsCmdCase expr matches)
517 518 519
  = do { (new_expr, e_fvs) <- rnLExpr expr
       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
       ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
520

521 522 523 524 525 526
rnCmd (HsCmdIf _ p b1 b2)
  = do { (p', fvP) <- rnLExpr p
       ; (b1', fvB1) <- rnLCmd b1
       ; (b2', fvB2) <- rnLCmd b2
       ; (mb_ite, fvITE) <- lookupIfThenElse
       ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
527

528
rnCmd (HsCmdLet (L l binds) cmd)
Simon Marlow's avatar
Simon Marlow committed
529
  = rnLocalBindsAndThen binds $ \ binds' _ -> do
530
      { (cmd',fvExpr) <- rnLCmd cmd
531
      ; return (HsCmdLet (L l binds') cmd', fvExpr) }
532

533
rnCmd (HsCmdDo (L l stmts) _)
Simon Marlow's avatar
Simon Marlow committed
534 535
  = do  { ((stmts', _), fvs) <-
            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
536
        ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
537

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
538
rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
539 540

---------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
541 542
type CmdNeeds = FreeVars        -- Only inhabitants are
                                --      appAName, choiceAName, loopAName
543 544

-- find what methods the Cmd needs (loop, choice, apply)
545
methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
546 547
methodNamesLCmd = methodNamesCmd . unLoc

548
methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
549

550
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
551
  = emptyFVs
552
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
553
  = unitFV appAName
554
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
555
methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
556

557
methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
558

559
methodNamesCmd (HsCmdIf _ _ c1 c2)
560
  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
561

562 563 564 565
methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c
methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c
methodNamesCmd (HsCmdLam match)        = methodNamesMatch match
566

567
methodNamesCmd (HsCmdCase _ matches)
568
  = methodNamesMatch matches `addOneFV` choiceAName
569

570
--methodNamesCmd _ = emptyFVs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
571
   -- Other forms can't occur in commands, but it's not convenient
572 573 574 575
   -- to error here so we just do what's convenient.
   -- The type checker will complain later

---------------------------------------------------
576
methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
577
methodNamesMatch (MG { mg_alts = L _ ms })
578
  = plusFVs (map do_one ms)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
579
 where
580
    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
581 582

-------------------------------------------------
583
-- gaw 2004
584
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
Ian Lynagh's avatar
Ian Lynagh committed
585
methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
586 587

-------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
588

589
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
Ian Lynagh's avatar
Ian Lynagh committed
590
methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
591 592

---------------------------------------------------
593
methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
594
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
595 596

---------------------------------------------------
597
methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
598 599
methodNamesLStmt = methodNamesStmt . unLoc

600
methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
Simon Marlow's avatar
Simon Marlow committed
601
methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd
602
methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
603
methodNamesStmt (BindStmt _ cmd _ _ _)           = methodNamesLCmd cmd
Simon Marlow's avatar
Simon Marlow committed
604 605
methodNamesStmt (RecStmt { recS_stmts = stmts }) =
  methodNamesStmts stmts `addOneFV` loopAName
606 607
methodNamesStmt (LetStmt {})                     = emptyFVs
methodNamesStmt (ParStmt {})                     = emptyFVs
608
methodNamesStmt (TransStmt {})                   = emptyFVs
Simon Marlow's avatar
Simon Marlow committed
609 610 611
methodNamesStmt ApplicativeStmt{}            = emptyFVs
   -- ParStmt and TransStmt can't occur in commands, but it's not
   -- convenient to error here so we just do what's convenient
612

Austin Seipp's avatar
Austin Seipp committed
613 614 615
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
616
        Arithmetic sequences
Austin Seipp's avatar
Austin Seipp committed
617 618 619
*                                                                      *
************************************************************************
-}
620

621
rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
622
rnArithSeq (From expr)
623 624
 = do { (expr', fvExpr) <- rnLExpr expr
      ; return (From expr', fvExpr) }
625 626

rnArithSeq (FromThen expr1 expr2)
627 628 629
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
630 631

rnArithSeq (FromTo expr1 expr2)
632 633 634
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
635 636

rnArithSeq (FromThenTo expr1 expr2 expr3)
637 638 639 640 641
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; (expr3', fvExpr3) <- rnLExpr expr3
      ; return (FromThenTo expr1' expr2' expr3',
                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
642

Austin Seipp's avatar
Austin Seipp committed
643 644 645
{-
************************************************************************
*                                                                      *
646
\subsubsection{@Stmt@s: in @do@ expressions}
Austin Seipp's avatar
Austin Seipp committed
647 648 649
*                                                                      *
************************************************************************
-}
650

651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671
{-
Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Both ApplicativeDo and RecursiveDo need to create tuples not
present in the source text.

For ApplicativeDo we create:

  (a,b,c) <- (\c b a -> (a,b,c)) <$>

For RecursiveDo we create:

  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))

The order of the components in those tuples needs to be stable
across recompilations, otherwise they can get optimized differently
and we end up with incompatible binaries.
To get a stable order we use nameSetElemsStable.
See Note [Deterministic UniqFM] to learn more about nondeterminism.
-}

Simon Marlow's avatar
Simon Marlow committed
672
-- | Rename some Stmts
673
rnStmts :: Outputable (body GhcPs)
Simon Marlow's avatar
Simon Marlow committed
674
        => HsStmtContext Name
675
        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
Simon Marlow's avatar
Simon Marlow committed
676
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
677
        -> [LStmt GhcPs (Located (body GhcPs))]
Simon Marlow's avatar
Simon Marlow committed
678
           -- ^ Statements
679
        -> ([Name] -> RnM (thing, FreeVars))
Simon Marlow's avatar
Simon Marlow committed
680 681
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
682
        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
Simon Marlow's avatar
Simon Marlow committed
683 684 685 686
rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts

-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
rnStmtsWithPostProcessing
687
        :: Outputable (body GhcPs)
Simon Marlow's avatar
Simon Marlow committed
688
        => HsStmtContext Name
689
        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
Simon Marlow's avatar
Simon Marlow committed
690 691
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
        -> (HsStmtContext Name
692 693
              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
Simon Marlow's avatar
Simon Marlow committed
694
           -- ^ postprocess the statements
695
        -> [LStmt GhcPs (Located (body GhcPs))]
Simon Marlow's avatar
Simon Marlow committed
696 697 698 699
           -- ^ Statements
        -> ([Name] -> RnM (thing, FreeVars))
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
700
        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)