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

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 86 87 88 89 90 91 92 93 94 95 96 97 98 99
rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
rnUnboundVar v
 = do { stage <- getStage
      ; if isUnqual v && not (in_untyped_bracket stage)
        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)

        else -- Fail immediately (qualified name, or in untyped bracket)
             do { n <- reportUnboundName v
                ; return (HsVar n, emptyFVs) } }
  where
    in_untyped_bracket (Brack _ (RnPendingUntyped {})) = True
    in_untyped_bracket _ = False

100
rnExpr (HsVar v)
101 102
  = do { mb_name <- lookupOccRn_maybe v
       ; case mb_name of {
103
           Nothing -> rnUnboundVar v ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
104
           Just name
105 106 107
              | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
              -> rnExpr (ExplicitList placeHolderType Nothing [])
108

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
109
              | otherwise
110
              -> finishHsVar name }}
111

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

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

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

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
141 142 143 144 145
        -- 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.
146 147 148 149 150 151
        ; 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
152
        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
153

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

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

166
rnExpr (HsSpliceE splice) = rnSpliceExpr splice
167

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

rnExpr e@(HsStatic expr) = do
324 325 326 327 328 329 330 331 332
    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
333 334 335 336 337 338 339 340 341 342 343 344 345
    (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
346 347 348
       case nameSetElems $ filterNameSet
                             (\n -> not (isTopLevelName n || isUnboundName n))
                             fvExpr                                           of
Facundo Domínguez's avatar
Facundo Domínguez committed
349 350 351 352 353 354 355 356 357 358
         [] -> 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
359 360 361
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
362
        Arrow notation
Austin Seipp's avatar
Austin Seipp committed
363 364 365
*                                                                      *
************************************************************************
-}
366

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

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

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

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

383 384 385 386 387 388
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
389
       ; return (hsHoleExpr, emptyFVs) }
390

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

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

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

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

rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
             -> RnM (HsRecordBinds Name, FreeVars)
rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
419
  = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
420
       ; (flds', fvss) <- mapAndUnzipM rn_field flds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
421
       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
422
                 fvs `plusFV` plusFVs fvss) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
423
  where
424 425
    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
426

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

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

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

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

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

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

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

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

487
rnCmd (HsCmdArrForm op fixity cmds)
488 489 490
  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
       ; (cmds',fvCmds) <- rnCmdArgs cmds
       ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
491

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

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

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

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

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

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

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

527
rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
528 529

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

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

537 538
methodNamesCmd :: HsCmd Name -> CmdNeeds

539
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
540
  = emptyFVs
541
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
542
  = unitFV appAName
543
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
544
methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
545

546
methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
547

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

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

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

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

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

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

-------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
577

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

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

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

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

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

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

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
640 641 642
-- | Rename some Stmts
rnStmts :: Outputable (body RdrName)
        => HsStmtContext Name
643
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
Simon Marlow's avatar
Simon Marlow committed
644
           -- ^ How to rename the body of each statement (e.g. rnLExpr)
645
        -> [LStmt RdrName (Located (body RdrName))]
Simon Marlow's avatar
Simon Marlow committed
646
           -- ^ Statements
647
        -> ([Name] -> RnM (thing, FreeVars))
Simon Marlow's avatar
Simon Marlow committed
648 649
           -- ^ if these statements scope over something, this renames it
           -- and returns the result.
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
650
        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
Simon Marlow's avatar
Simon Marlow committed
651 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
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.
--
711 712 713
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars

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

Simon Marlow's avatar
Simon Marlow committed
719
rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo
720
  = -- Behave like do { rec { ...all but last... }; last }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
721 722 723 724 725
    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) }
726 727
  where
    Just (all_but_last, last_stmt) = snocView stmts
728

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

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

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

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

765
rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
766