RnExpr.hs 54.6 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
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 BasicTypes       ( FixityDirection(..), Fixity(..), minPrecedence )
32
import PrelNames
mnislaih's avatar
mnislaih committed
33

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)
215 216
  = rnLocalBindsAndThen binds $ \binds' -> do
      { (expr',fvExpr) <- rnLExpr expr
217
      ; return (HsLet binds' expr', fvExpr) }
218

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

370 371 372
-- 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
373

374
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
375
        -- HsWrap
376

377 378
hsHoleExpr :: HsExpr id
hsHoleExpr = HsUnboundVar (mkVarOcc "_")
379

380 381 382 383 384 385
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
386
       ; return (hsHoleExpr, emptyFVs) }
387

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
424 425 426
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
427
        Arrow commands
Austin Seipp's avatar
Austin Seipp committed
428 429 430
*                                                                      *
************************************************************************
-}
431

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

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

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

453 454 455 456 457 458
rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
rnLCmd = wrapLocFstM rnCmd

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

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

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

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

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

494
rnCmd (HsCmdLam matches)
495 496
  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
       ; return (HsCmdLam matches', fvMatch) }
497

498 499 500
rnCmd (HsCmdPar e)
  = do  { (e', fvs_e) <- rnLCmd e
        ; return (HsCmdPar e', fvs_e) }
501

502
rnCmd (HsCmdCase expr matches)
503 504 505
  = 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) }
506

507 508 509 510 511 512
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]) }
513

514
rnCmd (HsCmdLet binds cmd)
515 516
  = rnLocalBindsAndThen binds $ \ binds' -> do
      { (cmd',fvExpr) <- rnLCmd cmd
517
      ; return (HsCmdLet binds' cmd', fvExpr) }
518

519
rnCmd (HsCmdDo stmts _)
520
  = do  { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
521
        ; return ( HsCmdDo stmts' placeHolderType, fvs ) }
522

523
rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
524 525

---------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
526 527
type CmdNeeds = FreeVars        -- Only inhabitants are
                                --      appAName, choiceAName, loopAName
528 529

-- find what methods the Cmd needs (loop, choice, apply)
530 531 532
methodNamesLCmd :: LHsCmd Name -> CmdNeeds
methodNamesLCmd = methodNamesCmd . unLoc

533 534
methodNamesCmd :: HsCmd Name -> CmdNeeds

535
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
536
  = emptyFVs
537
methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
538
  = unitFV appAName
539
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
540
methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
541

542
methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
543

544
methodNamesCmd (HsCmdIf _ _ c1 c2)
545
  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
546

547 548 549 550
methodNamesCmd (HsCmdLet _ c)      = methodNamesLCmd c
methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
methodNamesCmd (HsCmdApp c _)      = methodNamesLCmd c
methodNamesCmd (HsCmdLam match)    = methodNamesMatch match
551

552
methodNamesCmd (HsCmdCase _ matches)
553
  = methodNamesMatch matches `addOneFV` choiceAName
554

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

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

-------------------------------------------------
568
-- gaw 2004
569
methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
Ian Lynagh's avatar
Ian Lynagh committed
570
methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
571 572

-------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
573

574
methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
Ian Lynagh's avatar
Ian Lynagh committed
575
methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
576 577

---------------------------------------------------
578
methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
579
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
580 581

---------------------------------------------------
582
methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
583 584
methodNamesLStmt = methodNamesStmt . unLoc

585
methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
586
methodNamesStmt (LastStmt cmd _)                 = methodNamesLCmd cmd
587
methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
588 589
methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
590 591
methodNamesStmt (LetStmt {})                     = emptyFVs
methodNamesStmt (ParStmt {})                     = emptyFVs
592
methodNamesStmt (TransStmt {})                   = emptyFVs
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
593
   -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
594 595
   -- here so we just do what's convenient

Austin Seipp's avatar
Austin Seipp committed
596 597 598
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
599
        Arithmetic sequences
Austin Seipp's avatar
Austin Seipp committed
600 601 602
*                                                                      *
************************************************************************
-}
603

Ian Lynagh's avatar
Ian Lynagh committed
604
rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
605
rnArithSeq (From expr)
606 607
 = do { (expr', fvExpr) <- rnLExpr expr
      ; return (From expr', fvExpr) }
608 609

rnArithSeq (FromThen expr1 expr2)
610 611 612
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
613 614

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

rnArithSeq (FromThenTo expr1 expr2 expr3)
620 621 622 623 624
 = do { (expr1', fvExpr1) <- rnLExpr expr1
      ; (expr2', fvExpr2) <- rnLExpr expr2
      ; (expr3', fvExpr3) <- rnLExpr expr3
      ; return (FromThenTo expr1' expr2' expr3',
                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
625

Austin Seipp's avatar
Austin Seipp committed
626 627 628
{-
************************************************************************
*                                                                      *
629
\subsubsection{@Stmt@s: in @do@ expressions}
Austin Seipp's avatar
Austin Seipp committed
630 631 632
*                                                                      *
************************************************************************
-}
633

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
634
rnStmts :: Outputable (body RdrName) => HsStmtContext Name
635 636 637
        -> (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
638
        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
639 640 641
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars

642
rnStmts ctxt _ [] thing_inside
643
  = do { checkEmptyStmts ctxt
644 645 646
       ; (thing, fvs) <- thing_inside []
       ; return (([], thing), fvs) }

647
rnStmts MDoExpr rnBody stmts thing_inside    -- Deal with mdo
648
  = -- Behave like do { rec { ...all but last... }; last }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
649 650 651 652 653
    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) }
654 655
  where
    Just (all_but_last, last_stmt) = snocView stmts
656

657
rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
658
  | null lstmts
659
  = setSrcSpan loc $
660
    do { lstmt' <- checkLastStmt ctxt lstmt
661
       ; rnStmt ctxt rnBody lstmt' thing_inside }
662 663

  | otherwise
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
664
  = do { ((stmts1, (stmts2, thing)), fvs)
665
            <- setSrcSpan loc                         $
666
               do { checkStmt ctxt lstmt
667 668
                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
                    rnStmts ctxt rnBody lstmts  $ \ bndrs2 ->
669
                    thing_inside (bndrs1 ++ bndrs2) }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
670
        ; return (((stmts1 ++ stmts2), thing), fvs) }
671

672
----------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
673
rnStmt :: Outputable (body RdrName) => HsStmtContext Name
674 675
       -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
       -> LStmt RdrName (Located (body RdrName))
676
       -> ([Name] -> RnM (thing, FreeVars))
677
       -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
678 679
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
680

681
rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
682 683 684 685 686
  = 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) }
687

688
rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
689 690 691
  = do  { (body', fv_expr) <- rnBody body
        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName
        ; (guard_op, fvs2) <- if isListCompExpr ctxt
692
                              then lookupStmtName ctxt guardMName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
693 694 695 696 697 698 699
                              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) }
700

701
rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
702 703 704 705 706 707 708 709
  = 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) }}
710
       -- fv_expr shouldn't really be filtered by the rnPatsAndThen
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
711
        -- but it does not matter because the names are unique
712

713
rnStmt _ _ (L loc (LetStmt binds)) thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
714 715
  = do  { rnLocalBindsAndThen binds $ \binds' -> do
        { (thing, fvs) <- thing_inside (collectLocalBinders binds')
716
        ; return (([L loc (LetStmt binds')], thing), fvs) }  }
717

718
rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
719 720 721
  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName
        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName
722 723 724
        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op
                                                , recS_mfix_fn = mfix_op
                                                , recS_bind_fn = bind_op }
725

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
726 727 728 729 730 731 732 733 734
        -- 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.)
735
        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do
736
        { let bndrs = nameSetElems $ foldr (unionNameSet . (\(ds,_,_,_) -> ds))
737 738
                                            emptyNameSet segs
        ; (thing, fvs_later) <- thing_inside bndrs
739
        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
740
        ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }