mirrored from https://gitlab.haskell.org/ghc/ghc.git
-
Notifications
You must be signed in to change notification settings - Fork 705
/
TcHsSyn.lhs
1428 lines (1200 loc) · 56.5 KB
/
TcHsSyn.lhs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
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
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
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1996-1998
%
TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
This module is an extension of @HsSyn@ syntax, for use in the type
checker.
\begin{code}
module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit,
shortCutLit, hsOverLitName,
-- re-exported from TcMonad
TcId, TcIdSet,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkTopBndrs, zonkTyBndrsX,
emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv,
zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
) where
#include "HsVersions.h"
import HsSyn
import Id
import TcRnMonad
import PrelNames
import TypeRep -- We can see the representation of types
import TcType
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
import TcEvidence
import TysPrim
import TysWiredIn
import Type
import DataCon
import Name
import NameSet
import Var
import VarSet
import VarEnv
import DynFlags
import Literal
import BasicTypes
import Maybes
import SrcLoc
import Bag
import FastString
import Outputable
import Util
\end{code}
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%* *
%************************************************************************
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
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 Nothing) = mkListTy ty
hsPatType (ListPat _ _ (Just (ty,_))) = 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)
hsLitType :: HsLit -> TcType
hsLitType (HsChar _) = charTy
hsLitType (HsCharPrim _) = charPrimTy
hsLitType (HsString _) = stringTy
hsLitType (HsStringPrim _) = addrPrimTy
hsLitType (HsInt _) = intTy
hsLitType (HsIntPrim _) = intPrimTy
hsLitType (HsWordPrim _) = wordPrimTy
hsLitType (HsInt64Prim _) = int64PrimTy
hsLitType (HsWord64Prim _) = word64PrimTy
hsLitType (HsInteger _ ty) = ty
hsLitType (HsRat _ ty) = ty
hsLitType (HsFloatPrim _) = floatPrimTy
hsLitType (HsDoublePrim _) = doublePrimTy
\end{code}
Overloaded literals. Here mainly because it uses isIntTy etc
\begin{code}
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
-- 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}
%************************************************************************
%* *
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
%* *
%************************************************************************
The rest of the zonking is done *after* typechecking.
The main zonking pass runs over the bindings
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
b) convert unbound TcTyVar to Void
c) convert each TcId to an Id by zonking its type
The type variables are converted by binding mutable tyvars to immutable ones
and then zonking as normal.
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
It's all pretty boring stuff, because HsSyn is such a large type, and
the environment manipulation is tiresome.
\begin{code}
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) --
(IdEnv 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
-- Is only consulted lazily; hence knot-tying
instance Outputable ZonkEnv where
ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))
emptyZonkEnv :: ZonkEnv
emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping
mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
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])
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
= ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty
= ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env
mkTyVarZonkEnv :: [TyVar] -> ZonkEnv
mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv
setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env
zonkEnvIds :: ZonkEnv -> [Id]
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
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.)
-- (Also foreign-imported things aren't currently in the ZonkEnv;
-- that's ok because they don't need zonking.)
--
-- 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
-- 'main' is done as a separate chunk.
zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id
| isLocalVar id = lookupVarEnv env id `orElse` id
| otherwise = id
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
zonkIdOccs env ids = map (zonkIdOcc env) ids
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form. The TyVarEnv give
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
= do ty' <- zonkTcTypeToType env (idType id)
return (Id.setIdType id ty')
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
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 (extendIdZonkEnv1 env var', var') }
zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
zonkEvBndr env var
= do { let var_ty = varType var
; ty <-
{-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
zonkTcTypeToType env var_ty
; return (setVarType var ty) }
zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
zonkEvVarOcc env v = zonkIdOcc env v
zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX = mapAccumLM zonkTyBndrX
zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
-- This guarantees to return a TyVar (not a TcTyVar)
-- then we add it to the envt, so all occurrences are replaced
zonkTyBndrX env tv
= do { ki <- zonkTcTypeToType env (tyVarKind tv)
; let tv' = mkTyVar (tyVarName tv) ki
; return (extendTyZonkEnv1 env tv', tv') }
\end{code}
\begin{code}
zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
zonkTopExpr e = zonkExpr emptyZonkEnv e
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
zonkTopDecls :: Bag EvBind
-> LHsBinds TcId -> NameSet
-> [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
-- Warn about missing signatures
-- Do this only when we we have a type to offer
; warn_missing_sigs <- woptM Opt_WarnMissingSigs
; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
| otherwise = noSigWarn
; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
-- Top level is implicitly recursive
; rules' <- zonkRules env2 rules
; vects' <- zonkVects env2 vects
; specs' <- zonkLTcSpecPrags env2 imp_specs
; fords' <- zonkForeignExports env2 fords
; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
---------------------------------------------
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
zonkLocalBinds env EmptyLocalBinds
= return (env, EmptyLocalBinds)
zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
= panic "zonkLocalBinds" -- Not in typechecker output
zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
= do { warn_missing_sigs <- woptM 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') }
zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
new_binds <- mapM (wrapLocM zonk_ip_bind) binds
let
env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
(env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
where
zonk_ip_bind (IPBind n e)
= do n' <- mapIPNameTc (zonkIdBndr env) n
e' <- zonkLExpr env e
return (IPBind n' e')
---------------------------------------------
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env sig_warn binds
= fixM (\ ~(_, new_binds) -> do
{ let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 sig_warn binds
; return (env1, binds') })
---------------------------------------------
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 "Polymorphic 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 $ pprPrefixName (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
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})
= do { (_env, new_pat) <- zonkPat env pat -- Env already extended
; sig_warn False (collectPatBinders new_pat)
; new_grhss <- zonkGRHSs env zonkLExpr grhss
; new_ty <- zonkTcTypeToType env ty
; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
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 zonkLExpr 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 })
= ASSERT( all isImmutableTyVar tyvars )
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
; new_exports <- mapM (zonkExport env3) exports
; return (new_val_binds, new_exports) }
; sig_warn True (map abe_poly new_exports)
; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
, abe_mono = mono_id, abe_prags = prags })
= do new_poly_id <- zonkIdBndr env poly_id
(_, new_wrap) <- zonkCoFn env wrap
new_prags <- zonkSpecPrags env prags
return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps
; return (SpecPrags ps') }
zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
zonkLTcSpecPrags env ps
= mapM zonk_prag ps
where
zonk_prag (L loc (SpecPrag id co_fn inl))
= do { (_, co_fn') <- zonkCoFn env co_fn
; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
\end{code}
%************************************************************************
%* *
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
%* *
%************************************************************************
\begin{code}
zonkMatchGroup :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty })
= do { ms' <- mapM (zonkMatch env zBody) ms
; arg_tys' <- zonkTcTypeToTypes env arg_tys
; res_ty' <- zonkTcTypeToType env res_ty
; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) }
zonkMatch :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))
zonkMatch env zBody (L loc (Match pats _ grhss))
= do { (env1, new_pats) <- zonkPats env pats
; new_grhss <- zonkGRHSs env1 zBody grhss
; return (L loc (Match new_pats Nothing new_grhss)) }
-------------------------------------------------------------------------
zonkGRHSs :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
zonkGRHSs env zBody (GRHSs grhss binds) = do
(new_env, new_binds) <- zonkLocalBinds env binds
let
zonk_grhs (GRHS guarded rhs)
= do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
new_rhs <- zBody env2 rhs
return (GRHS new_guarded new_rhs)
new_grhss <- mapM (wrapLocM zonk_grhs) grhss
return (GRHSs new_grhss new_binds)
\end{code}
%************************************************************************
%* *
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
%* *
%************************************************************************
\begin{code}
zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
zonkLExprs env exprs = mapM (zonkLExpr env) exprs
zonkLExpr env expr = wrapLocM (zonkExpr env) expr
zonkExpr env (HsVar id)
= return (HsVar (zonkIdOcc env id))
zonkExpr _ (HsIPVar id)
= return (HsIPVar id)
zonkExpr env (HsLit (HsRat f ty))
= do new_ty <- zonkTcTypeToType env ty
return (HsLit (HsRat f new_ty))
zonkExpr _ (HsLit lit)
= return (HsLit lit)
zonkExpr env (HsOverLit lit)
= do { lit' <- zonkOverLit env lit
; return (HsOverLit lit') }
zonkExpr env (HsLam matches)
= do new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLam new_matches)
zonkExpr env (HsLamCase arg matches)
= do new_arg <- zonkTcTypeToType env arg
new_matches <- zonkMatchGroup env zonkLExpr matches
return (HsLamCase new_arg new_matches)
zonkExpr env (HsApp e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
return (HsApp new_e1 new_e2)
zonkExpr _ e@(HsRnBracketOut _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
zonkExpr env (HsBracketOut body bs)
= do bs' <- mapM zonk_b bs
return (HsBracketOut body bs')
where
zonk_b (PendingRnExpSplice _ e)
= pprPanic "zonkExpr: PendingRnExpSplice" (ppr e)
zonk_b (PendingRnPatSplice _ e)
= pprPanic "zonkExpr: PendingRnPatSplice" (ppr e)
zonk_b (PendingRnCrossStageSplice n)
= pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n)
zonk_b (PendingRnTypeSplice _ e)
= pprPanic "zonkExpr: PendingRnTypeSplice" (ppr e)
zonk_b (PendingRnDeclSplice _ e)
= pprPanic "zonkExpr: PendingRnDeclSplice" (ppr e)
zonk_b (PendingTcSplice n e)
= do e' <- zonkLExpr env e
return (PendingTcSplice n e')
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
return (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
= do new_e1 <- zonkLExpr env e1
new_op <- zonkLExpr env op
new_e2 <- zonkLExpr env e2
return (OpApp new_e1 new_op fixity new_e2)
zonkExpr env (NegApp expr op)
= do new_expr <- zonkLExpr env expr
new_op <- zonkExpr env op
return (NegApp new_expr new_op)
zonkExpr env (HsPar e)
= do new_e <- zonkLExpr env e
return (HsPar new_e)
zonkExpr env (SectionL expr op)
= do new_expr <- zonkLExpr env expr
new_op <- zonkLExpr env op
return (SectionL new_expr new_op)
zonkExpr env (SectionR op expr)
= do new_op <- zonkLExpr env op
new_expr <- zonkLExpr env expr
return (SectionR new_op new_expr)
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') }
zonkExpr env (HsCase expr ms)
= do new_expr <- zonkLExpr env expr
new_ms <- zonkMatchGroup env zonkLExpr ms
return (HsCase new_expr new_ms)
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
; return (HsIf new_e0 new_e1 new_e2 new_e3) }
zonkExpr env (HsMultiIf ty alts)
= do { alts' <- mapM (wrapLocM zonk_alt) alts
; ty' <- zonkTcTypeToType env ty
; return $ HsMultiIf ty' alts' }
where zonk_alt (GRHS guard expr)
= do { (env', guard') <- zonkStmts env zonkLExpr guard
; expr' <- zonkLExpr env' expr
; return $ GRHS guard' expr' }
zonkExpr env (HsLet binds expr)
= do (new_env, new_binds) <- zonkLocalBinds env binds
new_expr <- zonkLExpr new_env expr
return (HsLet new_binds new_expr)
zonkExpr env (HsDo do_or_lc stmts ty)
= do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
new_ty <- zonkTcTypeToType env ty
return (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty wit exprs)
= do new_ty <- zonkTcTypeToType env ty
new_wit <- zonkWit env wit
new_exprs <- zonkLExprs env exprs
return (ExplicitList new_ty new_wit new_exprs)
where zonkWit _ Nothing = return Nothing
zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
return (Just new_fln)
zonkExpr env (ExplicitPArr ty exprs)
= do new_ty <- zonkTcTypeToType env ty
new_exprs <- zonkLExprs env exprs
return (ExplicitPArr new_ty new_exprs)
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
; return (RecordCon data_con new_con_expr new_rbinds) }
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
= 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) }
zonkExpr env (ExprWithTySigOut e ty)
= do { e' <- zonkLExpr env e
; return (ExprWithTySigOut e' ty) }
zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeq expr wit info)
= do new_expr <- zonkExpr env expr
new_wit <- zonkWit env wit
new_info <- zonkArithSeq env info
return (ArithSeq new_expr new_wit new_info)
where zonkWit _ Nothing = return Nothing
zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
return (Just new_fln)
zonkExpr env (PArrSeq expr info)
= do new_expr <- zonkExpr env expr
new_info <- zonkArithSeq env info
return (PArrSeq new_expr new_info)
zonkExpr env (HsSCC lbl expr)
= do new_expr <- zonkLExpr env expr
return (HsSCC lbl new_expr)
zonkExpr env (HsTickPragma info expr)
= do new_expr <- zonkLExpr env expr
return (HsTickPragma info new_expr)
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
= do new_expr <- zonkLExpr env expr
return (HsCoreAnn lbl new_expr)
-- arrow notation extensions
zonkExpr env (HsProc pat body)
= do { (env1, new_pat) <- zonkPat env pat
; new_body <- zonkCmdTop env1 body
; return (HsProc new_pat new_body) }
zonkExpr env (HsWrap co_fn expr)
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
return (HsWrap new_co_fn new_expr)
zonkExpr _ (HsUnboundVar v)
= return (HsUnboundVar v)
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
-------------------------------------------------------------------------
zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id)
zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id)
zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
zonkCmd env (HsCmdCast co cmd)
= do { co' <- zonkTcLCoToLCo env co
; cmd' <- zonkCmd env cmd
; return (HsCmdCast co' cmd') }
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_ty <- zonkTcTypeToType env ty
return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
zonkCmd env (HsCmdArrForm op fixity args)
= do new_op <- zonkLExpr env op
new_args <- mapM (zonkCmdTop env) args
return (HsCmdArrForm new_op fixity new_args)
zonkCmd env (HsCmdApp c e)
= do new_c <- zonkLCmd env c
new_e <- zonkLExpr env e
return (HsCmdApp new_c new_e)
zonkCmd env (HsCmdLam matches)
= do new_matches <- zonkMatchGroup env zonkLCmd matches
return (HsCmdLam new_matches)
zonkCmd env (HsCmdPar c)
= do new_c <- zonkLCmd env c
return (HsCmdPar new_c)
zonkCmd env (HsCmdCase expr ms)
= do new_expr <- zonkLExpr env expr
new_ms <- zonkMatchGroup env zonkLCmd ms
return (HsCmdCase new_expr new_ms)
zonkCmd env (HsCmdIf eCond ePred cThen cElse)
= do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
; new_ePred <- zonkLExpr env ePred
; new_cThen <- zonkLCmd env cThen
; new_cElse <- zonkLCmd env cElse
; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
zonkCmd env (HsCmdLet binds cmd)
= do (new_env, new_binds) <- zonkLocalBinds env binds
new_cmd <- zonkLCmd new_env cmd
return (HsCmdLet new_binds new_cmd)
zonkCmd env (HsCmdDo stmts ty)
= do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
new_ty <- zonkTcTypeToType env ty
return (HsCmdDo new_stmts new_ty)
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
= do new_cmd <- zonkLCmd env cmd
new_stack_tys <- zonkTcTypeToType env stack_tys
new_ty <- zonkTcTypeToType env ty
new_ids <- mapSndM (zonkExpr env) ids
return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn env WpHole = return (env, WpHole)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
zonkCoFn env (WpCast co) = do { co' <- zonkTcLCoToLCo env co
; return (env, WpCast co') }
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') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
do { (env', tv') <- zonkTyBndrX env tv
; return (env', WpTyLam tv') }
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, WpTyApp ty') }
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
; return (env1, WpLet bs') }
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
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' }) }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
zonkArithSeq env (From e)
= do new_e <- zonkLExpr env e
return (From new_e)
zonkArithSeq env (FromThen e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
return (FromThen new_e1 new_e2)
zonkArithSeq env (FromTo e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
return (FromTo new_e1 new_e2)
zonkArithSeq env (FromThenTo e1 e2 e3)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_e3 <- zonkLExpr env e3
return (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
zonkStmts :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])
zonkStmts env _ [] = return (env, [])
zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s
; (env2, ss') <- zonkStmts env1 zBody ss
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
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) }
where
zonk_branch (ParStmtBlock stmts bndrs return_op)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_return <- zonkExpr env1 return_op
; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
zonkStmt env zBody (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
, recS_later_rets = later_rets, recS_rec_rets = rec_rets
, recS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
; new_ret_ty <- zonkTcTypeToType env ret_ty
; new_ret_id <- zonkExpr env ret_id
; new_mfix_id <- zonkExpr env mfix_id
; new_bind_id <- zonkExpr env bind_id
; let env1 = extendIdZonkEnv env new_rvs
; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
; new_later_rets <- mapM (zonkExpr env2) later_rets
; new_rec_rets <- mapM (zonkExpr env2) rec_rets
; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed
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
, recS_later_rets = new_later_rets
, recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
zonkStmt env zBody (BodyStmt body then_op guard_op ty)
= do new_body <- zBody env body
new_then <- zonkExpr env then_op
new_guard <- zonkExpr env guard_op
new_ty <- zonkTcTypeToType env ty
return (env, BodyStmt new_body new_then new_guard new_ty)
zonkStmt env zBody (LastStmt body ret_op)
= do new_body <- zBody env body
new_ret <- zonkExpr env ret_op
return (env, LastStmt new_body new_ret)
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 })
= do { (env', stmts') <- zonkStmts env zonkLExpr stmts
; binderMap' <- mapM (zonkBinderMapEntry env') binderMap
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- zonkLExpr env using
; return_op' <- zonkExpr env' return_op
; bind_op' <- zonkExpr env' bind_op
; liftM_op' <- zonkExpr env' liftM_op
; let env'' = extendIdZonkEnv env' (map snd binderMap')
; 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' }) }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
newBinder' <- zonkIdBndr env newBinder
return (oldBinder', newBinder')
zonkStmt env _ (LetStmt binds)
= do (env1, new_binds) <- zonkLocalBinds env binds
return (env1, LetStmt new_binds)
zonkStmt env zBody (BindStmt pat body bind_op fail_op)
= do { new_body <- zBody env body
; (env1, new_pat) <- zonkPat env pat
; new_bind <- zonkExpr env bind_op
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_body new_bind new_fail) }
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
= do { flds' <- mapM zonk_rbind flds
; return (HsRecFields flds' dd) }
where
zonk_rbind fld
= do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
; new_expr <- zonkLExpr env (hsRecFieldArg fld)
; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
mapIPNameTc _ (Left x) = return (Left x)
mapIPNameTc f (Right x) = do r <- f x
return (Right r)
\end{code}
%************************************************************************
%* *
\subsection[BackSubst-Pats]{Patterns}
%* *
%************************************************************************
\begin{code}
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
zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
zonk_pat env (ParPat p)
= do { (env', p') <- zonkPat env p
; return (env', ParPat p') }
zonk_pat env (WildPat ty)
= do { ty' <- zonkTcTypeToType env ty
; return (env, WildPat ty') }
zonk_pat env (VarPat v)
= do { v' <- zonkIdBndr env v
; return (extendIdZonkEnv1 env v', VarPat v') }
zonk_pat env (LazyPat pat)
= do { (env', pat') <- zonkPat env pat
; return (env', LazyPat pat') }
zonk_pat env (BangPat pat)
= do { (env', pat') <- zonkPat env pat
; return (env', BangPat pat') }
zonk_pat env (AsPat (L loc v) pat)
= do { v' <- zonkIdBndr env v
; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
; return (env', AsPat (L loc v') pat') }
zonk_pat env (ViewPat expr pat ty)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
; ty' <- zonkTcTypeToType env ty
; return (env', ViewPat expr' pat' ty') }