RnExpr.hs 79.5 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

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

21 22
#include "HsVersions.h"

23
import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
24
                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)
25
import HsSyn
26
import TcRnMonad
27
import Module           ( getModule )
28
import RnEnv
29
import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
30
import RnTypes
Ian Lynagh's avatar
Ian Lynagh committed
31
import RnPat
32
import DynFlags
33
import PrelNames
mnislaih's avatar
mnislaih committed
34

Simon Marlow's avatar
Simon Marlow committed
35
import BasicTypes
Ian Lynagh's avatar
Ian Lynagh committed
36
import Name
37
import NameSet
Ian Lynagh's avatar
Ian Lynagh committed
38 39
import RdrName
import UniqSet
Ian Lynagh's avatar
Ian Lynagh committed
40
import Data.List
41
import Util
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
42
import ListSetOps       ( removeDups )
43
import ErrUtils
sof's avatar
sof committed
44
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
45
import SrcLoc
46
import FastString
47
import Control.Monad
48
import TysWiredIn       ( nilDataConName )
49
import qualified GHC.LanguageExtensions as LangExt
50

Simon Marlow's avatar
Simon Marlow committed
51 52 53
import Data.Ord
import Data.Array

Austin Seipp's avatar
Austin Seipp committed
54 55 56
{-
************************************************************************
*                                                                      *
57
\subsubsection{Expressions}
Austin Seipp's avatar
Austin Seipp committed
58 59 60
*                                                                      *
************************************************************************
-}
61

62
rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
sof's avatar
sof committed
63 64
rnExprs ls = rnExprs' ls emptyUniqSet
 where
65
  rnExprs' [] acc = return ([], acc)
66 67
  rnExprs' (expr:exprs) acc =
   do { (expr', fvExpr) <- rnLExpr expr
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
68 69
        -- Now we do a "seq" on the free vars because typically it's small
        -- or empty, especially in very long lists of constants
70 71 72
      ; let  acc' = acc `plusFV` fvExpr
      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
      ; return (expr':exprs', fvExprs) }
73

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

76 77 78 79
rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
rnLExpr = wrapLocFstM rnExpr

rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
80

81
finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
82 83
-- Separated from rnExpr because it's also used
-- when renaming infix expressions
84
finishHsVar (L l name)
85 86 87
 = do { this_mod <- getModule
      ; when (nameIsLocalOrFrom this_mod name) $
        checkThLocalName name
88
      ; return (HsVar (L l name), unitFV name) }
89

90 91
rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
rnUnboundVar v
92
 = do { if isUnqual v
93 94 95
        then -- Treat this as a "hole"
             -- Do not fail right now; instead, return HsUnboundVar
             -- and let the type checker report the error
96 97 98 99 100
             do { let occ = rdrNameOcc v
                ; uv <- if startsWithUnderscore occ
                        then return (TrueExprHole occ)
                        else OutOfScope occ <$> getGlobalRdrEnv
                ; return (HsUnboundVar uv, emptyFVs) }
101

102
        else -- Fail immediately (qualified name)
103
             do { n <- reportUnboundName v
104
                ; return (HsVar (noLoc n), emptyFVs) } }
105

106
rnExpr (HsVar (L l v))
107
  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
108
       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
109
       ; case mb_name of {
110
           Nothing -> rnUnboundVar v ;
Adam Gundry's avatar
Adam Gundry committed
111
           Just (Left name)
112 113 114
              | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
              -> rnExpr (ExplicitList placeHolderType Nothing [])
115

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
116
              | otherwise
117
              -> finishHsVar (L l name) ;
118 119 120
            Just (Right [f@(FieldOcc (L _ fn) s)]) ->
                      return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s))
                             , unitFV (selectorFieldOcc f)) ;
121 122
           Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
                                                        PlaceHolder)
123
                                             , mkFVs (map selectorFieldOcc fs));
124
           Just (Right [])         -> panic "runExpr/HsVar" } }
125

126
rnExpr (HsIPVar v)
127
  = return (HsIPVar v, emptyFVs)
128

129 130 131 132 133 134
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
135

136
rnExpr (HsLit lit@(HsString src s))
137
  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
138
       ; if opt_OverloadedStrings then
139
            rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
140 141 142
         else do {
            ; rnLit lit
            ; return (HsLit lit, emptyFVs) } }
143

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
144
rnExpr (HsLit lit)
145 146
  = do { rnLit lit
       ; return (HsLit lit, emptyFVs) }
147

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
148
rnExpr (HsOverLit lit)
149 150
  = do { (lit', fvs) <- rnOverLit lit
       ; return (HsOverLit lit', fvs) }
151

152
rnExpr (HsApp fun arg)
153 154 155
  = do { (fun',fvFun) <- rnLExpr fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
156

157 158 159 160 161
rnExpr (HsAppType fun arg)
  = do { (fun',fvFun) <- rnLExpr fun
       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
       ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }

162
rnExpr (OpApp e1 op  _ e2)
163
  = do  { (e1', fv_e1) <- rnLExpr e1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
164
        ; (e2', fv_e2) <- rnLExpr e2
165 166
        ; (op', fv_op) <- rnLExpr op

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
167 168 169 170 171
        -- 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.
172
        ; fixity <- case op' of
173 174
              L _ (HsVar (L _ n)) -> lookupFixityRn n
              L _ (HsRecFld f)    -> lookupFieldFixityRn f
Alan Zimmerman's avatar
Alan Zimmerman committed
175
              _ -> return (Fixity NoSourceText minPrecedence InfixL)
176
                   -- c.f. lookupFixity for unbound
177 178

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

181
rnExpr (NegApp e _)
182 183 184 185
  = 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) }
186

187
------------------------------------------
188
-- Template Haskell extensions
189 190
-- 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
191 192
rnExpr e@(HsBracket br_body) = rnBracket e br_body

193
rnExpr (HsSpliceE splice) = rnSpliceExpr splice
194

195
---------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
196
--      Sections
thomie's avatar
thomie committed
197
-- See Note [Parsing sections] in Parser.y
198
rnExpr (HsPar (L loc (section@(SectionL {}))))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
199 200
  = do  { (section', fvs) <- rnSection section
        ; return (HsPar (L loc section'), fvs) }
201 202

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

206
rnExpr (HsPar e)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
207 208
  = do  { (e', fvs_e) <- rnLExpr e
        ; return (HsPar e', fvs_e) }
209

210
rnExpr expr@(SectionL {})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
211
  = do  { addErr (sectionErr expr); rnSection expr }
212
rnExpr expr@(SectionR {})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
213
  = do  { addErr (sectionErr expr); rnSection expr }
214 215

---------------------------------------------
Alan Zimmerman's avatar
Alan Zimmerman committed
216
rnExpr (HsCoreAnn src ann expr)
217
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
218
       ; return (HsCoreAnn src ann expr', fvs_expr) }
219

Alan Zimmerman's avatar
Alan Zimmerman committed
220
rnExpr (HsSCC src lbl expr)
221
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
222
       ; return (HsSCC src lbl expr', fvs_expr) }
223
rnExpr (HsTickPragma src info srcInfo expr)
224
  = do { (expr', fvs_expr) <- rnLExpr expr
225
       ; return (HsTickPragma src info srcInfo expr', fvs_expr) }
226

227
rnExpr (HsLam matches)
228 229
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
       ; return (HsLam matches', fvMatch) }
230

Simon Peyton Jones's avatar
Simon Peyton Jones committed
231
rnExpr (HsLamCase matches)
232
  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
Simon Peyton Jones's avatar
Simon Peyton Jones committed
233
       ; return (HsLamCase matches', fvs_ms) }
234

235
rnExpr (HsCase expr matches)
236 237 238
  = 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) }
239

240
rnExpr (HsLet (L l binds) expr)
Simon Marlow's avatar
Simon Marlow committed
241
  = rnLocalBindsAndThen binds $ \binds' _ -> do
242
      { (expr',fvExpr) <- rnLExpr expr
243
      ; return (HsLet (L l binds') expr', fvExpr) }
244

245
rnExpr (HsDo do_or_lc (L l stmts) _)
Simon Marlow's avatar
Simon Marlow committed
246 247 248 249
  = do  { ((stmts', _), fvs) <-
           rnStmtsWithPostProcessing do_or_lc rnLExpr
             postProcessStmtsForApplicativeDo stmts
             (\ _ -> return ((), emptyFVs))
250
        ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
251

252
rnExpr (ExplicitList _ _  exps)
253
  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
254
        ; (exps', fvs) <- rnExprs exps
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
255
        ; if opt_OverloadedLists
256
           then do {
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
257
            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
258 259
            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
                     , fvs `plusFV` fvs') }
260 261
           else
            return  (ExplicitList placeHolderType Nothing exps', fvs) }
262

chak's avatar
chak committed
263
rnExpr (ExplicitPArr _ exps)
264 265
  = do { (exps', fvs) <- rnExprs exps
       ; return  (ExplicitPArr placeHolderType exps', fvs) }
chak's avatar
chak committed
266

267 268 269 270 271 272
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
273 274 275 276
    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)
277

278 279 280 281
rnExpr (ExplicitSum alt arity expr _)
  = do { (expr', fvs) <- rnLExpr expr
       ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }

282 283 284 285 286 287 288 289 290 291 292 293 294
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) }
295

296
rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
297
  = do  { (expr', fvExpr) <- rnLExpr expr
Adam Gundry's avatar
Adam Gundry committed
298
        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
299 300 301
        ; 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
302
                 , fvExpr `plusFV` fvRbinds) }
303

304 305 306 307 308
rnExpr (ExprWithTySig expr pty)
  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                             rnLExpr expr
        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
309

310 311
rnExpr (HsIf _ p b1 b2)
  = do { (p', fvP) <- rnLExpr p
312 313 314 315
       ; (b1', fvB1) <- rnLExpr b1
       ; (b2', fvB2) <- rnLExpr b2
       ; (mb_ite, fvITE) <- lookupIfThenElse
       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
316

317
rnExpr (HsMultiIf _ty alts)
318
  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
319 320
       -- ; return (HsMultiIf ty alts', fvs) }
       ; return (HsMultiIf placeHolderType alts', fvs) }
321

322
rnExpr (ArithSeq _ _ seq)
323
  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
324
       ; (new_seq, fvs) <- rnArithSeq seq
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
325
       ; if opt_OverloadedLists
326
           then do {
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
327 328
            ; (from_list_name, fvs') <- lookupSyntaxName fromListName
            ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
329 330
           else
            return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
chak's avatar
chak committed
331

332
rnExpr (PArrSeq _ seq)
333 334
  = do { (new_seq, fvs) <- rnArithSeq seq
       ; return (PArrSeq noPostTcExpr new_seq, fvs) }
335

Austin Seipp's avatar
Austin Seipp committed
336
{-
337 338 339
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
340
-}
341

342
rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
343 344 345 346 347 348 349 350
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)
       }
351 352
rnExpr e@(EViewPat {}) = patSynErr e empty
rnExpr e@(ELazyPat {}) = patSynErr e empty
353

Facundo Domínguez's avatar
Facundo Domínguez committed
354 355 356 357 358 359 360 361 362
{-
************************************************************************
*                                                                      *
        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
363
wired-in. See the Notes about the NameSorts in Name.hs.
Facundo Domínguez's avatar
Facundo Domínguez committed
364 365
-}

366
rnExpr e@(HsStatic _ expr) = do
Facundo Domínguez's avatar
Facundo Domínguez committed
367 368 369 370 371 372 373
    (expr',fvExpr) <- rnLExpr expr
    stage <- getStage
    case stage of
      Splice _ -> addErr $ sep
             [ text "static forms cannot be used in splices:"
             , nest 2 $ ppr e
             ]
374 375 376 377
      _ -> return ()
    mod <- getModule
    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
    return (HsStatic fvExpr' expr', fvExpr)
Facundo Domínguez's avatar
Facundo Domínguez committed
378

Austin Seipp's avatar
Austin Seipp committed
379 380 381
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
382
        Arrow notation
Austin Seipp's avatar
Austin Seipp committed
383 384 385
*                                                                      *
************************************************************************
-}
386

387
rnExpr (HsProc pat body)
ross's avatar
ross committed
388
  = newArrowScope $
389 390 391
    rnPat ProcExpr pat $ \ pat' -> do
      { (body',fvBody) <- rnCmdTop body
      ; return (HsProc pat' body', fvBody) }
392

393 394 395
-- 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
396

397
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
398
        -- HsWrap
399

400
hsHoleExpr :: HsExpr id
401
hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
402

403 404
arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
arrowFail e
405
  = do { addErr (vcat [ text "Arrow command found where an expression was expected:"
406 407 408
                      , nest 2 (ppr e) ])
         -- Return a place-holder hole, so that we can carry on
         -- to report other errors
409
       ; return (hsHoleExpr, emptyFVs) }
410

411
----------------------
thomie's avatar
thomie committed
412
-- See Note [Parsing sections] in Parser.y
413 414
rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
rnSection section@(SectionR op expr)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
415 416 417 418
  = 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) }
419 420

rnSection section@(SectionL expr op)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
421 422 423 424
  = 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) }
425 426

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

Austin Seipp's avatar
Austin Seipp committed
428 429 430
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
431
        Arrow commands
Austin Seipp's avatar
Austin Seipp committed
432 433 434
*                                                                      *
************************************************************************
-}
435

Ian Lynagh's avatar
Ian Lynagh committed
436
rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
437
rnCmdArgs [] = return ([], emptyFVs)
438
rnCmdArgs (arg:args)
439 440 441
  = do { (arg',fvArg) <- rnCmdTop arg
       ; (args',fvArgs) <- rnCmdArgs args
       ; return (arg':args', fvArg `plusFV` fvArgs) }
442

Ian Lynagh's avatar
Ian Lynagh committed
443
rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
444 445
rnCmdTop = wrapLocFstM rnCmdTop'
 where
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
446
  rnCmdTop' (HsCmdTop cmd _ _ _)
447 448
   = do { (cmd', fvCmd) <- rnLCmd cmd
        ; let cmd_names = [arrAName, composeAName, firstAName] ++
niteria's avatar
niteria committed
449
                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
450
        -- Generate the rebindable syntax for the monad
451
        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
452

453 454
        ; return (HsCmdTop cmd' placeHolderType placeHolderType
                  (cmd_names `zip` cmd_names'),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
455
                  fvCmd `plusFV` cmd_fvs) }
456

457 458 459 460 461 462
rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
rnLCmd = wrapLocFstM rnCmd

rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)

rnCmd (HsCmdArrApp arrow arg _ ho rtl)
463 464 465 466
  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
                 fvArrow `plusFV` fvArg) }
467 468 469 470 471
  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
472 473 474 475
        -- 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.
476

477
-- infix form
Alan Zimmerman's avatar
Alan Zimmerman committed
478
rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
479
  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
480
       ; let L _ (HsVar (L _ op_name)) = op'
481 482
       ; (arg1',fv_arg1) <- rnCmdTop arg1
       ; (arg2',fv_arg2) <- rnCmdTop arg2
483
        -- Deal with fixity
484 485 486
       ; fixity <- lookupFixityRn op_name
       ; final_e <- mkOpFormRn arg1' op' fixity arg2'
       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
487

Alan Zimmerman's avatar
Alan Zimmerman committed
488
rnCmd (HsCmdArrForm op f fixity cmds)
489 490
  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
       ; (cmds',fvCmds) <- rnCmdArgs cmds
Alan Zimmerman's avatar
Alan Zimmerman committed
491
       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
492

493
rnCmd (HsCmdApp fun arg)
494 495 496
  = do { (fun',fvFun) <- rnLCmd  fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
497

498
rnCmd (HsCmdLam matches)
499 500
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
       ; return (HsCmdLam matches', fvMatch) }
501

502 503 504
rnCmd (HsCmdPar e)
  = do  { (e', fvs_e) <- rnLCmd e
        ; return (HsCmdPar e', fvs_e) }
505

506
rnCmd (HsCmdCase expr matches)
507 508 509
  = 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) }
510

511 512 513 514 515 516
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]) }
517

518
rnCmd (HsCmdLet (L l binds) cmd)
Simon Marlow's avatar
Simon Marlow committed
519
  = rnLocalBindsAndThen binds $ \ binds' _ -> do
520
      { (cmd',fvExpr) <- rnLCmd cmd
521
      ; return (HsCmdLet (L l binds') cmd', fvExpr) }
522

523
rnCmd (HsCmdDo (L l stmts) _)
Simon Marlow's avatar
Simon Marlow committed
524 525
  = do  { ((stmts', _), fvs) <-
            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
526
        ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
527

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
528
rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
529 530

---------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
531 532
type CmdNeeds = FreeVars        -- Only inhabitants are
                                --      appAName, choiceAName, loopAName
533 534

-- find what methods the Cmd needs (loop, choice, apply)
535 536 537
methodNamesLCmd :: LHsCmd Name -> CmdNeeds
methodNamesLCmd = methodNamesCmd . unLoc

538 539
methodNamesCmd :: HsCmd Name -> CmdNeeds

540
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
541
  = emptyFVs
542
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
543
  = unitFV appAName
544
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
545
methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
546

547
methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
548

549
methodNamesCmd (HsCmdIf _ _ c1 c2)
550
  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
551

552 553 554 555
methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c
methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c
methodNamesCmd (HsCmdLam match)        = methodNamesMatch match
556

557
methodNamesCmd (HsCmdCase _ matches)
558
  = methodNamesMatch matches `addOneFV` choiceAName
559

560
--methodNamesCmd _ = emptyFVs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
561
   -- Other forms can't occur in commands, but it's not convenient
562 563 564 565
   -- to error here so we just do what's convenient.
   -- The type checker will complain later

---------------------------------------------------
566
methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
567
methodNamesMatch (MG { mg_alts = L _ ms })
568
  = plusFVs (map do_one ms)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
569
 where
Alan Zimmerman's avatar
Alan Zimmerman committed
570
    do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
571 572

-------------------------------------------------
573
-- gaw 2004
574
methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
Ian Lynagh's avatar
Ian Lynagh committed
575
methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
576 577

-------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
578

579
methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
Ian Lynagh's avatar
Ian Lynagh committed
580
methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
581 582

---------------------------------------------------
583
methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
584
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
585 586

---------------------------------------------------
587
methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
588 589
methodNamesLStmt = methodNamesStmt . unLoc

590
methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
Simon Marlow's avatar
Simon Marlow committed
591
methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd
592
methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
593
methodNamesStmt (BindStmt _ cmd _ _ _)           = methodNamesLCmd cmd
Simon Marlow's avatar
Simon Marlow committed
594 595
methodNamesStmt (RecStmt { recS_stmts = stmts }) =
  methodNamesStmts stmts `addOneFV` loopAName
596 597
methodNamesStmt (LetStmt {})                     = emptyFVs
methodNamesStmt (ParStmt {})                     = emptyFVs
598
methodNamesStmt (TransStmt {})                   = emptyFVs
Simon Marlow's avatar
Simon Marlow committed
599 600 601
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
602

Austin Seipp's avatar
Austin Seipp committed
603 604 605
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
606
        Arithmetic sequences
Austin Seipp's avatar
Austin Seipp committed
607 608 609
*                                                                      *
************************************************************************
-}
610

Ian Lynagh's avatar
Ian Lynagh committed
611
rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
612
rnArithSeq (From expr)
613 614
 = do { (expr', fvExpr) <- rnLExpr expr
      ; return (From expr', fvExpr) }
615 616

rnArithSeq (FromThen expr1 expr2)
617 618 619
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
620 621

rnArithSeq (FromTo expr1 expr2)
622 623 624
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
625 626

rnArithSeq (FromThenTo expr1 expr2 expr3)
627 628 629 630 631
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; (expr3', fvExpr3) <- rnLExpr expr3
      ; return (FromThenTo expr1' expr2' expr3',
                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
632

Austin Seipp's avatar
Austin Seipp committed
633 634 635
{-
************************************************************************
*                                                                      *
636
\subsubsection{@Stmt@s: in @do@ expressions}
Austin Seipp's avatar
Austin Seipp committed
637 638 639
*                                                                      *
************************************************************************
-}
640

641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
{-
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
662 663 664
-- | Rename some Stmts
rnStmts :: Outputable (body RdrName)
        => HsStmtContext Name
665
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
Simon Marlow's avatar
Simon Marlow committed
666
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
667
        -> [LStmt RdrName (Located (body RdrName))]
Simon Marlow's avatar
Simon Marlow committed
668
           -- ^ Statements
669
        -> ([Name] -> RnM (thing, FreeVars))
Simon Marlow's avatar
Simon Marlow committed
670 671
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
672
        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
Simon Marlow's avatar
Simon Marlow committed
673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700
rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts

-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
rnStmtsWithPostProcessing
        :: Outputable (body RdrName)
        => HsStmtContext Name
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
        -> (HsStmtContext Name
              -> [(LStmt Name (Located (body Name)), FreeVars)]
              -> RnM ([LStmt Name (Located (body Name))], FreeVars))
           -- ^ postprocess the statements
        -> [LStmt RdrName (Located (body RdrName))]
           -- ^ Statements
        -> ([Name] -> RnM (thing, FreeVars))
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
 = do { ((stmts', thing), fvs) <-
          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
      ; return ((pp_stmts, thing), fvs `plusFV` fvs')
      }

-- | maybe rearrange statements according to the ApplicativeDo transformation
postProcessStmtsForApplicativeDo
  :: HsStmtContext Name
Simon Marlow's avatar
Simon Marlow committed
701 702
  -> [(ExprLStmt Name, FreeVars)]
  -> RnM ([ExprLStmt Name], FreeVars)
Simon Marlow's avatar
Simon Marlow committed
703 704 705 706 707
postProcessStmtsForApplicativeDo ctxt stmts
  = do {
       -- rearrange the statements using ApplicativeStmt if
       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
       -- to each Stmt body.
708
         ado_is_on <- xoptM LangExt.ApplicativeDo
Simon Marlow's avatar
Simon Marlow committed
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732
       ; let is_do_expr | DoExpr <- ctxt = True
                        | otherwise = False
       ; if ado_is_on && is_do_expr
            then rearrangeForApplicativeDo ctxt stmts
            else noPostProcessStmts ctxt stmts }

-- | strip the FreeVars annotations from statements
noPostProcessStmts
  :: HsStmtContext Name
  -> [(LStmt Name (Located (body Name)), FreeVars)]
  -> RnM ([LStmt Name (Located (body Name))], FreeVars)
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)


rnStmtsWithFreeVars :: Outputable (body RdrName)
        => HsStmtContext Name
        -> (