TcHsSyn.lhs 51.5 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1996-1998
4
%
5
6

TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7
8
9
10
11

This module is an extension of @HsSyn@ syntax, for use in the type
checker.

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
12
13
14
15
16
17
18
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

19
module TcHsSyn (
20
21
22
	mkHsConApp, mkHsDictLet, mkHsApp,
	hsLitType, hsLPatType, hsPatType, 
	mkHsAppTy, mkSimpleHsAlt,
23
	nlHsIntLit, 
24
	shortCutLit, hsOverLitName,
25
	
26
	-- re-exported from TcMonad
27
	TcId, TcIdSet, 
28

29
30
31
	zonkTopDecls, zonkTopExpr, zonkTopLExpr, 
	zonkTopBndrs, zonkTyBndrsX,
        emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, 
32
        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
33
34
  ) where

35
#include "HsVersions.h"
36

37
import HsSyn
38
import Id
39
import TcRnMonad
40
import PrelNames
41
import TypeRep     -- We can see the representation of types
42
import TcType
43
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
44
import TcEvidence
45
46
import TysPrim
import TysWiredIn
dreixel's avatar
dreixel committed
47
import Type
48
import DataCon
49
import Name
50
import NameSet
51
import Var
52
import VarSet
53
import VarEnv
54
import DynFlags
55
import Literal
56
57
58
import BasicTypes
import Maybes
import SrcLoc
sof's avatar
sof committed
59
import Bag
60
import FastString
sof's avatar
sof committed
61
import Outputable
62
import Util
63
-- import Data.Traversable( traverse )
64
65
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
66
67
68
69
70
71
72
73
74
75
76
77
\begin{code}
-- XXX
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)

returnM :: Monad m => a -> m a
returnM = return

mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
mappM = mapM
\end{code}

78

79
80
81
82
83
84
%************************************************************************
%*									*
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%*									*
%************************************************************************

85
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
86
87
then something is wrong.
\begin{code}
88
89
90
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

Ian Lynagh's avatar
Ian Lynagh committed
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
hsPatType :: Pat Id -> Type
hsPatType (ParPat pat)                = hsLPatType pat
hsPatType (WildPat ty)                = ty
hsPatType (VarPat var)                = idType var
hsPatType (BangPat pat)               = hsLPatType pat
hsPatType (LazyPat pat)               = hsLPatType pat
hsPatType (LitPat lit)                = hsLitType lit
hsPatType (AsPat var _)               = idType (unLoc var)
hsPatType (ViewPat _ _ ty)            = ty
hsPatType (ListPat _ ty)              = mkListTy ty
hsPatType (PArrPat _ ty)              = mkPArrTy ty
hsPatType (TuplePat _ _ ty)           = ty
hsPatType (ConPatOut { pat_ty = ty }) = ty
hsPatType (SigPatOut _ ty)            = ty
hsPatType (NPat lit _ _)              = overLitType lit
hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
hsPatType (CoPat _ _ ty)              = ty
hsPatType p                           = pprPanic "hsPatType" (ppr p)
109
110

hsLitType :: HsLit -> TcType
Ian Lynagh's avatar
Ian Lynagh committed
111
112
113
114
115
116
117
hsLitType (HsChar _)       = charTy
hsLitType (HsCharPrim _)   = charPrimTy
hsLitType (HsString _)     = stringTy
hsLitType (HsStringPrim _) = addrPrimTy
hsLitType (HsInt _)        = intTy
hsLitType (HsIntPrim _)    = intPrimTy
hsLitType (HsWordPrim _)   = wordPrimTy
118
119
hsLitType (HsInt64Prim _)  = int64PrimTy
hsLitType (HsWord64Prim _) = word64PrimTy
Ian Lynagh's avatar
Ian Lynagh committed
120
121
122
123
hsLitType (HsInteger _ ty) = ty
hsLitType (HsRat _ ty)     = ty
hsLitType (HsFloatPrim _)  = floatPrimTy
hsLitType (HsDoublePrim _) = doublePrimTy
124
125
\end{code}

126
127
128
Overloaded literals. Here mainly becuase it uses isIntTy etc

\begin{code}
129
130
131
132
133
134
shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
shortCutLit dflags (HsIntegral i) ty
  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt i))
  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim i))
  | isIntegerTy ty = Just (HsLit (HsInteger i ty))
  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
135
136
137
138
139
140
	-- The 'otherwise' case is important
	-- Consider (3 :: Float).  Syntactically it looks like an IntLit,
	-- so we'll call shortCutIntLit, but of course it's a float
	-- This can make a big difference for programs with a lot of
	-- literals, compiled without -O

141
shortCutLit _ (HsFractional f) ty
142
143
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
144
145
  | otherwise     = Nothing

146
shortCutLit _ (HsIsString s) ty
147
148
149
150
151
152
153
154
155
156
157
158
159
  | isStringTy ty = Just (HsLit (HsString s))
  | otherwise     = Nothing

mkLit :: DataCon -> HsLit -> HsExpr Id
mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)

------------------------------
hsOverLitName :: OverLitVal -> Name
-- Get the canonical 'fromX' name for a particular OverLitVal
hsOverLitName (HsIntegral {})   = fromIntegerName
hsOverLitName (HsFractional {}) = fromRationalName
hsOverLitName (HsIsString {})   = fromStringName
\end{code}
160

161
162
163
164
165
166
%************************************************************************
%*									*
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
%*									*
%************************************************************************

167
168
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
169
170
171

 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 b) convert unbound TcTyVar to Void
172
 c) convert each TcId to an Id by zonking its type
sof's avatar
sof committed
173

174
175
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
176

177
178
179
The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
sof's avatar
sof committed
180

181
182
It's all pretty boring stuff, because HsSyn is such a large type, and 
the environment manipulation is tiresome.
183

184
\begin{code}
dreixel's avatar
dreixel committed
185
186
187
188
189
190
191
192
type UnboundTyVarZonker = TcTyVar-> TcM Type 
	-- How to zonk an unbound type variable
        -- Note [Zonking the LHS of a RULE]

data ZonkEnv 
  = ZonkEnv 
      UnboundTyVarZonker
      (TyVarEnv TyVar)          -- 
193
      (IdEnv    Var)		-- What variables are in scope
194
195
196
197
	-- Maps an Id or EvVar to its zonked version; both have the same Name
	-- Note that all evidence (coercion variables as well as dictionaries)
	-- 	are kept in the ZonkEnv
	-- Only *type* abstraction is done by side effect
198
199
	-- Is only consulted lazily; hence knot-tying

200
201
202
203
instance Outputable ZonkEnv where 
  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))


Ian Lynagh's avatar
Ian Lynagh committed
204
emptyZonkEnv :: ZonkEnv
205
206
207
208
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping

mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
209

dreixel's avatar
dreixel committed
210
211
212
extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids 
  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
213

dreixel's avatar
dreixel committed
214
215
216
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id 
  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
217

dreixel's avatar
dreixel committed
218
219
220
221
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
  = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env

222
223
224
mkTyVarZonkEnv :: [TyVar] -> ZonkEnv
mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv

dreixel's avatar
dreixel committed
225
226
setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
227

228
zonkEnvIds :: ZonkEnv -> [Id]
dreixel's avatar
dreixel committed
229
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
230
231
232
233
234

zonkIdOcc :: ZonkEnv -> TcId -> Id
-- Ids defined in this module should be in the envt; 
-- ignore others.  (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
235
236
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
237
238
239
240
241
242
243
244
245
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
-- an earlier chunk won't be in the 'env' that the zonking phase 
-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
-- zonked.  There's no point in looking it up there (except for error 
-- checking), and it's not conveniently to hand; hence the simple
-- 'orElse' case in the LocalVar branch.
--
-- Even without template splices, in module Main, the checking of
246
-- 'main' is done as a separate chunk.
dreixel's avatar
dreixel committed
247
zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id 
248
249
250
  | isLocalVar id = lookupVarEnv env id `orElse` id
  | otherwise	  = id

Ian Lynagh's avatar
Ian Lynagh committed
251
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
252
zonkIdOccs env ids = map (zonkIdOcc env) ids
253

254
255
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form.  The TyVarEnv give 
256
257
258
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
  = zonkTcTypeToType env (idType id)	`thenM` \ ty' ->
259
    returnM (Id.setIdType id ty')
260
261
262
263
264
265

zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mappM (zonkIdBndr env) ids

zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
266

267
268
269
270
271
272
273
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
zonkEvBndrsX = mapAccumLM zonkEvBndrX 

zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
zonkEvBndrX env var
  = do { var' <- zonkEvBndr env var
dreixel's avatar
dreixel committed
274
       ; return (extendIdZonkEnv1 env var', var') }
275
276
277
278
279

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
zonkEvBndr env var 
280
281
282
283
  = do { let var_ty = varType var
       ; ty <- 
           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
           zonkTcTypeToType env var_ty
dreixel's avatar
dreixel committed
284
       ; return (setVarType var ty) }
285
286
287

zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
zonkEvVarOcc env v = zonkIdOcc env v
dreixel's avatar
dreixel committed
288
289
290
291
292

zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX = mapAccumLM zonkTyBndrX 

zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
293
294
-- This guarantees to return a TyVar (not a TcTyVar)
-- then we add it to the envt, so all occurrences are replaced
dreixel's avatar
dreixel committed
295
296
zonkTyBndrX env tv
  = do { ki <- zonkTcTypeToType env (tyVarKind tv)
297
298
       ; let tv' = mkTyVar (tyVarName tv) ki
       ; return (extendTyZonkEnv1 env tv', tv') }
299
300
301
302
\end{code}


\begin{code}
303
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
304
305
zonkTopExpr e = zonkExpr emptyZonkEnv e

306
307
308
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

309
310
zonkTopDecls :: Bag EvBind 
             -> LHsBinds TcId -> NameSet
311
312
313
314
315
316
317
318
319
320
             -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
             -> TcM ([Id], 
                     Bag EvBind,
                     Bag (LHsBind  Id),
                     [LForeignDecl Id],
                     [LTcSpecPrag],
                     [LRuleDecl    Id],
                     [LVectDecl    Id])
zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
321

322
323
	 -- Warn about missing signatures
	 -- Do this only when we we have a type to offer
324
        ; warn_missing_sigs <- woptM Opt_WarnMissingSigs
325
326
327
328
        ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
                       | otherwise         = noSigWarn

        ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
329
330
331
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
        ; vects' <- zonkVects env2 vects
332
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
333
334
        ; fords' <- zonkForeignExports env2 fords
        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
335
336

---------------------------------------------
337
338
339
340
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

341
342
343
344
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
345
  = do	{ warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
346
347
348
349
350
351
352
353
354
355
356
357
        ; let sig_warn | not warn_missing_sigs = noSigWarn
                       | otherwise             = localSigWarn sig_ns
              sig_ns = getTypeSigNames vb
	; (env1, new_binds) <- go env sig_warn binds
        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
  where
    go env _ []
      = return (env, [])
    go env sig_warn ((r,b):bs) 
      = do { (env1, b')  <- zonkRecMonoBinds env sig_warn b
	   ; (env2, bs') <- go env1 sig_warn bs
	   ; return (env2, (r,b'):bs') }
358
359

zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
360
  = mappM (wrapLocM zonk_ip_bind) binds	`thenM` \ new_binds ->
361
    let
362
	env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
363
    in
364
    zonkTcEvBinds env1 dict_binds 	`thenM` \ (env2, new_dict_binds) -> 
365
    returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
366
  where
367
    zonk_ip_bind (IPBind n e)
368
	= mapIPNameTc (zonkIdBndr env) n	`thenM` \ n' ->
369
370
	  zonkLExpr env e			`thenM` \ e' ->
	  returnM (IPBind n' e')
371

372
---------------------------------------------
373
374
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env sig_warn binds 
375
 = fixM (\ ~(_, new_binds) -> do 
dreixel's avatar
dreixel committed
376
	{ let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
377
        ; binds' <- zonkMonoBinds env1 sig_warn binds
378
379
        ; return (env1, binds') })

380
---------------------------------------------
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
type SigWarn = Bool -> [Id] -> TcM ()	
     -- Missing-signature warning
     -- The Bool is True for an AbsBinds, False otherwise

noSigWarn :: SigWarn
noSigWarn _ _ = return ()

topSigWarn :: NameSet -> SigWarn
topSigWarn sig_ns _ ids = mapM_ (topSigWarnId sig_ns) ids

topSigWarnId :: NameSet -> Id -> TcM ()
-- The NameSet is the Ids that *lack* a signature
-- We have to do it this way round because there are
-- lots of top-level bindings that are generated by GHC
-- and that don't have signatures
topSigWarnId sig_ns id
  | idName id `elemNameSet` sig_ns = warnMissingSig msg id
  | otherwise                      = return ()
  where
    msg = ptext (sLit "Top-level binding with no type signature:")

localSigWarn :: NameSet -> SigWarn
localSigWarn sig_ns is_abs_bind ids
  | not is_abs_bind = return ()
  | otherwise       = mapM_ (localSigWarnId sig_ns) ids

localSigWarnId :: NameSet -> Id -> TcM ()
-- NameSet are the Ids that *have* type signatures
localSigWarnId sig_ns id
  | not (isSigmaTy (idType id))    = return ()
  | idName id `elemNameSet` sig_ns = return ()
  | otherwise                      = warnMissingSig msg id
  where
    msg = ptext (sLit "Polymophic local binding with no type signature:")

warnMissingSig :: SDoc -> Id -> TcM ()
warnMissingSig msg id
  = do  { env0 <- tcInitTidyEnv
        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
        ; addWarnTcM (env1, mk_msg tidy_ty) }
  where
422
    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
423
424
425
426

---------------------------------------------
zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) binds
427

428
429
zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
430
  = do	{ (_env, new_pat) <- zonkPat env pat		-- Env already extended
431
        ; sig_warn False (collectPatBinders new_pat)
432
433
	; new_grhss <- zonkGRHSs env grhss
	; new_ty    <- zonkTcTypeToType env ty
434
	; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
435

436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
  = do { new_var  <- zonkIdBndr env var
       ; sig_warn False [new_var]
       ; new_expr <- zonkLExpr env expr
       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }

zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
                                     , fun_co_fn = co_fn })
  = do { new_var <- zonkIdBndr env var
       ; sig_warn False [new_var]
       ; (env1, new_co_fn) <- zonkCoFn env co_fn
       ; new_ms <- zonkMatchGroup env1 ms
       ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
                      , fun_co_fn = new_co_fn }) }

zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                                 , abs_ev_binds = ev_binds
			         , abs_exports = exports
                                 , abs_binds = val_binds })
455
  = ASSERT( all isImmutableTyVar tyvars )
dreixel's avatar
dreixel committed
456
457
    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
458
459
       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
dreixel's avatar
dreixel committed
460
         do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
461
    	    ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
462
463
    	    ; new_exports   <- mapM (zonkExport env3) exports
    	    ; return (new_val_binds, new_exports) } 
464
       ; sig_warn True (map abe_poly new_exports)
dreixel's avatar
dreixel committed
465
466
       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
                          , abs_ev_binds = new_ev_binds
467
			  , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
468
  where
469
470
471
472
473
474
475
    zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
                       , abe_mono = mono_id, abe_prags = prags })
	= zonkIdBndr env poly_id		`thenM` \ new_poly_id ->
	  zonkCoFn env wrap                     `thenM` \ (_, new_wrap) ->
          zonkSpecPrags env prags		`thenM` \ new_prags -> 
	  returnM (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
                      , abe_mono = zonkIdOcc env mono_id, abe_prags = new_prags })
476

477
478
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
479
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
480
                                       ; return (SpecPrags ps') }
481
482
483
484

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
485
  where
486
    zonk_prag (L loc (SpecPrag id co_fn inl))
487
	= do { (_, co_fn') <- zonkCoFn env co_fn
488
	     ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
489
490
491
492
\end{code}

%************************************************************************
%*									*
493
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
494
495
496
497
%*									*
%************************************************************************

\begin{code}
498
499
500
501
502
zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
zonkMatchGroup env (MatchGroup ms ty) 
  = do	{ ms' <- mapM (zonkMatch env) ms
	; ty' <- zonkTcTypeToType env ty
	; return (MatchGroup ms' ty') }
503

504
zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
505
zonkMatch env (L loc (Match pats _ grhss))
506
507
508
  = do	{ (env1, new_pats) <- zonkPats env pats
	; new_grhss <- zonkGRHSs env1 grhss
	; return (L loc (Match new_pats Nothing new_grhss)) }
509

510
-------------------------------------------------------------------------
511
zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
512

513
zonkGRHSs env (GRHSs grhss binds)
514
  = zonkLocalBinds env binds   	`thenM` \ (new_env, new_binds) ->
515
    let
516
517
518
519
	zonk_grhs (GRHS guarded rhs)
	  = zonkStmts new_env guarded	`thenM` \ (env2, new_guarded) ->
	    zonkLExpr env2 rhs		`thenM` \ new_rhs ->
	    returnM (GRHS new_guarded new_rhs)
520
    in
521
    mappM (wrapLocM zonk_grhs) grhss 	`thenM` \ new_grhss ->
522
    returnM (GRHSs new_grhss new_binds)
523
524
525
526
527
528
529
530
531
\end{code}

%************************************************************************
%*									*
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
%*									*
%************************************************************************

\begin{code}
532
533
534
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
535

536
537
zonkLExprs env exprs = mappM (zonkLExpr env) exprs
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
538

539
540
zonkExpr env (HsVar id)
  = returnM (HsVar (zonkIdOcc env id))
541

542
543
zonkExpr _ (HsIPVar id)
  = returnM (HsIPVar id)
544

545
zonkExpr env (HsLit (HsRat f ty))
546
  = zonkTcTypeToType env ty	   `thenM` \ new_ty  ->
547
    returnM (HsLit (HsRat f new_ty))
sof's avatar
sof committed
548

Ian Lynagh's avatar
Ian Lynagh committed
549
zonkExpr _ (HsLit lit)
550
  = returnM (HsLit lit)
551
552
553
554

zonkExpr env (HsOverLit lit)
  = do	{ lit' <- zonkOverLit env lit
	; return (HsOverLit lit') }
555

556
557
558
zonkExpr env (HsLam matches)
  = zonkMatchGroup env matches	`thenM` \ new_matches ->
    returnM (HsLam new_matches)
559

560
561
562
563
564
zonkExpr env (HsLamCase arg matches)
  = zonkTcTypeToType env arg	`thenM` \ new_arg ->
    zonkMatchGroup env matches	`thenM` \ new_matches ->
    returnM (HsLamCase new_arg new_matches)

565
zonkExpr env (HsApp e1 e2)
566
567
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
568
569
570
571
572
573
    returnM (HsApp new_e1 new_e2)

zonkExpr env (HsBracketOut body bs) 
  = mappM zonk_b bs	`thenM` \ bs' ->
    returnM (HsBracketOut body bs')
  where
574
    zonk_b (n,e) = zonkLExpr env e	`thenM` \ e' ->
575
576
		   returnM (n,e')

Ian Lynagh's avatar
Ian Lynagh committed
577
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
578
			     returnM (HsSpliceE s)
579
580

zonkExpr env (OpApp e1 op fixity e2)
581
582
583
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env op	`thenM` \ new_op ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
584
585
    returnM (OpApp new_e1 new_op fixity new_e2)

586
587
588
589
zonkExpr env (NegApp expr op)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    zonkExpr env op	`thenM` \ new_op ->
    returnM (NegApp new_expr new_op)
590
591

zonkExpr env (HsPar e)    
592
  = zonkLExpr env e	`thenM` \new_e ->
593
594
595
    returnM (HsPar new_e)

zonkExpr env (SectionL expr op)
596
597
  = zonkLExpr env expr	`thenM` \ new_expr ->
    zonkLExpr env op		`thenM` \ new_op ->
598
599
600
    returnM (SectionL new_expr new_op)

zonkExpr env (SectionR op expr)
601
602
  = zonkLExpr env op		`thenM` \ new_op ->
    zonkLExpr env expr		`thenM` \ new_expr ->
603
604
    returnM (SectionR new_op new_expr)

605
606
607
608
609
610
611
zonkExpr env (ExplicitTuple tup_args boxed)
  = do { new_tup_args <- mapM zonk_tup_arg tup_args
       ; return (ExplicitTuple new_tup_args boxed) }
  where
    zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
    zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }

612
613
zonkExpr env (HsCase expr ms)
  = zonkLExpr env expr    	`thenM` \ new_expr ->
614
    zonkMatchGroup env ms	`thenM` \ new_ms ->
615
    returnM (HsCase new_expr new_ms)
616

617
618
619
620
621
622
zonkExpr env (HsIf e0 e1 e2 e3)
  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
       ; new_e1 <- zonkLExpr env e1
       ; new_e2 <- zonkLExpr env e2
       ; new_e3 <- zonkLExpr env e3
       ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
623

624
625
626
627
628
629
630
631
632
zonkExpr env (HsMultiIf ty alts)
  = do { alts' <- mapM (wrapLocM zonk_alt) alts
       ; ty'   <- zonkTcTypeToType env ty
       ; returnM $ HsMultiIf ty' alts' }
  where zonk_alt (GRHS guard expr)
          = do { (env', guard') <- zonkStmts env guard
               ; expr'          <- zonkLExpr env' expr
               ; returnM $ GRHS guard' expr' }

633
zonkExpr env (HsLet binds expr)
634
  = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
635
    zonkLExpr new_env expr	`thenM` \ new_expr ->
636
637
    returnM (HsLet new_binds new_expr)

638
639
zonkExpr env (HsDo do_or_lc stmts ty)
  = zonkStmts env stmts 	`thenM` \ (_, new_stmts) ->
640
    zonkTcTypeToType env ty	`thenM` \ new_ty   ->
641
    returnM (HsDo do_or_lc new_stmts new_ty)
642
643

zonkExpr env (ExplicitList ty exprs)
644
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
645
    zonkLExprs env exprs	`thenM` \ new_exprs ->
646
647
648
    returnM (ExplicitList new_ty new_exprs)

zonkExpr env (ExplicitPArr ty exprs)
649
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
650
    zonkLExprs env exprs	`thenM` \ new_exprs ->
651
652
    returnM (ExplicitPArr new_ty new_exprs)

653
zonkExpr env (RecordCon data_con con_expr rbinds)
654
655
656
  = do	{ new_con_expr <- zonkExpr env con_expr
	; new_rbinds   <- zonkRecFields env rbinds
	; return (RecordCon data_con new_con_expr new_rbinds) }
657

658
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
659
660
661
662
663
  = do	{ new_expr    <- zonkLExpr env expr
	; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
	; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
	; new_rbinds  <- zonkRecFields env rbinds
	; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
664

665
666
667
668
zonkExpr env (ExprWithTySigOut e ty) 
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

Ian Lynagh's avatar
Ian Lynagh committed
669
zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
670

671
672
zonkExpr env (ArithSeq expr info)
  = zonkExpr env expr		`thenM` \ new_expr ->
673
    zonkArithSeq env info	`thenM` \ new_info ->
674
    returnM (ArithSeq new_expr new_info)
675

676
677
zonkExpr env (PArrSeq expr info)
  = zonkExpr env expr		`thenM` \ new_expr ->
678
    zonkArithSeq env info	`thenM` \ new_info ->
679
    returnM (PArrSeq new_expr new_info)
680
681

zonkExpr env (HsSCC lbl expr)
682
  = zonkLExpr env expr	`thenM` \ new_expr ->
683
684
    returnM (HsSCC lbl new_expr)

andy@galois.com's avatar
andy@galois.com committed
685
686
687
688
zonkExpr env (HsTickPragma info expr)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    returnM (HsTickPragma info new_expr)

689
690
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
691
  = zonkLExpr env expr   `thenM` \ new_expr ->
692
693
    returnM (HsCoreAnn lbl new_expr)

694
-- arrow notation extensions
695
zonkExpr env (HsProc pat body)
696
697
698
  = do	{ (env1, new_pat) <- zonkPat env pat
	; new_body <- zonkCmdTop env1 body
	; return (HsProc new_pat new_body) }
699

700
701
702
zonkExpr env (HsArrApp e1 e2 ty ho rl)
  = zonkLExpr env e1	    	    	`thenM` \ new_e1 ->
    zonkLExpr env e2	    	    	`thenM` \ new_e2 ->
703
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
704
    returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
705

706
707
zonkExpr env (HsArrForm op fixity args)
  = zonkLExpr env op	    	    	`thenM` \ new_op ->
708
    mappM (zonkCmdTop env) args		`thenM` \ new_args ->
709
    returnM (HsArrForm new_op fixity new_args)
710

711
zonkExpr env (HsWrap co_fn expr)
712
713
  = zonkCoFn env co_fn	`thenM` \ (env1, new_co_fn) ->
    zonkExpr env1 expr	`thenM` \ new_expr ->
714
    return (HsWrap new_co_fn new_expr)
715

716
717
718
zonkExpr _ HsHole
  = return HsHole

Ian Lynagh's avatar
Ian Lynagh committed
719
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
720

721
722
723
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
724
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
725
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
726
727
  = zonkLExpr env cmd	    		`thenM` \ new_cmd ->
    zonkTcTypeToTypes env stack_tys	`thenM` \ new_stack_tys ->
728
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
729
    mapSndM (zonkExpr env) ids		`thenM` \ new_ids ->
730
731
    returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)

732
-------------------------------------------------------------------------
733
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
734
zonkCoFn env WpHole   = return (env, WpHole)
735
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
736
				    ; (env2, c2') <- zonkCoFn env1 c2
737
				    ; return (env2, WpCompose c1' c2') }
batterseapower's avatar
batterseapower committed
738
739
zonkCoFn env (WpCast co) = do { co' <- zonkTcLCoToLCo env co
			      ; return (env, WpCast co') }
740
741
742
743
zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
				 ; return (env', WpEvLam ev') }
zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg 
                                 ; return (env, WpEvApp arg') }
744
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
dreixel's avatar
dreixel committed
745
746
                              do { (env', tv') <- zonkTyBndrX env tv
				 ; return (env', WpTyLam tv') }
747
748
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
				 ; return (env, WpTyApp ty') }
749
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
750
				 ; return (env1, WpLet bs') }
751

752
753
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
754
755
756
757
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
  = do	{ ty' <- zonkTcTypeToType env ty
	; e' <- zonkExpr env e
 	; return (lit { ol_witness = e', ol_type = ty' }) }
758

759
-------------------------------------------------------------------------
760
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
761

762
zonkArithSeq env (From e)
763
  = zonkLExpr env e		`thenM` \ new_e ->
764
    returnM (From new_e)
765

766
zonkArithSeq env (FromThen e1 e2)
767
768
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
769
    returnM (FromThen new_e1 new_e2)
770

771
zonkArithSeq env (FromTo e1 e2)
772
773
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
774
    returnM (FromTo new_e1 new_e2)
775

776
zonkArithSeq env (FromThenTo e1 e2 e3)
777
778
779
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
    zonkLExpr env e3	`thenM` \ new_e3 ->
780
    returnM (FromThenTo new_e1 new_e2 new_e3)
781

782

783
-------------------------------------------------------------------------
784
785
786
787
788
zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
zonkStmts env []     = return (env, [])
zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
			  ; (env2, ss') <- zonkStmts env1 ss
			  ; return (env2, s' : ss') }
789

790
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
791
792
793
794
795
796
797
zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op)
  = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
	     env1 = extendIdZonkEnv env new_binders
       ; new_mzip <- zonkExpr env1 mzip_op
       ; new_bind <- zonkExpr env1 bind_op
       ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }
798
  where
799
800
801
802
    zonk_branch (ParStmtBlock stmts bndrs return_op) 
       = do { (env1, new_stmts) <- zonkStmts env stmts
            ; new_return <- zonkExpr env1 return_op
	    ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
803

804
805
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
                      , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
806
807
                      , recS_later_rets = later_rets, recS_rec_rets = rec_rets
                      , recS_ret_ty = ret_ty })
808
809
  = do { new_rvs <- zonkIdBndrs env rvs
       ; new_lvs <- zonkIdBndrs env lvs
810
       ; new_ret_ty  <- zonkTcTypeToType env ret_ty
811
812
813
       ; new_ret_id  <- zonkExpr env ret_id
       ; new_mfix_id <- zonkExpr env mfix_id
       ; new_bind_id <- zonkExpr env bind_id
dreixel's avatar
dreixel committed
814
       ; let env1 = extendIdZonkEnv env new_rvs
815
       ; (env2, new_segStmts) <- zonkStmts env1 segStmts
816
817
	-- Zonk the ret-expressions in an envt that 
	-- has the polymorphic bindings in the envt
818
819
       ; new_later_rets <- mapM (zonkExpr env2) later_rets
       ; new_rec_rets <- mapM (zonkExpr env2) rec_rets
dreixel's avatar
dreixel committed
820
       ; return (extendIdZonkEnv env new_lvs,     -- Only the lvs are needed
821
822
823
                 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                         , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                         , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
824
825
                         , recS_later_rets = new_later_rets
                         , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
826

827
zonkStmt env (ExprStmt expr then_op guard_op ty)
828
  = zonkLExpr env expr		`thenM` \ new_expr ->
829
    zonkExpr env then_op	`thenM` \ new_then ->
830
    zonkExpr env guard_op	`thenM` \ new_guard ->
831
    zonkTcTypeToType env ty	`thenM` \ new_ty ->
832
    returnM (env, ExprStmt new_expr new_then new_guard new_ty)
833

834
835
836
837
838
zonkStmt env (LastStmt expr ret_op)
  = zonkLExpr env expr		`thenM` \ new_expr ->
    zonkExpr env ret_op		`thenM` \ new_ret ->
    returnM (env, LastStmt new_expr new_ret)

839
840
841
zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
                        , trS_by = by, trS_form = form, trS_using = using
                        , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
842
843
  = do { (env', stmts') <- zonkStmts env stmts 
    ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
844
845
    ; by'        <- fmapMaybeM (zonkLExpr env') by
    ; using'     <- zonkLExpr env using
846
    ; return_op' <- zonkExpr env' return_op
847
848
    ; bind_op'   <- zonkExpr env' bind_op
    ; liftM_op'  <- zonkExpr env' liftM_op
dreixel's avatar
dreixel committed
849
    ; let env'' = extendIdZonkEnv env' (map snd binderMap')
850
851
852
    ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
                               , trS_by = by', trS_form = form, trS_using = using'
                               , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
853
854
855
856
857
858
  where
    zonkBinderMapEntry env (oldBinder, newBinder) = do 
        let oldBinder' = zonkIdOcc env oldBinder
        newBinder' <- zonkIdBndr env newBinder
        return (oldBinder', newBinder') 

859
zonkStmt env (LetStmt binds)
860
  = zonkLocalBinds env binds	`thenM` \ (env1, new_binds) ->
861
    returnM (env1, LetStmt new_binds)
862

863
zonkStmt env (BindStmt pat expr bind_op fail_op)
864
865
  = do	{ new_expr <- zonkLExpr env expr
	; (env1, new_pat) <- zonkPat env pat
866
867
868
	; new_bind <- zonkExpr env bind_op
	; new_fail <- zonkExpr env fail_op
	; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
869

870
-------------------------------------------------------------------------
871
872
873
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
  = do	{ flds' <- mappM zonk_rbind flds
874
	; return (HsRecFields flds' dd) }
875
  where
876
    zonk_rbind fld
877
878
879
      = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
	   ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
	   ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
880
881

-------------------------------------------------------------------------
882
883
884
mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
mapIPNameTc _ (Left x)  = returnM (Left x)
mapIPNameTc f (Right x) = f x  `thenM` \ r -> returnM (Right r)
885
886
\end{code}

887

888
889
890
891
892
893
894
%************************************************************************
%*									*
\subsection[BackSubst-Pats]{Patterns}
%*									*
%************************************************************************

\begin{code}
895
896
897
898
899
zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
-- Extend the environment as we go, because it's possible for one
-- pattern to bind something that is used in another (inside or
-- to the right)
zonkPat env pat = wrapLocSndM (zonk_pat env) pat
900

Ian Lynagh's avatar
Ian Lynagh committed
901
zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
902
zonk_pat env (ParPat p)
903
904
  = do	{ (env', p') <- zonkPat env p
  	; return (env', ParPat p') }
905

906
zonk_pat env (WildPat ty)
907
908
  = do	{ ty' <- zonkTcTypeToType env ty
	; return (env, WildPat ty') }
909

910
zonk_pat env (VarPat v)
911
  = do	{ v' <- zonkIdBndr env v
dreixel's avatar
dreixel committed
912
	; return (extendIdZonkEnv1 env v', VarPat v') }
913

914
zonk_pat env (LazyPat pat)
915
916
  = do	{ (env', pat') <- zonkPat env pat
	; return (env',  LazyPat pat') }
917

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
918
919
920
921
zonk_pat env (BangPat pat)
  = do	{ (env', pat') <- zonkPat env pat
	; return (env',  BangPat pat') }

922
923
zonk_pat env (AsPat (L loc v) pat)
  = do	{ v' <- zonkIdBndr env v
dreixel's avatar
dreixel committed
924
	; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
925
 	; return (env', AsPat (L loc v') pat') }
926

927
928
929
zonk_pat env (ViewPat expr pat ty)
  = do	{ expr' <- zonkLExpr env expr
	; (env', pat') <- zonkPat env pat
930
931
 	; ty' <- zonkTcTypeToType env ty
	; return (env', ViewPat expr' pat' ty') }
932

933
zonk_pat env (ListPat pats ty)
934
935
936
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', ListPat pats' ty') }
937

938
zonk_pat env (PArrPat pats ty)
939
940
941
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', PArrPat pats' ty') }
942

943
944
945
946
zonk_pat env (TuplePat pats boxed ty)
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', TuplePat pats' boxed ty') }
947

948
949
950
951
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
                          , pat_dicts = evs, pat_binds = binds
                          , pat_args = args })
  = ASSERT( all isImmutableTyVar tyvars ) 
952
    do	{ new_ty <- zonkTcTypeToType env ty
953
954
955
956
957
        ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
          -- Must zonk the existential variables, because their
          -- /kind/ need potential zonking.
          -- cf typecheck/should_compile/tc221.hs
	; (env1, new_evs) <- zonkEvBndrsX env0 evs
958
	; (env2, new_binds) <- zonkTcEvBinds env1 binds
959
	; (env', new_args) <- zonkConStuff env2 args
960
961
962
963
964
	; returnM (env', p { pat_ty = new_ty, 
                             pat_tvs = new_tyvars,
                             pat_dicts = new_evs, 
			     pat_binds = new_binds, 
                             pat_args = new_args }) }
965

966
zonk_pat env (LitPat lit) = return (env, LitPat lit)
967

968
969
970
971
zonk_pat env (SigPatOut pat ty)
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pat') <- zonkPat env pat
	; return (env', SigPatOut pat' ty') }
972

973
zonk_pat env (NPat lit mb_neg eq_expr)
974
  = do	{ lit' <- zonkOverLit env lit
975
 	; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
976
 	; eq_expr' <- zonkExpr env eq_expr
977
	; return (env, NPat lit' mb_neg' eq_expr') }
978

979
zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
980
  = do	{ n' <- zonkIdBndr env n
981
982
	; lit' <- zonkOverLit env lit
 	; e1' <- zonkExpr env e1
983
	; e2' <- zonkExpr env e2
dreixel's avatar
dreixel committed
984
	; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
985

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
986
987
988
989
990
991
zonk_pat env (CoPat co_fn pat ty) 
  = do { (env', co_fn') <- zonkCoFn env co_fn
       ; (env'', pat') <- zonkPat env' (noLoc pat)
       ; ty' <- zonkTcTypeToType env'' ty
       ; return (env'', CoPat co_fn' (unLoc pat') ty') }

Ian Lynagh's avatar
Ian Lynagh committed
992
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
993

994
---------------------------
Ian Lynagh's avatar
Ian Lynagh committed
995
996
997
998
zonkConStuff :: ZonkEnv
             -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
             -> TcM (ZonkEnv,
                     HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
999
zonkConStuff env (PrefixCon pats)
1000
1001
  = do	{ (env', pats') <- zonkPats env pats
	; return (env', PrefixCon pats') }
1002

1003
zonkConStuff env (InfixCon p1 p2)
1004
1005
1006
  = do	{ (env1, p1') <- zonkPat env  p1
	; (env', p2') <- zonkPat env1 p2
	; return (env', InfixCon p1' p2') }
1007

1008
1009
1010
1011
1012
zonkConStuff env (RecCon (HsRecFields rpats dd))
  = do	{ (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
	; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
	; returnM (env', RecCon (HsRecFields rpats' dd)) }
	-- Field selectors have declared types; hence no zonking
1013
1014

---------------------------
Ian Lynagh's avatar
Ian Lynagh committed
1015
zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
1016
1017
zonkPats env []		= return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
1018
1019
		     ; (env', pats') <- zonkPats env1 pats
		     ; return (env', pat':pats') }
1020
1021
\end{code}

sof's avatar
sof committed
1022
1023
1024
1025
1026
1027
%************************************************************************
%*									*
\subsection[BackSubst-Foreign]{Foreign exports}
%*									*
%************************************************************************

1028

sof's avatar
sof committed
1029
\begin{code}
1030
1031
zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
sof's avatar
sof committed
1032

1033
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
1034
1035
zonkForeignExport env (ForeignExport i _hs_ty co spec) =
   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
Ian Lynagh's avatar
Ian Lynagh committed
1036
zonkForeignExport _ for_imp 
1037
  = returnM for_imp	-- Foreign imports don't need zonking
sof's avatar
sof committed
1038
\end{code}
1039
1040

\begin{code}
1041
1042
zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
1043

1044
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
1045
zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
dreixel's avatar
dreixel committed
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
  = do { unbound_tkv_set <- newMutVar emptyVarSet
       ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set)
              -- See Note [Zonking the LHS of a RULE]

       ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars

       ; new_lhs <- zonkLExpr env_inside lhs
       ; new_rhs <- zonkLExpr env_inside rhs

       ; unbound_tkvs <- readMutVar unbound_tkv_set

1057
       ; let final_bndrs :: [RuleBndr Var]
dreixel's avatar
dreixel committed
1058
             final_bndrs = map (RuleBndr . noLoc)
1059
                               (varSetElemsKvsFirst unbound_tkvs)
dreixel's avatar
dreixel committed
1060
                           ++ new_bndrs
1061

1062
<