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

Simon Marlow's avatar
Simon Marlow committed
13
{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-}
14

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

19 20
#include "HsVersions.h"

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

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

Austin Seipp's avatar
Austin Seipp committed
48 49 50
{-
************************************************************************
*                                                                      *
51
\subsubsection{Expressions}
Austin Seipp's avatar
Austin Seipp committed
52 53 54
*                                                                      *
************************************************************************
-}
55

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

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

70 71 72 73
rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
rnLExpr = wrapLocFstM rnExpr

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

75 76 77
finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
-- Separated from rnExpr because it's also used
-- when renaming infix expressions
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
78
finishHsVar name
79 80 81
 = do { this_mod <- getModule
      ; when (nameIsLocalOrFrom this_mod name) $
        checkThLocalName name
82
      ; return (HsVar name, unitFV name) }
83

84 85
rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
rnUnboundVar v
86
 = do { if isUnqual v
87 88 89 90 91
        then -- Treat this as a "hole"
             -- Do not fail right now; instead, return HsUnboundVar
             -- and let the type checker report the error
             return (HsUnboundVar (rdrNameOcc v), emptyFVs)

92
        else -- Fail immediately (qualified name)
93 94 95
             do { n <- reportUnboundName v
                ; return (HsVar n, emptyFVs) } }

96
rnExpr (HsVar v)
Adam Gundry's avatar
Adam Gundry committed
97
  = do { mb_name <- lookupOccRn_overloaded False v
98
       ; case mb_name of {
99
           Nothing -> rnUnboundVar v ;
Adam Gundry's avatar
Adam Gundry committed
100
           Just (Left name)
101 102 103
              | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
              -> rnExpr (ExplicitList placeHolderType Nothing [])
104

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
105
              | otherwise
Adam Gundry's avatar
Adam Gundry committed
106 107 108 109
              -> finishHsVar name ;
           Just (Right (f:fs)) -> ASSERT( null fs )
                                  return (HsSingleRecFld f, unitFV (selectorFieldOcc f)) ;
           Just (Right [])                 -> error "runExpr/HsVar" } }
110

111
rnExpr (HsIPVar v)
112
  = return (HsIPVar v, emptyFVs)
113

114
rnExpr (HsLit lit@(HsString src s))
115
  = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
116
       ; if opt_OverloadedStrings then
117
            rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
118 119 120
         else do {
            ; rnLit lit
            ; return (HsLit lit, emptyFVs) } }
121

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
122
rnExpr (HsLit lit)
123 124
  = do { rnLit lit
       ; return (HsLit lit, emptyFVs) }
125

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
126
rnExpr (HsOverLit lit)
127 128
  = do { (lit', fvs) <- rnOverLit lit
       ; return (HsOverLit lit', fvs) }
129

130
rnExpr (HsApp fun arg)
131 132 133
  = do { (fun',fvFun) <- rnLExpr fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
134

135
rnExpr (OpApp e1 op  _ e2)
136
  = do  { (e1', fv_e1) <- rnLExpr e1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
137
        ; (e2', fv_e2) <- rnLExpr e2
138 139
        ; (op', fv_op) <- rnLExpr op

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
140 141 142 143 144
        -- 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.
145 146 147 148 149 150
        ; fixity <- case op' of
                      L _ (HsVar n) -> lookupFixityRn n
                      _             -> return (Fixity minPrecedence InfixL)
                                       -- c.f. lookupFixity for unbound

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

153
rnExpr (NegApp e _)
154 155 156 157
  = 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) }
158

159
------------------------------------------
160
-- Template Haskell extensions
161 162
-- 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
163 164
rnExpr e@(HsBracket br_body) = rnBracket e br_body

165
rnExpr (HsSpliceE splice) = rnSpliceExpr splice
166

167
---------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
168
--      Sections
thomie's avatar
thomie committed
169
-- See Note [Parsing sections] in Parser.y
170
rnExpr (HsPar (L loc (section@(SectionL {}))))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
171 172
  = do  { (section', fvs) <- rnSection section
        ; return (HsPar (L loc section'), fvs) }
173 174

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

178
rnExpr (HsPar e)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
179 180
  = do  { (e', fvs_e) <- rnLExpr e
        ; return (HsPar e', fvs_e) }
181

182
rnExpr expr@(SectionL {})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
183
  = do  { addErr (sectionErr expr); rnSection expr }
184
rnExpr expr@(SectionR {})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
185
  = do  { addErr (sectionErr expr); rnSection expr }
186 187

---------------------------------------------
Alan Zimmerman's avatar
Alan Zimmerman committed
188
rnExpr (HsCoreAnn src ann expr)
189
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
190
       ; return (HsCoreAnn src ann expr', fvs_expr) }
191

Alan Zimmerman's avatar
Alan Zimmerman committed
192
rnExpr (HsSCC src lbl expr)
193
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
194 195
       ; return (HsSCC src lbl expr', fvs_expr) }
rnExpr (HsTickPragma src info expr)
196
  = do { (expr', fvs_expr) <- rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
197
       ; return (HsTickPragma src info expr', fvs_expr) }
198

199
rnExpr (HsLam matches)
200 201
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
       ; return (HsLam matches', fvMatch) }
202

203
rnExpr (HsLamCase _arg matches)
204
  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
205 206
       -- ; return (HsLamCase arg matches', fvs_ms) }
       ; return (HsLamCase placeHolderType matches', fvs_ms) }
207

208
rnExpr (HsCase expr matches)
209 210 211
  = 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) }
212

213
rnExpr (HsLet binds expr)
Simon Marlow's avatar
Simon Marlow committed
214
  = rnLocalBindsAndThen binds $ \binds' _ -> do
215
      { (expr',fvExpr) <- rnLExpr expr
216
      ; return (HsLet binds' expr', fvExpr) }
217

218
rnExpr (HsDo do_or_lc stmts _)
Simon Marlow's avatar
Simon Marlow committed
219 220 221 222
  = do  { ((stmts', _), fvs) <-
           rnStmtsWithPostProcessing do_or_lc rnLExpr
             postProcessStmtsForApplicativeDo stmts
             (\ _ -> return ((), emptyFVs))
223
        ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
224

225 226 227
rnExpr (ExplicitList _ _  exps)
  = do  { opt_OverloadedLists <- xoptM Opt_OverloadedLists
        ; (exps', fvs) <- rnExprs exps
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
228
        ; if opt_OverloadedLists
229
           then do {
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
230
            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
231 232
            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
                     , fvs `plusFV` fvs') }
233 234
           else
            return  (ExplicitList placeHolderType Nothing exps', fvs) }
235

chak's avatar
chak committed
236
rnExpr (ExplicitPArr _ exps)
237 238
  = do { (exps', fvs) <- rnExprs exps
       ; return  (ExplicitPArr placeHolderType exps', fvs) }
chak's avatar
chak committed
239

240 241 242 243 244 245
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
246 247 248 249
    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)
250

251
rnExpr (RecordCon con_id _ rbinds)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
252 253 254 255
  = do  { conname <- lookupLocatedOccRn con_id
        ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
        ; return (RecordCon conname noPostTcExpr rbinds',
                  fvRbinds `addOneFV` unLoc conname) }
256

Matthew Pickering's avatar
Matthew Pickering committed
257
rnExpr (RecordUpd expr rbinds _ _ _ _)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
258
  = do  { (expr', fvExpr) <- rnLExpr expr
Adam Gundry's avatar
Adam Gundry committed
259
        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
Matthew Pickering's avatar
Matthew Pickering committed
260 261 262 263
        ; return (RecordUpd expr' rbinds'
                            PlaceHolder PlaceHolder
                            PlaceHolder PlaceHolder
                 , fvExpr `plusFV` fvRbinds) }
264

thomasw's avatar
thomasw committed
265
rnExpr (ExprWithTySig expr pty PlaceHolder)
thomasw's avatar
thomasw committed
266 267 268 269
  = do  { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
        ; (expr', fvExpr)   <- bindSigTyVarsFV (hsExplicitTvs pty') $
                               rnLExpr expr
        ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) }
270

271 272
rnExpr (HsIf _ p b1 b2)
  = do { (p', fvP) <- rnLExpr p
273 274 275 276
       ; (b1', fvB1) <- rnLExpr b1
       ; (b2', fvB2) <- rnLExpr b2
       ; (mb_ite, fvITE) <- lookupIfThenElse
       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
277

278
rnExpr (HsMultiIf _ty alts)
279
  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
280 281
       -- ; return (HsMultiIf ty alts', fvs) }
       ; return (HsMultiIf placeHolderType alts', fvs) }
282

283
rnExpr (HsType a)
284 285
  = do { (t, fvT) <- rnLHsType HsTypeCtx a
       ; return (HsType t, fvT) }
286

287 288 289
rnExpr (ArithSeq _ _ seq)
  = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
       ; (new_seq, fvs) <- rnArithSeq seq
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
290
       ; if opt_OverloadedLists
291
           then do {
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
292 293
            ; (from_list_name, fvs') <- lookupSyntaxName fromListName
            ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
294 295
           else
            return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
chak's avatar
chak committed
296

297
rnExpr (PArrSeq _ seq)
298 299
  = do { (new_seq, fvs) <- rnArithSeq seq
       ; return (PArrSeq noPostTcExpr new_seq, fvs) }
300

Austin Seipp's avatar
Austin Seipp committed
301
{-
302 303 304
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
305
-}
306

307
rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
308
rnExpr e@(EAsPat {})   = patSynErr e
309
rnExpr e@(EViewPat {}) = patSynErr e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
310
rnExpr e@(ELazyPat {}) = patSynErr e
311

Facundo Domínguez's avatar
Facundo Domínguez committed
312 313 314 315 316 317 318 319 320
{-
************************************************************************
*                                                                      *
        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
321
wired-in. See the Notes about the NameSorts in Name.hs.
Facundo Domínguez's avatar
Facundo Domínguez committed
322 323 324
-}

rnExpr e@(HsStatic expr) = do
325 326 327 328 329 330 331 332 333
    target <- fmap hscTarget getDynFlags
    case target of
      -- SPT entries are expected to exist in object code so far, and this is
      -- not the case in interpreted mode. See bug #9878.
      HscInterpreted -> addErr $ sep
        [ text "The static form is not supported in interpreted mode."
        , text "Please use -fobject-code."
        ]
      _ -> return ()
Facundo Domínguez's avatar
Facundo Domínguez committed
334 335 336 337 338 339 340 341 342 343 344 345 346
    (expr',fvExpr) <- rnLExpr expr
    stage <- getStage
    case stage of
      Brack _ _ -> return () -- Don't check names if we are inside brackets.
                             -- We don't want to reject cases like:
                             -- \e -> [| static $(e) |]
                             -- if $(e) turns out to produce a legal expression.
      Splice _ -> addErr $ sep
             [ text "static forms cannot be used in splices:"
             , nest 2 $ ppr e
             ]
      _ -> do
       let isTopLevelName n = isExternalName n || isWiredInName n
347 348 349
       case nameSetElems $ filterNameSet
                             (\n -> not (isTopLevelName n || isUnboundName n))
                             fvExpr                                           of
Facundo Domínguez's avatar
Facundo Domínguez committed
350 351 352 353 354 355 356 357 358 359
         [] -> return ()
         fvNonGlobal -> addErr $ cat
             [ text $ "Only identifiers of top-level bindings can "
                      ++ "appear in the body of the static form:"
             , nest 2 $ ppr e
             , text "but the following identifiers were found instead:"
             , nest 2 $ vcat $ map ppr fvNonGlobal
             ]
    return (HsStatic expr', fvExpr)

Austin Seipp's avatar
Austin Seipp committed
360 361 362
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
363
        Arrow notation
Austin Seipp's avatar
Austin Seipp committed
364 365 366
*                                                                      *
************************************************************************
-}
367

368
rnExpr (HsProc pat body)
ross's avatar
ross committed
369
  = newArrowScope $
370 371 372
    rnPat ProcExpr pat $ \ pat' -> do
      { (body',fvBody) <- rnCmdTop body
      ; return (HsProc pat' body', fvBody) }
373

374 375 376
-- 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
377

378
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
379
        -- HsWrap
380

381 382
hsHoleExpr :: HsExpr id
hsHoleExpr = HsUnboundVar (mkVarOcc "_")
383

384 385 386 387 388 389
arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
arrowFail e
  = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
                      , nest 2 (ppr e) ])
         -- Return a place-holder hole, so that we can carry on
         -- to report other errors
390
       ; return (hsHoleExpr, emptyFVs) }
391

392
----------------------
thomie's avatar
thomie committed
393
-- See Note [Parsing sections] in Parser.y
394 395
rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
rnSection section@(SectionR op expr)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
396 397 398 399
  = 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) }
400 401

rnSection section@(SectionL expr op)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
402 403 404 405
  = 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) }
406 407

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

Austin Seipp's avatar
Austin Seipp committed
409 410 411
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
412
        Records
Austin Seipp's avatar
Austin Seipp committed
413 414 415
*                                                                      *
************************************************************************
-}
416 417 418 419

rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
             -> RnM (HsRecordBinds Name, FreeVars)
rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
420
  = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
421
       ; (flds', fvss) <- mapAndUnzipM rn_field flds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
422
       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
423
                 fvs `plusFV` plusFVs fvss) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
424
  where
425 426
    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
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] ++
449
                          nameSetElems (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 478
-- infix form
rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
479 480 481 482
  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
       ; let L _ (HsVar op_name) = op'
       ; (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

488
rnCmd (HsCmdArrForm op fixity cmds)
489 490 491
  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
       ; (cmds',fvCmds) <- rnCmdArgs cmds
       ; return (HsCmdArrForm op' 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 binds cmd)
Simon Marlow's avatar
Simon Marlow committed
519
  = rnLocalBindsAndThen binds $ \ binds' _ -> do
520
      { (cmd',fvExpr) <- rnLCmd cmd
521
      ; return (HsCmdLet binds' cmd', fvExpr) }
522

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

528
rnCmd cmd@(HsCmdCast {}) = 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
545
methodNamesCmd (HsCmdCast _ 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 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 = 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

Simon Marlow's avatar
Simon Marlow committed
641 642 643
-- | Rename some Stmts
rnStmts :: Outputable (body RdrName)
        => HsStmtContext Name
644
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
Simon Marlow's avatar
Simon Marlow committed
645
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
646
        -> [LStmt RdrName (Located (body RdrName))]
Simon Marlow's avatar
Simon Marlow committed
647
           -- ^ Statements
648
        -> ([Name] -> RnM (thing, FreeVars))
Simon Marlow's avatar
Simon Marlow committed
649 650
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
651
        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
Simon Marlow's avatar
Simon Marlow committed
652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 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 701 702 703 704 705 706 707 708 709 710 711
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
  -> [(LStmt Name (LHsExpr Name), FreeVars)]
  -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
postProcessStmtsForApplicativeDo ctxt stmts
  = do {
       -- rearrange the statements using ApplicativeStmt if
       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
       -- to each Stmt body.
         ado_is_on <- xoptM Opt_ApplicativeDo
       ; 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
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
        -> [LStmt RdrName (Located (body RdrName))]
        -> ([Name] -> RnM (thing, FreeVars))
        -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
               , FreeVars)
-- Each Stmt body is annotated with its FreeVars, so that
-- we can rearrange statements for ApplicativeDo.
--
712 713 714
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars

Simon Marlow's avatar
Simon Marlow committed
715
rnStmtsWithFreeVars ctxt _ [] thing_inside
716
  = do { checkEmptyStmts ctxt
717 718 719
       ; (thing, fvs) <- thing_inside []
       ; return (([], thing), fvs) }

Simon Marlow's avatar
Simon Marlow committed
720
rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo
721
  = -- Behave like do { rec { ...all but last... }; last }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
722 723 724 725 726
    do { ((stmts1, (stmts2, thing)), fvs)
           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
              do { last_stmt' <- checkLastStmt MDoExpr last_stmt
                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
        ; return (((stmts1 ++ stmts2), thing), fvs) }
727 728
  where
    Just (all_but_last, last_stmt) = snocView stmts
729

Simon Marlow's avatar
Simon Marlow committed
730
rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
731
  | null lstmts
732
  = setSrcSpan loc $
733
    do { lstmt' <- checkLastStmt ctxt lstmt
734
       ; rnStmt ctxt rnBody lstmt' thing_inside }
735 736

  | otherwise
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
737
  = do { ((stmts1, (stmts2, thing)), fvs)
738
            <- setSrcSpan loc                         $
739
               do { checkStmt ctxt lstmt
740
                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
Simon Marlow's avatar
Simon Marlow committed
741
                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->
742
                    thing_inside (bndrs1 ++ bndrs2) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
743
        ; return (((stmts1 ++ stmts2), thing), fvs) }
744

745
----------------------
Simon Marlow's avatar
Simon Marlow committed
746 747
rnStmt :: Outputable (body RdrName)
       => HsStmtContext Name
748
       -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
Simon Marlow's avatar
Simon Marlow committed
749
          -- ^ How to rename the body of the statement
750
       -> LStmt RdrName (Located (body RdrName))
Simon Marlow's avatar
Simon Marlow committed
751
          -- ^ The statement
752
       -> ([Name] -> RnM (thing, FreeVars))
Simon Marlow's avatar
Simon Marlow committed
753 754 755
          -- ^ Rename the stuff that this statement scopes over
       -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
              , FreeVars)
756 757
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
758

Simon Marlow's avatar
Simon Marlow committed
759
rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
760 761 762
  = do  { (body', fv_expr) <- rnBody body
        ; (ret_op, fvs1)   <- lookupStmtName ctxt returnMName
        ; (thing,  fvs3)   <- thing_inside []
Simon Marlow's avatar
Simon Marlow committed
763
        ; return (([(L loc (LastStmt body'