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

13 14
{-# LANGUAGE CPP, ScopedTypeVariables #-}

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 22
import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )

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

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

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

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

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

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

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

77 78 79
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
80
finishHsVar name
81 82 83
 = do { this_mod <- getModule
      ; when (nameIsLocalOrFrom this_mod name) $
        checkThLocalName name
84
      ; return (HsVar name, unitFV name) }
85

86
rnExpr (HsVar v)
87 88
  = do { mb_name <- lookupOccRn_maybe v
       ; case mb_name of {
89
           Nothing -> do { if startsWithUnderscore (rdrNameOcc v)
90 91
                           then return (HsUnboundVar v, emptyFVs)
                           else do { n <- reportUnboundName v; finishHsVar n } } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
92
           Just name
93 94 95
              | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                       -- OverloadedLists works correctly
              -> rnExpr (ExplicitList placeHolderType Nothing [])
96

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
97
              | otherwise
98
              -> finishHsVar name }}
99

100
rnExpr (HsIPVar v)
101
  = return (HsIPVar v, emptyFVs)
102

103
rnExpr (HsLit lit@(HsString src s))
104
  = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
105
       ; if opt_OverloadedStrings then
106
            rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
107 108 109
         else do {
            ; rnLit lit
            ; return (HsLit lit, emptyFVs) } }
110

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
111
rnExpr (HsLit lit)
112 113
  = do { rnLit lit
       ; return (HsLit lit, emptyFVs) }
114

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
115
rnExpr (HsOverLit lit)
116 117
  = do { (lit', fvs) <- rnOverLit lit
       ; return (HsOverLit lit', fvs) }
118

119
rnExpr (HsApp fun arg)
120 121 122
  = do { (fun',fvFun) <- rnLExpr fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
123

124 125
rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
  = do  { (e1', fv_e1) <- rnLExpr e1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
126 127 128 129 130 131 132 133 134 135 136 137 138
        ; (e2', fv_e2) <- rnLExpr e2
        ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
        ; (op', fv_op) <- finishHsVar op_name
                -- NB: op' is usually just a variable, but might be
                --     an applicatoin (assert "Foo.hs:47")
        -- 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.
        ; fixity <- lookupFixityRn op_name
        ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
139
rnExpr (OpApp _ other_op _ _)
140
  = failWith (vcat [ hang (ptext (sLit "Infix application with a non-variable operator:"))
141 142
                        2 (ppr other_op)
                   , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
143

144
rnExpr (NegApp e _)
145 146 147 148
  = 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) }
149

150
------------------------------------------
151
-- Template Haskell extensions
152 153
-- 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
154 155
rnExpr e@(HsBracket br_body) = rnBracket e br_body

156
rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice
157

158

Ian Lynagh's avatar
Ian Lynagh committed
159
rnExpr (HsQuasiQuoteE qq)
160 161 162 163
  = do { lexpr' <- runQuasiQuoteExpr qq
         -- Wrap the result of the quasi-quoter in parens so that we don't
         -- lose the outermost location set by runQuasiQuote (#7918)
       ; rnExpr (HsPar lexpr') }
164

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

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

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

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

---------------------------------------------
186
rnExpr (HsCoreAnn ann expr)
187 188
  = do { (expr', fvs_expr) <- rnLExpr expr
       ; return (HsCoreAnn ann expr', fvs_expr) }
189

190
rnExpr (HsSCC lbl expr)
191 192
  = do { (expr', fvs_expr) <- rnLExpr expr
       ; return (HsSCC lbl expr', fvs_expr) }
andy@galois.com's avatar
andy@galois.com committed
193
rnExpr (HsTickPragma info expr)
194 195
  = do { (expr', fvs_expr) <- rnLExpr expr
       ; return (HsTickPragma info expr', fvs_expr) }
196

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

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

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

rnExpr (HsLet binds expr)
212 213 214
  = rnLocalBindsAndThen binds $ \binds' -> do
      { (expr',fvExpr) <- rnLExpr expr
      ; return (HsLet binds' expr', fvExpr) }
215

216
rnExpr (HsDo do_or_lc stmts _)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
217 218
  = do  { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs))
        ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
219

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

chak's avatar
chak committed
231
rnExpr (ExplicitPArr _ exps)
232 233
  = do { (exps', fvs) <- rnExprs exps
       ; return  (ExplicitPArr placeHolderType exps', fvs) }
chak's avatar
chak committed
234

235 236 237 238 239 240
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
241 242 243 244
    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)
245

246
rnExpr (RecordCon con_id _ rbinds)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
247 248 249 250
  = do  { conname <- lookupLocatedOccRn con_id
        ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
        ; return (RecordCon conname noPostTcExpr rbinds',
                  fvRbinds `addOneFV` unLoc conname) }
251

252
rnExpr (RecordUpd expr rbinds _ _ _)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
253 254 255 256
  = do  { (expr', fvExpr) <- rnLExpr expr
        ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
        ; return (RecordUpd expr' rbinds' [] [] [],
                  fvExpr `plusFV` fvRbinds) }
257

thomasw's avatar
thomasw committed
258 259 260 261 262
rnExpr (ExprWithTySig expr pty PlaceHolder)
  = do  { (wcs, pty') <- extractWildcards pty
        ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
          (pty'', fvTy) <- rnLHsType ExprWithTySigCtx pty'
        ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty'') $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
263
                             rnLExpr expr
thomasw's avatar
thomasw committed
264
        ; return (ExprWithTySig expr' pty'' wcs_new, fvExpr `plusFV` fvTy) } }
265

266 267
rnExpr (HsIf _ p b1 b2)
  = do { (p', fvP) <- rnLExpr p
268 269 270 271
       ; (b1', fvB1) <- rnLExpr b1
       ; (b2', fvB2) <- rnLExpr b2
       ; (mb_ite, fvITE) <- lookupIfThenElse
       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
272

273
rnExpr (HsMultiIf _ty alts)
274
  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
275 276
       -- ; return (HsMultiIf ty alts', fvs) }
       ; return (HsMultiIf placeHolderType alts', fvs) }
277

278
rnExpr (HsType a)
279 280
  = do { (t, fvT) <- rnLHsType HsTypeCtx a
       ; return (HsType t, fvT) }
281

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

292
rnExpr (PArrSeq _ seq)
293 294
  = do { (new_seq, fvs) <- rnArithSeq seq
       ; return (PArrSeq noPostTcExpr new_seq, fvs) }
295

Austin Seipp's avatar
Austin Seipp committed
296
{-
297 298 299
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
300
-}
301

302
rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
303
rnExpr e@(EAsPat {})   = patSynErr e
304
rnExpr e@(EViewPat {}) = patSynErr e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
305
rnExpr e@(ELazyPat {}) = patSynErr e
306

Facundo Domínguez's avatar
Facundo Domínguez committed
307 308 309 310 311 312 313 314 315
{-
************************************************************************
*                                                                      *
        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
316
wired-in. See the Notes about the NameSorts in Name.hs.
Facundo Domínguez's avatar
Facundo Domínguez committed
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
-}

rnExpr e@(HsStatic expr) = do
    (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
       case nameSetElems $ filterNameSet (not . isTopLevelName) fvExpr of
         [] -> 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
344 345 346
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
347
        Arrow notation
Austin Seipp's avatar
Austin Seipp committed
348 349 350
*                                                                      *
************************************************************************
-}
351

352
rnExpr (HsProc pat body)
ross's avatar
ross committed
353
  = newArrowScope $
354 355 356
    rnPat ProcExpr pat $ \ pat' -> do
      { (body',fvBody) <- rnCmdTop body
      ; return (HsProc pat' body', fvBody) }
357

358 359 360
-- 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
361

362
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
363
        -- HsWrap
364

365 366 367
hsHoleExpr :: HsExpr Name
hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_"))

368 369 370 371 372 373
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
374
       ; return (hsHoleExpr, emptyFVs) }
375

376
----------------------
thomie's avatar
thomie committed
377
-- See Note [Parsing sections] in Parser.y
378 379
rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
rnSection section@(SectionR op expr)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
380 381 382 383
  = 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) }
384 385

rnSection section@(SectionL expr op)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
386 387 388 389
  = 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) }
390 391

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

Austin Seipp's avatar
Austin Seipp committed
393 394 395
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
396
        Records
Austin Seipp's avatar
Austin Seipp committed
397 398 399
*                                                                      *
************************************************************************
-}
400 401 402 403

rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
             -> RnM (HsRecordBinds Name, FreeVars)
rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
404
  = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
405
       ; (flds', fvss) <- mapAndUnzipM rn_field flds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
406
       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
407
                 fvs `plusFV` plusFVs fvss) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
408
  where
409 410
    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
411

Austin Seipp's avatar
Austin Seipp committed
412 413 414
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
415
        Arrow commands
Austin Seipp's avatar
Austin Seipp committed
416 417 418
*                                                                      *
************************************************************************
-}
419

Ian Lynagh's avatar
Ian Lynagh committed
420
rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
421
rnCmdArgs [] = return ([], emptyFVs)
422
rnCmdArgs (arg:args)
423 424 425
  = do { (arg',fvArg) <- rnCmdTop arg
       ; (args',fvArgs) <- rnCmdArgs args
       ; return (arg':args', fvArg `plusFV` fvArgs) }
426

Ian Lynagh's avatar
Ian Lynagh committed
427
rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
428 429
rnCmdTop = wrapLocFstM rnCmdTop'
 where
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
430
  rnCmdTop' (HsCmdTop cmd _ _ _)
431 432
   = do { (cmd', fvCmd) <- rnLCmd cmd
        ; let cmd_names = [arrAName, composeAName, firstAName] ++
433
                          nameSetElems (methodNamesCmd (unLoc cmd'))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
434
        -- Generate the rebindable syntax for the monad
435
        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
436

437 438
        ; return (HsCmdTop cmd' placeHolderType placeHolderType
                  (cmd_names `zip` cmd_names'),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
439
                  fvCmd `plusFV` cmd_fvs) }
440

441 442 443 444 445 446
rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
rnLCmd = wrapLocFstM rnCmd

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

rnCmd (HsCmdArrApp arrow arg _ ho rtl)
447 448 449 450
  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
                 fvArrow `plusFV` fvArg) }
451 452 453 454 455
  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
456 457 458 459
        -- 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.
460

461 462
-- infix form
rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
463 464 465 466
  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
       ; let L _ (HsVar op_name) = op'
       ; (arg1',fv_arg1) <- rnCmdTop arg1
       ; (arg2',fv_arg2) <- rnCmdTop arg2
467
        -- Deal with fixity
468 469 470
       ; fixity <- lookupFixityRn op_name
       ; final_e <- mkOpFormRn arg1' op' fixity arg2'
       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
471

472
rnCmd (HsCmdArrForm op fixity cmds)
473 474 475
  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
       ; (cmds',fvCmds) <- rnCmdArgs cmds
       ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
476

477
rnCmd (HsCmdApp fun arg)
478 479 480
  = do { (fun',fvFun) <- rnLCmd  fun
       ; (arg',fvArg) <- rnLExpr arg
       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
481

482
rnCmd (HsCmdLam matches)
483 484
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
       ; return (HsCmdLam matches', fvMatch) }
485

486 487 488
rnCmd (HsCmdPar e)
  = do  { (e', fvs_e) <- rnLCmd e
        ; return (HsCmdPar e', fvs_e) }
489

490
rnCmd (HsCmdCase expr matches)
491 492 493
  = 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) }
494

495 496 497 498 499 500
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]) }
501

502
rnCmd (HsCmdLet binds cmd)
503 504 505
  = rnLocalBindsAndThen binds $ \ binds' -> do
      { (cmd',fvExpr) <- rnLCmd cmd
      ; return (HsCmdLet binds' cmd', fvExpr) }
506

507 508 509
rnCmd (HsCmdDo stmts _)
  = do  { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
        ; return ( HsCmdDo stmts' placeHolderType, fvs ) }
510

511
rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
512 513

---------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
514 515
type CmdNeeds = FreeVars        -- Only inhabitants are
                                --      appAName, choiceAName, loopAName
516 517

-- find what methods the Cmd needs (loop, choice, apply)
518 519 520
methodNamesLCmd :: LHsCmd Name -> CmdNeeds
methodNamesLCmd = methodNamesCmd . unLoc

521 522
methodNamesCmd :: HsCmd Name -> CmdNeeds

523
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
524
  = emptyFVs
525
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
526
  = unitFV appAName
527
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
528
methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
529

530
methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
531

532
methodNamesCmd (HsCmdIf _ _ c1 c2)
533
  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
534

535
methodNamesCmd (HsCmdLet _ c)      = methodNamesLCmd c
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
536
methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
537 538
methodNamesCmd (HsCmdApp c _)      = methodNamesLCmd c
methodNamesCmd (HsCmdLam match)    = methodNamesMatch match
539

540
methodNamesCmd (HsCmdCase _ matches)
541
  = methodNamesMatch matches `addOneFV` choiceAName
542

543
--methodNamesCmd _ = emptyFVs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
544
   -- Other forms can't occur in commands, but it's not convenient
545 546 547 548
   -- to error here so we just do what's convenient.
   -- The type checker will complain later

---------------------------------------------------
549
methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
550
methodNamesMatch (MG { mg_alts = ms })
551
  = plusFVs (map do_one ms)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
552
 where
Ian Lynagh's avatar
Ian Lynagh committed
553
    do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
554 555

-------------------------------------------------
556
-- gaw 2004
557
methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
Ian Lynagh's avatar
Ian Lynagh committed
558
methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
559 560

-------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
561

562
methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
Ian Lynagh's avatar
Ian Lynagh committed
563
methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
564 565

---------------------------------------------------
566
methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
567
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
568 569

---------------------------------------------------
570
methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
571 572
methodNamesLStmt = methodNamesStmt . unLoc

573
methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
574
methodNamesStmt (LastStmt cmd _)                 = methodNamesLCmd cmd
575
methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
576 577
methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
578 579
methodNamesStmt (LetStmt {})                     = emptyFVs
methodNamesStmt (ParStmt {})                     = emptyFVs
580
methodNamesStmt (TransStmt {})                   = emptyFVs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
581
   -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
582 583
   -- here so we just do what's convenient

Austin Seipp's avatar
Austin Seipp committed
584 585 586
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
587
        Arithmetic sequences
Austin Seipp's avatar
Austin Seipp committed
588 589 590
*                                                                      *
************************************************************************
-}
591

Ian Lynagh's avatar
Ian Lynagh committed
592
rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
593
rnArithSeq (From expr)
594 595
 = do { (expr', fvExpr) <- rnLExpr expr
      ; return (From expr', fvExpr) }
596 597

rnArithSeq (FromThen expr1 expr2)
598 599 600
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
601 602

rnArithSeq (FromTo expr1 expr2)
603 604 605
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
606 607

rnArithSeq (FromThenTo expr1 expr2 expr3)
608 609 610 611 612
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; (expr3', fvExpr3) <- rnLExpr expr3
      ; return (FromThenTo expr1' expr2' expr3',
                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
613

Austin Seipp's avatar
Austin Seipp committed
614 615 616
{-
************************************************************************
*                                                                      *
617
\subsubsection{@Stmt@s: in @do@ expressions}
Austin Seipp's avatar
Austin Seipp committed
618 619 620
*                                                                      *
************************************************************************
-}
621

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
622
rnStmts :: Outputable (body RdrName) => HsStmtContext Name
623 624 625
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
        -> [LStmt RdrName (Located (body RdrName))]
        -> ([Name] -> RnM (thing, FreeVars))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
626
        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
627 628 629
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars

630
rnStmts ctxt _ [] thing_inside
631
  = do { checkEmptyStmts ctxt
632 633 634
       ; (thing, fvs) <- thing_inside []
       ; return (([], thing), fvs) }

635
rnStmts MDoExpr rnBody stmts thing_inside    -- Deal with mdo
636
  = -- Behave like do { rec { ...all but last... }; last }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
637 638 639 640 641
    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) }
642 643
  where
    Just (all_but_last, last_stmt) = snocView stmts
644

645
rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
646
  | null lstmts
647
  = setSrcSpan loc $
648
    do { lstmt' <- checkLastStmt ctxt lstmt
649
       ; rnStmt ctxt rnBody lstmt' thing_inside }
650 651

  | otherwise
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
652
  = do { ((stmts1, (stmts2, thing)), fvs)
653
            <- setSrcSpan loc                         $
654
               do { checkStmt ctxt lstmt
655 656
                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
                    rnStmts ctxt rnBody lstmts  $ \ bndrs2 ->
657
                    thing_inside (bndrs1 ++ bndrs2) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
658
        ; return (((stmts1 ++ stmts2), thing), fvs) }
659

660
----------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
661
rnStmt :: Outputable (body RdrName) => HsStmtContext Name
662 663
       -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
       -> LStmt RdrName (Located (body RdrName))
664
       -> ([Name] -> RnM (thing, FreeVars))
665
       -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
666 667
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
668

669
rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
670 671 672 673 674
  = do  { (body', fv_expr) <- rnBody body
        ; (ret_op, fvs1)   <- lookupStmtName ctxt returnMName
        ; (thing,  fvs3)   <- thing_inside []
        ; return (([L loc (LastStmt body' ret_op)], thing),
                  fv_expr `plusFV` fvs1 `plusFV` fvs3) }
675

676
rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
677 678 679
  = do  { (body', fv_expr) <- rnBody body
        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName
        ; (guard_op, fvs2) <- if isListCompExpr ctxt
680
                              then lookupStmtName ctxt guardMName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
681 682 683 684 685 686 687
                              else return (noSyntaxExpr, emptyFVs)
                              -- Only list/parr/monad comprehensions use 'guard'
                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
                              -- Here "gd" is a guard
        ; (thing, fvs3)    <- thing_inside []
        ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing),
                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
688

689
rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
690 691 692 693 694 695 696 697
  = do  { (body', fv_expr) <- rnBody body
                -- The binders do not scope over the expression
        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
        ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
        { (thing, fvs3) <- thing_inside (collectPatBinders pat')
        ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing),
                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
698
       -- fv_expr shouldn't really be filtered by the rnPatsAndThen
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
699
        -- but it does not matter because the names are unique
700

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
701 702 703
rnStmt _ _ (L loc (LetStmt binds)) thing_inside
  = do  { rnLocalBindsAndThen binds $ \binds' -> do
        { (thing, fvs) <- thing_inside (collectLocalBinders binds')
704
        ; return (([L loc (LetStmt binds')], thing), fvs) }  }
705

706
rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
707 708 709
  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName
        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName
710 711 712
        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op
                                                , recS_mfix_fn = mfix_op
                                                , recS_bind_fn = bind_op }
713

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
714 715 716 717 718 719 720 721 722
        -- Step1: Bring all the binders of the mdo into scope
        -- (Remember that this also removes the binders from the
        -- finally-returned free-vars.)
        -- And rename each individual stmt, making a
        -- singleton segment.  At this stage the FwdRefs field
        -- isn't finished: it's empty for all except a BindStmt
        -- for which it's the fwd refs within the bind itself
        -- (This set may not be empty, because we're in a recursive
        -- context.)
723
        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do
724
        { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds))
725 726
                                            emptyNameSet segs
        ; (thing, fvs_later) <- thing_inside bndrs
727
        ; let (rec_stmts', fvs) = segmentRecStmts ctxt empty_rec_stmt segs fvs_later
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
728
        ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
729

730
rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
731
  = do  { (mzip_op, fvs1)   <- lookupStmtName ctxt mzipName
732 733
        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
734 735
        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
        ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing)
736 737
                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }

738
rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form