TcHsSyn.lhs 40 KB
Newer Older
1
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
12

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

\begin{code}
module TcHsSyn (
13
14
15
	mkHsConApp, mkHsDictLet, mkHsApp,
	hsLitType, hsLPatType, hsPatType, 
	mkHsAppTy, mkSimpleHsAlt,
16
	nlHsIntLit, 
17
	shortCutLit, hsOverLitName,
18
	
19
	-- re-exported from TcMonad
20
	TcId, TcIdSet, 
21

22
	zonkTopDecls, zonkTopExpr, zonkTopLExpr,
23
	zonkId, zonkTopBndrs
24
25
  ) where

26
#include "HsVersions.h"
27
28
29
30
31

-- friends:
import HsSyn	-- oodles of it

-- others:
32
import Id
33

34
import TcRnMonad
35
import PrelNames
36
37
38
39
import TcType
import TcMType
import TysPrim
import TysWiredIn
40
import DataCon
41
import Name
42
import NameSet
43
import Var
44
import VarSet
45
import VarEnv
46
import Literal
47
48
49
import BasicTypes
import Maybes
import SrcLoc
50
import DynFlags( DynFlag(..) )
sof's avatar
sof committed
51
import Bag
52
import FastString
sof's avatar
sof committed
53
import Outputable
54
55
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
56
57
58
59
60
61
62
63
64
65
66
67
\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}

68

69
70
71
72
73
74
%************************************************************************
%*									*
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%*									*
%************************************************************************

75
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
76
77
then something is wrong.
\begin{code}
78
79
80
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat

Ian Lynagh's avatar
Ian Lynagh committed
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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)
99
100

hsLitType :: HsLit -> TcType
Ian Lynagh's avatar
Ian Lynagh committed
101
102
103
104
105
106
107
108
109
110
111
hsLitType (HsChar _)       = charTy
hsLitType (HsCharPrim _)   = charPrimTy
hsLitType (HsString _)     = stringTy
hsLitType (HsStringPrim _) = addrPrimTy
hsLitType (HsInt _)        = intTy
hsLitType (HsIntPrim _)    = intPrimTy
hsLitType (HsWordPrim _)   = wordPrimTy
hsLitType (HsInteger _ ty) = ty
hsLitType (HsRat _ ty)     = ty
hsLitType (HsFloatPrim _)  = floatPrimTy
hsLitType (HsDoublePrim _) = doublePrimTy
112
113
\end{code}

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
Overloaded literals. Here mainly becuase it uses isIntTy etc

\begin{code}
shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
shortCutLit (HsIntegral i) ty
  | isIntTy ty && inIntRange i   = Just (HsLit (HsInt i))
  | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
  | isIntegerTy ty 	       	 = Just (HsLit (HsInteger i ty))
  | otherwise		       	 = shortCutLit (HsFractional (fromInteger i)) ty
	-- 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

shortCutLit (HsFractional f) ty
  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
  | otherwise     = Nothing

shortCutLit (HsIsString s) ty
  | 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}
148

149
150
151
152
153
154
%************************************************************************
%*									*
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
%*									*
%************************************************************************

155
156
157
158
159
\begin{code}
-- zonkId is used *during* typechecking just to zonk the Id's type
zonkId :: TcId -> TcM TcId
zonkId id
  = zonkTcType (idType id) `thenM` \ ty' ->
160
    returnM (Id.setIdType id ty')
161
162
163
164
\end{code}

The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
165
166
167

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

170
171
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
172

173
174
175
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
176

177
178
It's all pretty boring stuff, because HsSyn is such a large type, and 
the environment manipulation is tiresome.
179

180
\begin{code}
181
data ZonkEnv = ZonkEnv	(TcType -> TcM Type) 	-- How to zonk a type
182
183
184
185
186
			(VarEnv Var)		-- What variables are in scope
	-- 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
187
188
	-- Is only consulted lazily; hence knot-tying

Ian Lynagh's avatar
Ian Lynagh committed
189
emptyZonkEnv :: ZonkEnv
190
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
191

192
extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
193
194
195
extendZonkEnv (ZonkEnv zonk_ty env) ids 
  = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])

196
extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
197
198
199
extendZonkEnv1 (ZonkEnv zonk_ty env) id 
  = ZonkEnv zonk_ty (extendVarEnv env id id)

200
201
setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
202

203
204
zonkEnvIds :: ZonkEnv -> [Id]
zonkEnvIds (ZonkEnv _ env) = varEnvElts env
205
206
207
208
209

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.)
210
211
-- (Also foreign-imported things aren't currently in the ZonkEnv;
--  that's ok because they don't need zonking.)
212
213
214
215
216
217
218
219
220
--
-- 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
221
-- 'main' is done as a separate chunk.
Ian Lynagh's avatar
Ian Lynagh committed
222
zonkIdOcc (ZonkEnv _zonk_ty env) id 
223
224
225
  | isLocalVar id = lookupVarEnv env id `orElse` id
  | otherwise	  = id

Ian Lynagh's avatar
Ian Lynagh committed
226
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
227
zonkIdOccs env ids = map (zonkIdOcc env) ids
228

229
230
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form.  The TyVarEnv give 
231
232
233
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
  = zonkTcTypeToType env (idType id)	`thenM` \ ty' ->
234
    returnM (Id.setIdType id ty')
235
236
237
238
239
240

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

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

242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
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
       ; return (extendZonkEnv1 env var', var') }

zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
zonkEvBndr env var 
  = do { ty' <- zonkTcTypeToType env (varType var)
       ; return (setVarType var ty') }

zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
zonkEvVarOcc env v = zonkIdOcc env v
260
261
262
263
\end{code}


\begin{code}
264
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
265
266
zonkTopExpr e = zonkExpr emptyZonkEnv e

267
268
269
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e

270
271
zonkTopDecls :: Bag EvBind 
             -> LHsBinds TcId -> NameSet
272
             -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
273
	     -> TcM ([Id], 
274
	             Bag EvBind,
275
276
		     Bag (LHsBind  Id),
		     [LForeignDecl Id],
277
		     [LTcSpecPrag],
278
		     [LRuleDecl    Id])
279
zonkTopDecls ev_binds binds sig_ns rules imp_specs fords
280
281
  = do	{ (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds

282
283
284
285
286
287
288
	 -- Warn about missing signatures
	 -- Do this only when we we have a type to offer
        ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
        ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
                       | otherwise         = noSigWarn

        ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
289
			-- Top level is implicitly recursive
290
	; rules' <- zonkRules env2 rules
291
        ; specs' <- zonkLTcSpecPrags env2 imp_specs
292
	; fords' <- zonkForeignExports env2 fords
293
	; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
294
295

---------------------------------------------
296
297
298
299
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
  = return (env, EmptyLocalBinds)

300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
  = panic "zonkLocalBinds" -- Not in typechecker output

zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
  = do	{ warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs
        ; 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') }
317
318

zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
319
  = mappM (wrapLocM zonk_ip_bind) binds	`thenM` \ new_binds ->
320
    let
321
	env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
322
    in
323
    zonkTcEvBinds env1 dict_binds 	`thenM` \ (env2, new_dict_binds) -> 
324
    returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
325
  where
326
    zonk_ip_bind (IPBind n e)
327
	= mapIPNameTc (zonkIdBndr env) n	`thenM` \ n' ->
328
329
	  zonkLExpr env e			`thenM` \ e' ->
	  returnM (IPBind n' e')
330

331
---------------------------------------------
332
333
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env sig_warn binds 
334
 = fixM (\ ~(_, new_binds) -> do 
335
	{ let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
336
        ; binds' <- zonkMonoBinds env1 sig_warn binds
337
338
        ; return (env1, binds') })

339
---------------------------------------------
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
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
    mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ]

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

387
388
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})
389
  = do	{ (_env, new_pat) <- zonkPat env pat		-- Env already extended
390
        ; sig_warn False (collectPatBinders new_pat)
391
392
	; new_grhss <- zonkGRHSs env grhss
	; new_ty    <- zonkTcTypeToType env ty
393
	; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
394

395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
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 })
414
  = ASSERT( all isImmutableTyVar tyvars )
415
416
417
418
    do { (env1, new_evs) <- zonkEvBndrsX env evs
       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
    	 do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
419
    	    ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
420
421
    	    ; new_exports   <- mapM (zonkExport env3) exports
    	    ; return (new_val_binds, new_exports) } 
422
       ; sig_warn True [b | (_,b,_,_) <- new_exports]
423
424
       ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
			  , abs_exports = new_exports, abs_binds = new_val_bind }) }
sof's avatar
sof committed
425
  where
426
    zonkExport env (tyvars, global, local, prags)
427
	-- The tyvars are already zonked
428
	= zonkIdBndr env global			`thenM` \ new_global ->
429
	  zonkSpecPrags env prags		`thenM` \ new_prags -> 
430
	  returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
431

432
433
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
434
zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
435
                                       ; return (SpecPrags ps') }
436
437
438
439

zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
  = mapM zonk_prag ps
440
  where
441
    zonk_prag (L loc (SpecPrag id co_fn inl))
442
	= do { (_, co_fn') <- zonkCoFn env co_fn
443
	     ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
444
445
446
447
\end{code}

%************************************************************************
%*									*
448
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
449
450
451
452
%*									*
%************************************************************************

\begin{code}
453
454
455
456
457
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') }
458

459
zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
460
zonkMatch env (L loc (Match pats _ grhss))
461
462
463
  = do	{ (env1, new_pats) <- zonkPats env pats
	; new_grhss <- zonkGRHSs env1 grhss
	; return (L loc (Match new_pats Nothing new_grhss)) }
464

465
-------------------------------------------------------------------------
466
zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
467

468
zonkGRHSs env (GRHSs grhss binds)
469
  = zonkLocalBinds env binds   	`thenM` \ (new_env, new_binds) ->
470
    let
471
472
473
474
	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)
475
    in
476
    mappM (wrapLocM zonk_grhs) grhss 	`thenM` \ new_grhss ->
477
    returnM (GRHSs new_grhss new_binds)
478
479
480
481
482
483
484
485
486
\end{code}

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

\begin{code}
487
488
489
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
490

491
492
zonkLExprs env exprs = mappM (zonkLExpr env) exprs
zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
493

494
495
zonkExpr env (HsVar id)
  = returnM (HsVar (zonkIdOcc env id))
496

497
498
zonkExpr env (HsIPVar id)
  = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
499

500
zonkExpr env (HsLit (HsRat f ty))
501
  = zonkTcTypeToType env ty	   `thenM` \ new_ty  ->
502
    returnM (HsLit (HsRat f new_ty))
sof's avatar
sof committed
503

Ian Lynagh's avatar
Ian Lynagh committed
504
zonkExpr _ (HsLit lit)
505
  = returnM (HsLit lit)
506
507
508
509

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

511
512
513
zonkExpr env (HsLam matches)
  = zonkMatchGroup env matches	`thenM` \ new_matches ->
    returnM (HsLam new_matches)
514
515

zonkExpr env (HsApp e1 e2)
516
517
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
518
519
520
521
522
523
    returnM (HsApp new_e1 new_e2)

zonkExpr env (HsBracketOut body bs) 
  = mappM zonk_b bs	`thenM` \ bs' ->
    returnM (HsBracketOut body bs')
  where
524
    zonk_b (n,e) = zonkLExpr env e	`thenM` \ e' ->
525
526
		   returnM (n,e')

Ian Lynagh's avatar
Ian Lynagh committed
527
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
528
			     returnM (HsSpliceE s)
529
530

zonkExpr env (OpApp e1 op fixity e2)
531
532
533
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env op	`thenM` \ new_op ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
534
535
    returnM (OpApp new_e1 new_op fixity new_e2)

536
537
538
539
zonkExpr env (NegApp expr op)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    zonkExpr env op	`thenM` \ new_op ->
    returnM (NegApp new_expr new_op)
540
541

zonkExpr env (HsPar e)    
542
  = zonkLExpr env e	`thenM` \new_e ->
543
544
545
    returnM (HsPar new_e)

zonkExpr env (SectionL expr op)
546
547
  = zonkLExpr env expr	`thenM` \ new_expr ->
    zonkLExpr env op		`thenM` \ new_op ->
548
549
550
    returnM (SectionL new_expr new_op)

zonkExpr env (SectionR op expr)
551
552
  = zonkLExpr env op		`thenM` \ new_op ->
    zonkLExpr env expr		`thenM` \ new_expr ->
553
554
    returnM (SectionR new_op new_expr)

555
556
557
558
559
560
561
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') }

562
563
zonkExpr env (HsCase expr ms)
  = zonkLExpr env expr    	`thenM` \ new_expr ->
564
    zonkMatchGroup env ms	`thenM` \ new_ms ->
565
    returnM (HsCase new_expr new_ms)
566

567
568
569
570
571
572
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) }
573
574

zonkExpr env (HsLet binds expr)
575
  = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
576
    zonkLExpr new_env expr	`thenM` \ new_expr ->
577
578
    returnM (HsLet new_binds new_expr)

579
580
581
zonkExpr env (HsDo do_or_lc stmts body ty)
  = zonkStmts env stmts 	`thenM` \ (new_env, new_stmts) ->
    zonkLExpr new_env body	`thenM` \ new_body ->
582
    zonkTcTypeToType env ty	`thenM` \ new_ty   ->
583
    returnM (HsDo do_or_lc new_stmts new_body new_ty)
584
585

zonkExpr env (ExplicitList ty exprs)
586
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
587
    zonkLExprs env exprs	`thenM` \ new_exprs ->
588
589
590
    returnM (ExplicitList new_ty new_exprs)

zonkExpr env (ExplicitPArr ty exprs)
591
  = zonkTcTypeToType env ty	`thenM` \ new_ty ->
592
    zonkLExprs env exprs	`thenM` \ new_exprs ->
593
594
    returnM (ExplicitPArr new_ty new_exprs)

595
zonkExpr env (RecordCon data_con con_expr rbinds)
596
597
598
  = do	{ new_con_expr <- zonkExpr env con_expr
	; new_rbinds   <- zonkRecFields env rbinds
	; return (RecordCon data_con new_con_expr new_rbinds) }
599

600
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
601
602
603
604
605
  = 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) }
606

607
608
609
610
zonkExpr env (ExprWithTySigOut e ty) 
  = do { e' <- zonkLExpr env e
       ; return (ExprWithTySigOut e' ty) }

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

613
614
zonkExpr env (ArithSeq expr info)
  = zonkExpr env expr		`thenM` \ new_expr ->
615
    zonkArithSeq env info	`thenM` \ new_info ->
616
    returnM (ArithSeq new_expr new_info)
617

618
619
zonkExpr env (PArrSeq expr info)
  = zonkExpr env expr		`thenM` \ new_expr ->
620
    zonkArithSeq env info	`thenM` \ new_info ->
621
    returnM (PArrSeq new_expr new_info)
622
623

zonkExpr env (HsSCC lbl expr)
624
  = zonkLExpr env expr	`thenM` \ new_expr ->
625
626
    returnM (HsSCC lbl new_expr)

andy@galois.com's avatar
andy@galois.com committed
627
628
629
630
zonkExpr env (HsTickPragma info expr)
  = zonkLExpr env expr	`thenM` \ new_expr ->
    returnM (HsTickPragma info new_expr)

631
632
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
633
  = zonkLExpr env expr   `thenM` \ new_expr ->
634
635
    returnM (HsCoreAnn lbl new_expr)

636
-- arrow notation extensions
637
zonkExpr env (HsProc pat body)
638
639
640
  = do	{ (env1, new_pat) <- zonkPat env pat
	; new_body <- zonkCmdTop env1 body
	; return (HsProc new_pat new_body) }
641

642
643
644
zonkExpr env (HsArrApp e1 e2 ty ho rl)
  = zonkLExpr env e1	    	    	`thenM` \ new_e1 ->
    zonkLExpr env e2	    	    	`thenM` \ new_e2 ->
645
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
646
    returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
647

648
649
zonkExpr env (HsArrForm op fixity args)
  = zonkLExpr env op	    	    	`thenM` \ new_op ->
650
    mappM (zonkCmdTop env) args		`thenM` \ new_args ->
651
    returnM (HsArrForm new_op fixity new_args)
652

653
zonkExpr env (HsWrap co_fn expr)
654
655
  = zonkCoFn env co_fn	`thenM` \ (env1, new_co_fn) ->
    zonkExpr env1 expr	`thenM` \ new_expr ->
656
    return (HsWrap new_co_fn new_expr)
657

Ian Lynagh's avatar
Ian Lynagh committed
658
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
659

660
661
662
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd

Ian Lynagh's avatar
Ian Lynagh committed
663
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
664
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
665
666
  = zonkLExpr env cmd	    		`thenM` \ new_cmd ->
    zonkTcTypeToTypes env stack_tys	`thenM` \ new_stack_tys ->
667
    zonkTcTypeToType env ty 		`thenM` \ new_ty ->
668
    mapSndM (zonkExpr env) ids		`thenM` \ new_ids ->
669
670
    returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)

671
-------------------------------------------------------------------------
672
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
673
zonkCoFn env WpHole   = return (env, WpHole)
674
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
675
				    ; (env2, c2') <- zonkCoFn env1 c2
676
				    ; return (env2, WpCompose c1' c2') }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
677
678
zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
				 ; return (env, WpCast co') }
679
680
681
682
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') }
683
zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
684
                              return (env, WpTyLam tv) 
685
686
zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
				 ; return (env, WpTyApp ty') }
687
zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
688
				 ; return (env1, WpLet bs') }
689

690
691
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
692
693
694
695
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' }) }
696

697
-------------------------------------------------------------------------
698
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
699

700
zonkArithSeq env (From e)
701
  = zonkLExpr env e		`thenM` \ new_e ->
702
    returnM (From new_e)
703

704
zonkArithSeq env (FromThen e1 e2)
705
706
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
707
    returnM (FromThen new_e1 new_e2)
708

709
zonkArithSeq env (FromTo e1 e2)
710
711
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
712
    returnM (FromTo new_e1 new_e2)
713

714
zonkArithSeq env (FromThenTo e1 e2 e3)
715
716
717
  = zonkLExpr env e1	`thenM` \ new_e1 ->
    zonkLExpr env e2	`thenM` \ new_e2 ->
    zonkLExpr env e3	`thenM` \ new_e3 ->
718
    returnM (FromThenTo new_e1 new_e2 new_e3)
719

720

721
-------------------------------------------------------------------------
722
723
724
725
726
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') }
727

728
729
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
zonkStmt env (ParStmt stmts_w_bndrs)
730
  = mappM zonk_branch stmts_w_bndrs	`thenM` \ new_stmts_w_bndrs ->
731
    let 
732
	new_binders = concat (map snd new_stmts_w_bndrs)
733
734
	env1 = extendZonkEnv env new_binders
    in
735
    return (env1, ParStmt new_stmts_w_bndrs)
736
  where
737
    zonk_branch (stmts, bndrs) = zonkStmts env stmts	`thenM` \ (env1, new_stmts) ->
738
				 returnM (new_stmts, zonkIdOccs env1 bndrs)
739

740
741
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
742
                      , recS_rec_rets = rets })
743
744
745
746
747
748
749
  = do { new_rvs <- zonkIdBndrs env rvs
       ; new_lvs <- zonkIdBndrs env lvs
       ; new_ret_id  <- zonkExpr env ret_id
       ; new_mfix_id <- zonkExpr env mfix_id
       ; new_bind_id <- zonkExpr env bind_id
       ; let env1 = extendZonkEnv env new_rvs
       ; (env2, new_segStmts) <- zonkStmts env1 segStmts
750
751
	-- Zonk the ret-expressions in an envt that 
	-- has the polymorphic bindings in the envt
752
       ; new_rets <- mapM (zonkExpr env2) rets
753
       ; return (extendZonkEnv env new_lvs,     -- Only the lvs are needed
754
755
756
                 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
757
                         , recS_rec_rets = new_rets }) }
758

759
zonkStmt env (ExprStmt expr then_op ty)
760
  = zonkLExpr env expr		`thenM` \ new_expr ->
761
    zonkExpr env then_op	`thenM` \ new_then ->
762
    zonkTcTypeToType env ty	`thenM` \ new_ty ->
763
    returnM (env, ExprStmt new_expr new_then new_ty)
764

765
zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
766
767
768
769
  = do { (env', stmts') <- zonkStmts env stmts 
    ; let binders' = zonkIdOccs env' binders
    ; usingExpr' <- zonkLExpr env' usingExpr
    ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
770
    ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
771
    
772
zonkStmt env (GroupStmt stmts binderMap by using)
773
774
  = do { (env', stmts') <- zonkStmts env stmts 
    ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
775
776
    ; by' <- fmapMaybeM (zonkLExpr env') by
    ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
777
    ; let env'' = extendZonkEnv env' (map snd binderMap')
778
    ; return (env'', GroupStmt stmts' binderMap' by' using') }
779
780
781
782
783
784
  where
    zonkBinderMapEntry env (oldBinder, newBinder) = do 
        let oldBinder' = zonkIdOcc env oldBinder
        newBinder' <- zonkIdBndr env newBinder
        return (oldBinder', newBinder') 

785
zonkStmt env (LetStmt binds)
786
  = zonkLocalBinds env binds	`thenM` \ (env1, new_binds) ->
787
    returnM (env1, LetStmt new_binds)
788

789
zonkStmt env (BindStmt pat expr bind_op fail_op)
790
791
  = do	{ new_expr <- zonkLExpr env expr
	; (env1, new_pat) <- zonkPat env pat
792
793
794
	; new_bind <- zonkExpr env bind_op
	; new_fail <- zonkExpr env fail_op
	; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
795

Ian Lynagh's avatar
Ian Lynagh committed
796
797
zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
zonkMaybeLExpr _   Nothing  = return Nothing
798
799
zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)

800
801

-------------------------------------------------------------------------
802
803
804
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
  = do	{ flds' <- mappM zonk_rbind flds
805
	; return (HsRecFields flds' dd) }
806
  where
807
    zonk_rbind fld
808
809
810
      = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
	   ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
	   ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
811
812

-------------------------------------------------------------------------
813
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
814
mapIPNameTc f (IPName n) = f n  `thenM` \ r -> returnM (IPName r)
815
816
\end{code}

817

818
819
820
821
822
823
824
%************************************************************************
%*									*
\subsection[BackSubst-Pats]{Patterns}
%*									*
%************************************************************************

\begin{code}
825
826
827
828
829
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
830

Ian Lynagh's avatar
Ian Lynagh committed
831
zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
832
zonk_pat env (ParPat p)
833
834
  = do	{ (env', p') <- zonkPat env p
  	; return (env', ParPat p') }
835

836
zonk_pat env (WildPat ty)
837
838
  = do	{ ty' <- zonkTcTypeToType env ty
	; return (env, WildPat ty') }
839

840
zonk_pat env (VarPat v)
841
842
843
  = do	{ v' <- zonkIdBndr env v
	; return (extendZonkEnv1 env v', VarPat v') }

844
zonk_pat env (LazyPat pat)
845
846
  = do	{ (env', pat') <- zonkPat env pat
	; return (env',  LazyPat pat') }
847

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
848
849
850
851
zonk_pat env (BangPat pat)
  = do	{ (env', pat') <- zonkPat env pat
	; return (env',  BangPat pat') }

852
853
854
855
zonk_pat env (AsPat (L loc v) pat)
  = do	{ v' <- zonkIdBndr env v
	; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
 	; return (env', AsPat (L loc v') pat') }
856

857
858
859
zonk_pat env (ViewPat expr pat ty)
  = do	{ expr' <- zonkLExpr env expr
	; (env', pat') <- zonkPat env pat
860
861
 	; ty' <- zonkTcTypeToType env ty
	; return (env', ViewPat expr' pat' ty') }
862

863
zonk_pat env (ListPat pats ty)
864
865
866
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', ListPat pats' ty') }
867

868
zonk_pat env (PArrPat pats ty)
869
870
871
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', PArrPat pats' ty') }
872

873
874
875
876
zonk_pat env (TuplePat pats boxed ty)
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pats') <- zonkPats env pats
	; return (env', TuplePat pats' boxed ty') }
877

878
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args })
879
  = ASSERT( all isImmutableTyVar (pat_tvs p) ) 
880
    do	{ new_ty <- zonkTcTypeToType env ty
881
882
	; (env1, new_evs) <- zonkEvBndrsX env evs
	; (env2, new_binds) <- zonkTcEvBinds env1 binds
883
	; (env', new_args) <- zonkConStuff env2 args
884
	; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs, 
885
			     pat_binds = new_binds, pat_args = new_args }) }
886

887
zonk_pat env (LitPat lit) = return (env, LitPat lit)
888

889
890
891
892
zonk_pat env (SigPatOut pat ty)
  = do	{ ty' <- zonkTcTypeToType env ty
	; (env', pat') <- zonkPat env pat
	; return (env', SigPatOut pat' ty') }
893

894
zonk_pat env (NPat lit mb_neg eq_expr)
895
  = do	{ lit' <- zonkOverLit env lit
896
 	; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
897
 	; eq_expr' <- zonkExpr env eq_expr
898
	; return (env, NPat lit' mb_neg' eq_expr') }
899

900
zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
901
  = do	{ n' <- zonkIdBndr env n
902
903
	; lit' <- zonkOverLit env lit
 	; e1' <- zonkExpr env e1
904
	; e2' <- zonkExpr env e2
905
	; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
906

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
907
908
909
910
911
912
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
913
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
914

915
---------------------------
Ian Lynagh's avatar
Ian Lynagh committed
916
917
918
919
zonkConStuff :: ZonkEnv
             -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
             -> TcM (ZonkEnv,
                     HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
920
zonkConStuff env (PrefixCon pats)
921
922
  = do	{ (env', pats') <- zonkPats env pats
	; return (env', PrefixCon pats') }
923

924
zonkConStuff env (InfixCon p1 p2)
925
926
927
  = do	{ (env1, p1') <- zonkPat env  p1
	; (env', p2') <- zonkPat env1 p2
	; return (env', InfixCon p1' p2') }
928

929
930
931
932
933
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
934
935

---------------------------
Ian Lynagh's avatar
Ian Lynagh committed
936
zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
937
938
zonkPats env []		= return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
939
940
		     ; (env', pats') <- zonkPats env1 pats
		     ; return (env', pat':pats') }
941
942
\end{code}

sof's avatar
sof committed
943
944
945
946
947
948
%************************************************************************
%*									*
\subsection[BackSubst-Foreign]{Foreign exports}
%*									*
%************************************************************************

949

sof's avatar
sof committed
950
\begin{code}
951
952
zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
sof's avatar
sof committed
953

954
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
Ian Lynagh's avatar
Ian Lynagh committed
955
zonkForeignExport env (ForeignExport i _hs_ty spec) =
Simon Marlow's avatar
Simon Marlow committed
956
   returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
Ian Lynagh's avatar
Ian Lynagh committed
957
zonkForeignExport _ for_imp 
958
  = returnM for_imp	-- Foreign imports don't need zonking
sof's avatar
sof committed
959
\end{code}
960
961

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

965
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
966
zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
967
  = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
968

969
970
       ; unbound_tv_set <- newMutVar emptyVarSet
       ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
	-- We need to gather the type variables mentioned on the LHS so we can 
	-- quantify over them.  Example:
	--   data T a = C
	-- 
	--   foo :: T a -> Int
	--   foo C = 1
	--
	--   {-# RULES "myrule"  foo C = 1 #-}
	-- 
	-- After type checking the LHS becomes (foo a (C a))
	-- and we do not want to zap the unbound tyvar 'a' to (), because
	-- that limits the applicability of the rule.  Instead, we
	-- want to quantify over it!  
	--
	-- It's easiest to find the free tyvars here. Attempts to do so earlier
	-- are tiresome, because (a) the data type is big and (b) finding the 
	-- free type vars of an expression is necessarily monadic operation.
	--	(consider /\a -> f @ b, where b is side-effected to a)

990
991
992
993
994
995
996
997
       ; new_lhs <- zonkLExpr env_lhs lhs
       ; new_rhs <- zonkLExpr env_rhs rhs

       ; unbound_tvs <- readMutVar unbound_tv_set
       ; let final_bndrs :: [RuleBndr Var]
	     final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs

       ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
998
  where
999
1000
1001
1002
1003
1004
1005
1006
   zonk_bndr env (RuleBndr (L loc v)) 
      = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
   zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"

   zonk_it env v
     | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
     | isCoVar v  = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
     | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
1007
\end{code}
sof's avatar
sof committed
1008

1009

1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
%************************************************************************
%*									*
              Constraints and evidence
%*									*
%************************************************************************

\begin{code}
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
                                    return (EvId (zonkIdOcc env v))
zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcTypeToType env co
                                       ; return (EvCoercion co') }
zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
                                    do { co' <- zonkTcTypeToType env co
                                       ; return (EvCast (zonkIdOcc env v) co') }
zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
1026
zonkEvTerm env (EvDFunApp df tys tms)
1027
1028
  = do { tys' <- zonkTcTypeToTypes env tys
       ; let tms' = map (zonkEvVarOcc env) tms
1029
       ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058

zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
				       ; return (env', EvBinds bs') }
zonkTcEvBinds env (EvBinds bs)    = do { (env', bs') <- zonkEvBinds env bs
				       ; return (env', EvBinds bs') }

zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
                                           ; zonkEvBinds env (evBindMapBinds bs) }

zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds env binds
  = fixM (\ ~( _, new_binds) -> do
	 { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
         ; binds' <- mapBagM (zonkEvBind env1) binds
         ; return (env1, binds') })
  where
    collect_ev_bndrs :: Bag EvBind -> [EvVar]
    collect_ev_bndrs = foldrBag add [] 
    add (EvBind var _) vars = var : vars

zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
zonkEvBind env (EvBind var term)
  = do { var' <- zonkEvBndr env var
       ; term' <- zonkEvTerm env term
       ; return (EvBind var' term') }
\end{code}

1059
1060
%************************************************************************
%*									*
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1061
                         Zonking types
1062
1063
1064
1065
1066
1067
1068
%*									*
%************************************************************************

\begin{code}
zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty

1069
1070
1071
zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys

1072
1073
1074
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
1075
  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
1076
1077
  where
    zonk_unbound_tyvar tv 
1078
        = do { tv' <- zonkQuantifiedTyVar tv
1079
1080
1081
	     ; tv_set <- readMutVar unbound_tv_set
	     ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
	     ; return (mkTyVarTy tv') }