RnExpr.hs 71.8 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)
97 98
  = do { opt_DuplicateRecordFields <- xoptM Opt_DuplicateRecordFields
       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
99
       ; case mb_name of {
100
           Nothing -> rnUnboundVar v ;
Adam Gundry's avatar
Adam Gundry committed
101
           Just (Left name)
102 103 104
              | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
              -> rnExpr (ExplicitList placeHolderType Nothing [])
105

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
106
              | otherwise
Adam Gundry's avatar
Adam Gundry committed
107
              -> finishHsVar name ;
108 109 110 111 112
           Just (Right [f])        -> return (HsRecFld (ambiguousFieldOcc f)
                                             , unitFV (selectorFieldOcc f)) ;
           Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
                                             , mkFVs (map selectorFieldOcc fs));
           Just (Right [])         -> error "runExpr/HsVar" } }
113

114
rnExpr (HsIPVar v)
115
  = return (HsIPVar v, emptyFVs)
116

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

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

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

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

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

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

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

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

168
rnExpr (HsSpliceE splice) = rnSpliceExpr splice
169

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

286
rnExpr (HsType a)
287 288
  = do { (t, fvT) <- rnLHsType HsTypeCtx a
       ; return (HsType t, fvT) }
289

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

300
rnExpr (PArrSeq _ seq)
301 302
  = do { (new_seq, fvs) <- rnArithSeq seq
       ; return (PArrSeq noPostTcExpr new_seq, fvs) }
303

Austin Seipp's avatar
Austin Seipp committed
304
{-
305 306 307
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
308
-}
309

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

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

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

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

377 378 379
-- 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
380

381
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
382
        -- HsWrap
383

384 385
hsHoleExpr :: HsExpr id
hsHoleExpr = HsUnboundVar (mkVarOcc "_")
386

387 388 389 390 391 392
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
393
       ; return (hsHoleExpr, emptyFVs) }
394

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
431 432 433
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
434
        Arrow commands
Austin Seipp's avatar
Austin Seipp committed
435 436 437
*                                                                      *
************************************************************************
-}
438

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

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

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

460 461 462 463 464 465
rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
rnLCmd = wrapLocFstM rnCmd

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

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

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

491
rnCmd (HsCmdArrForm op fixity cmds)
492 493 494
  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
       ; (cmds',fvCmds) <- rnCmdArgs cmds
       ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
495

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

501
rnCmd (HsCmdLam matches)
502 503
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
       ; return (HsCmdLam matches', fvMatch) }
504

505 506 507
rnCmd (HsCmdPar e)
  = do  { (e', fvs_e) <- rnLCmd e
        ; return (HsCmdPar e', fvs_e) }
508

509
rnCmd (HsCmdCase expr matches)
510 511 512
  = 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) }
513

514 515 516 517 518 519
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]) }
520

521
rnCmd (HsCmdLet binds cmd)
Simon Marlow's avatar
Simon Marlow committed
522
  = rnLocalBindsAndThen binds $ \ binds' _ -> do
523
      { (cmd',fvExpr) <- rnLCmd cmd
524
      ; return (HsCmdLet binds' cmd', fvExpr) }
525

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

531
rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
532 533

---------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
534 535
type CmdNeeds = FreeVars        -- Only inhabitants are
                                --      appAName, choiceAName, loopAName
536 537

-- find what methods the Cmd needs (loop, choice, apply)
538 539 540
methodNamesLCmd :: LHsCmd Name -> CmdNeeds
methodNamesLCmd = methodNamesCmd . unLoc

541 542
methodNamesCmd :: HsCmd Name -> CmdNeeds

543
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
544
  = emptyFVs
545
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
546
  = unitFV appAName
547
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
548
methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
549

550
methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
551

552
methodNamesCmd (HsCmdIf _ _ c1 c2)
553
  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
554

555 556 557 558
methodNamesCmd (HsCmdLet _ c)      = methodNamesLCmd c
methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
methodNamesCmd (HsCmdApp c _)      = methodNamesLCmd c
methodNamesCmd (HsCmdLam match)    = methodNamesMatch match
559

560
methodNamesCmd (HsCmdCase _ matches)
561
  = methodNamesMatch matches `addOneFV` choiceAName
562

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

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

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

-------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
581

582
methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
Ian Lynagh's avatar
Ian Lynagh committed
583
methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
584 585

---------------------------------------------------
586
methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
587
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
588 589

---------------------------------------------------
590
methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
591 592
methodNamesLStmt = methodNamesStmt . unLoc

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

Austin Seipp's avatar
Austin Seipp committed
606 607 608
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
609
        Arithmetic sequences
Austin Seipp's avatar
Austin Seipp committed
610 611 612
*                                                                      *
************************************************************************
-}
613

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

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

rnArithSeq (FromTo expr1 expr2)
625 626 627
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
628 629

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

Austin Seipp's avatar
Austin Seipp committed
636 637 638
{-
************************************************************************
*                                                                      *
639
\subsubsection{@Stmt@s: in @do@ expressions}
Austin Seipp's avatar
Austin Seipp committed
640 641 642
*                                                                      *
************************************************************************
-}
643

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

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

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
762
rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
763