-
Notifications
You must be signed in to change notification settings - Fork 0
/
context_constraints.dpatch
6161 lines (5868 loc) · 260 KB
/
context_constraints.dpatch
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
13 patches for repository http://darcs.haskell.org/ghc:
Mon Mar 8 23:30:17 UTC 2010 matt@softmechanics.net
* Context Constraints
Mon Mar 15 05:41:58 UTC 2010 matt@softmechanics.net
* Context Constraints Part 2
Can now correct deduce which instance to use from type variables, in
addition to (concrete) types. lookupPred is still the main driver,
and there is still lots of debug code in there, from trying to find the
best method.
Two big changes to the simplification loop: the first is that a function
that checks if a matching Inst is available (Inst -> TcM Bool) is passed
down to lookupPred. This could be remedied by importing findAvail into
Inst.lhs.
The second was a simple solution to the problem of deciding an instance
for type variables too early. That is, before all the other instances for
the typeclass parameters have been discovered. The result of choosing too
early is that a more general instance is chosen than should be. I addressed
the problem by modifing passing a boolean "force" argument to lookupPred, indicating
that it must choose the best matching instance it can now. If force is False,
lookupPred will return an instance only if it is the best possible (i.e. no more specific
instance exists).
Tue Mar 16 18:05:20 UTC 2010 matt@softmechanics.net
* Partial Cleanup
Fri Mar 19 17:27:45 UTC 2010 matt@softmechanics.net
* Improved force logic in lookupPred
Fri Mar 19 21:45:27 UTC 2010 matt@softmechanics.net
* Use mutual recursion between applyContextConstraints, lookupPred to lookup context predicates
Sun Mar 21 18:24:44 UTC 2010 matt@softmechanics.net
* New ContextConstraints extension flag
Removed short-circuit logic to always accept a single matched element as properly constrained without checking.
Finally added ContextConstraints extension flag.
Added param to propagate force flag throughout applyContextConstraints/lookupPred loop.
Made ContextConstraints always ignore unified instances.
Wed Mar 24 05:29:04 UTC 2010 matt@softmechanics.net
* Context Constraints: Loop Detection
Added some simple loop detection to the context constraints logic.
Tue Apr 6 20:25:30 UTC 2010 matt@softmechanics.net
* Context Constraints
Wed Apr 7 18:59:59 UTC 2010 matt@softmechanics.net
* Better Handling of Functional Dependencies in Contexts
1) Need to only allow a predicate to "resolve" a type variable (replace it with
a concrete type) if the pred has a functional dependency, and no dependencies
are type variables. Still todo, in the meantime, make sure we have at least
one real type (no check for fun dep). I.e. don't resolve any variable if we
don't know any types.
2) If applyContextConstraints resolves any variables, update the type/variable
parameters for the instance use under consideration.
Wed Apr 28 17:13:54 UTC 2010 matt@softmechanics.net
* better handling of parametric types, i.e. (m a) in instance head
Fri Apr 30 00:10:57 UTC 2010 matt@softmechanics.net
* improved type merging and improvement detection
Tue Jun 8 05:18:17 UTC 2010 matt@softmechanics.net
* move ContextConstraints to TcSimplify
Fri Jun 18 20:15:18 UTC 2010 matt@softmechanics.net
* Remove unused declarations
New patches:
[Context Constraints
matt@softmechanics.net**20100308233017
Ignore-this: 6ffaf8308504978eda2a0c72af9ed137
] {
hunk ./compiler/typecheck/Inst.lhs 753
Just specs -> funDepErr ispec' specs
Nothing -> return ()
- -- Check for duplicate instance decls
- ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
- ; dup_ispecs = [ dup_ispec
- | (dup_ispec, _) <- matches
- , let (_,_,_,dup_tys) = instanceHead dup_ispec
- , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
- -- Find memebers of the match list which ispec itself matches.
- -- If the match is 2-way, it's a duplicate
- ; case dup_ispecs of
- dup_ispec : _ -> dupInstErr ispec' dup_ispec
- [] -> return ()
-
-- OK, now extend the envt
; return (extendInstEnv home_ie ispec') }
hunk ./compiler/types/InstEnv.lhs 36
import UniqFM
import Id
import FastString
+import Type (substPred)
import Data.Maybe ( isJust, isNothing )
\end{code}
hunk ./compiler/types/InstEnv.lhs 450
(pkg_matches, pkg_unifs) = lookup pkg_ie
all_matches = home_matches ++ pkg_matches
all_unifs = home_unifs ++ pkg_unifs
- pruned_matches = foldr insert_overlapping [] all_matches
+ pruned_matches = applyContextConstraints $ foldr insert_overlapping [] all_matches
-- Even if the unifs is non-empty (an error situation)
-- we still prune the matches, so that the error message isn't
-- misleading (complaining of multiple matches when some should be
hunk ./compiler/types/InstEnv.lhs 456
-- overlapped away)
+ --------------
+ applyContextConstraints x@(_:_:_) = reduceContextMatches $ filter matchesContext x
+ applyContextConstraints x = x
+
+ reduceContextMatches [] = []
+ reduceContextMatches [x] = [x]
+ reduceContextMatches (x:xs) = collectMostSpecificContexts [] x xs
+
+ collectMostSpecificContexts outs x []
+ | isMostSpecificContext x outs
+ = x:outs
+ | otherwise
+ = outs
+
+ collectMostSpecificContexts outs x ins@(x':ins')
+ | isMostSpecificContext x (outs ++ ins)
+ = collectMostSpecificContexts (x:outs) x' ins'
+ | otherwise
+ = collectMostSpecificContexts outs x' ins'
+
+ thetaProperSubset :: ThetaType -> ThetaType -> Bool
+ thetaProperSubset sub super =
+ all inSuper sub
+ where inSuper c = inP c super
+ cmpPred (ClassP c1 _) (ClassP c2 _) = c1 == c2
+ cmpPred _ _ = False -- TODO: handle other predicates
+
+ inP _ [] = False
+ inP a (b:_) | a `cmpPred` b = True
+ inP a as = inP a $ tail as
+
+ isMostSpecificContext x xs =
+ all (not . thetaProperSubset (theta x)) $ map theta xs
+ where theta = (\(_,x,_,_) -> x) . instanceHead . fst
+
+ matchesContext (match_inst, _) =
+ all matchesPred theta
+ where (_, theta, _, _) = instanceHead match_inst
+ (Instance { is_tvs = tpl_tvs, is_tys = tpl_tys }) = match_inst
+ (Just subst) = tcMatchTys tpl_tvs tpl_tys tys
+
+ matchesPred pred@(ClassP _ _) =
+ case lookupInstEnv (pkg_ie, home_ie) predC predTys of
+ ([_],_) -> True
+ (_,_) -> False
+ where (ClassP predC predTys) = substPred subst pred
+ matchesPred _ = False
+
--------------
lookup env = case lookupUFM env cls of
Nothing -> ([],[]) -- No instances for this class
}
[Context Constraints Part 2
matt@softmechanics.net**20100315054158
Ignore-this: 3cff74290775029a8f62469f7de4598f
Can now correct deduce which instance to use from type variables, in
addition to (concrete) types. lookupPred is still the main driver,
and there is still lots of debug code in there, from trying to find the
best method.
Two big changes to the simplification loop: the first is that a function
that checks if a matching Inst is available (Inst -> TcM Bool) is passed
down to lookupPred. This could be remedied by importing findAvail into
Inst.lhs.
The second was a simple solution to the problem of deciding an instance
for type variables too early. That is, before all the other instances for
the typeclass parameters have been discovered. The result of choosing too
early is that a more general instance is chosen than should be. I addressed
the problem by modifing passing a boolean "force" argument to lookupPred, indicating
that it must choose the best matching instance it can now. If force is False,
lookupPred will return an instance only if it is the best possible (i.e. no more specific
instance exists).
] {
hunk ./compiler/typecheck/Inst.lhs 804
= NoInstance
| GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
-lookupSimpleInst :: Inst -> TcM LookupInstResult
+lookupSimpleInst :: Bool -> (Inst -> TcM Bool) -> Inst -> TcM LookupInstResult
-- This is "simple" in that it returns NoInstance for implication constraints
-- It's important that lookupInst does not put any new stuff into
hunk ./compiler/typecheck/Inst.lhs 811
-- the LIE. Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify
-lookupSimpleInst (EqInst {}) = return NoInstance
+lookupSimpleInst _ _ (EqInst {}) = return NoInstance
--------------------- Implications ------------------------
hunk ./compiler/typecheck/Inst.lhs 814
-lookupSimpleInst (ImplicInst {}) = return NoInstance
+lookupSimpleInst _ _ (ImplicInst {}) = return NoInstance
--------------------- Methods ------------------------
hunk ./compiler/typecheck/Inst.lhs 817
-lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
+lookupSimpleInst _ _ (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
= do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
hunk ./compiler/typecheck/Inst.lhs 831
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
+lookupSimpleInst _ _ (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
, ol_rebindable = rebindable }
, tci_ty = ty, tci_loc = iloc})
| debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
hunk ./compiler/typecheck/Inst.lhs 852
loc = instLocSpan iloc
--------------------- Dictionaries ------------------------
-lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
- = do { mb_result <- lookupPred pred
+lookupSimpleInst force availP dct@(Dict {tci_pred = pred, tci_loc = loc})
+ = do { mb_result <- lookupPred force availP dct
; case mb_result of {
Nothing -> return NoInstance ;
Just (dfun_id, mb_inst_tys) -> do
hunk ./compiler/typecheck/Inst.lhs 884
}}}}
---------------
-lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
+applyContextConstraints _ _ _ _ x@([],_) = return x
+applyContextConstraints _ _ _ _ x@([_],_) = return x
+applyContextConstraints inst availP ies tys (ms,us) =
+ do ms' <- filterM matchesContext ms
+ return (reduceContextMatches ms', us)
+ where
+ reduceContextMatches [] = []
+ reduceContextMatches [x] = [x]
+ reduceContextMatches (x:xs) = collectMostSpecificContexts [] x xs
+
+ collectMostSpecificContexts outs x []
+ | isMostSpecificContext x outs
+ = x:outs
+ | otherwise
+ = outs
+
+ collectMostSpecificContexts outs x ins@(x':ins')
+ | isMostSpecificContext x (outs ++ ins)
+ = collectMostSpecificContexts (x:outs) x' ins'
+ | otherwise
+ = collectMostSpecificContexts outs x' ins'
+
+ isMostSpecificContext x xs =
+ all (not . thetaProperSubset (theta x)) $ map theta xs
+ where theta = (\(_,x,_,_) -> x) . instanceHead . fst
+
+ thetaProperSubset :: ThetaType -> ThetaType -> Bool
+ thetaProperSubset sub super =
+ all inSuper sub
+ where inSuper c = inP c super
+ cmpPred (ClassP c1 _) (ClassP c2 _) = c1 == c2
+ cmpPred _ _ = False -- TODO: handle other predicates
+
+ inP _ [] = False
+ inP a (b:_) | a `cmpPred` b = True
+ inP a as = inP a $ tail as
+
+ matchesContext match@(match_inst, _) =
+ do bools <- mapM matchesPred theta
+ return $ and bools
+ where (_, theta, _, _) = instanceHead match_inst
+ (Instance { is_tvs = tpl_tvs, is_tys = tpl_tys }) = match_inst
+ (Just subst) = tcMatchTys tpl_tvs tpl_tys tys
+
+ matchesPred pred@(ClassP _ _) =
+ do let (ClassP predC predTys) = substPred subst pred
+ let lookup = lookupInstEnv ies predC predTys
+ res <- applyContextConstraints inst availP ies predTys lookup
+ case res of
+ ([x],_) -> instMatchAvailP availP inst x
+ _ -> return False
+ matchesPred _ = return False
+
+predClassNames inst =
+ map getName theta
+ where (_, theta, _, _) = instanceHead inst
+ getName (ClassP cls _) = className cls
+
+matchInst :: Inst -> (DFunId, [Either TyVar TcType]) -> TcM LookupInstResult
+matchInst (Dict {tci_pred=pred, tci_loc=loc}) (dfun_id, mb_inst_tys) = do
+ { use_stage <- getStage
+ ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) (thLevel use_stage)
+
+ -- It's possible that not all the tyvars are in
+ -- the substitution, tenv. For example:
+ -- instance C X a => D X where ...
+ -- (presumably there's a functional dependency in class C)
+ -- Hence mb_inst_tys :: Either TyVar TcType
+
+ ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
+ inst_tv (Right ty) = return ty
+ ; tys <- mapM inst_tv mb_inst_tys
+ ; let
+ (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
+ src_loc = instLocSpan loc
+ dfun = HsVar dfun_id
+ ; if null theta then
+ return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
+ else do
+ { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
+ ; let co_fn = dict_app <.> mkWpTyApps tys
+ ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
+ }}
+
+returnInsts (ispec, inst_tys) = (is_dfun ispec, inst_tys)
+
+maybeGenInst gi@(GenInst dicts _) = Just gi
+maybeGenInst _ = Nothing
+
+lookupInstResultAvailP :: (Inst -> TcM Bool) -> LookupInstResult -> TcM Bool
+lookupInstResultAvailP availP (GenInst dicts _) =
+ do avails <- mapM availP dicts
+ return $ and avails
+
+--instMatchAvailP :: (Inst -> TcM Bool) -> Inst -> InstMatch -> TcM Bool
+instMatchAvailP availP inst match =
+ do match' <- matchInst inst $ returnInsts match
+ lookupInstResultAvailP availP match'
+
+-- an instance with zero type variables is THE best match
+-- an instance is "a best match" if no other instance has
+-- all its predicates and more
+bestInstMatches [] = []
+bestInstMatches [x] = [x]
+bestInstMatches (x:xs) = collectMostSpecificContexts [] x xs
+ where
+-- collectMostSpecificContexts _ x _
+-- | noTypeVariables x
+-- = [x]
+--
+ collectMostSpecificContexts outs x []
+ | isMostSpecificContext x outs
+ = x:outs
+ | otherwise
+ = outs
+
+ collectMostSpecificContexts outs x ins@(x':ins')
+ | isMostSpecificContext x (outs ++ ins)
+ = collectMostSpecificContexts (x:outs) x' ins'
+ | otherwise
+ = collectMostSpecificContexts outs x' ins'
+
+ noTypeVariables x = null $ tyVars x
+ tyVars = (\(x,_,_,_) -> x) . instanceHead . fst
+
+-- this is a naive match method. it has no knowledge
+-- of which type variables a pred is predicating.
+-- so (A a, A b, C c) is a proper subset of (A a, B b, C c),
+-- which is not true. However, I can't figure out why tcEqPred
+-- always fails on type variables. Needs unification? Maybe tcMatchTys?
+thetaProperSubset :: ThetaType -> ThetaType -> Bool
+thetaProperSubset subTheta superTheta =
+ -- NO pred exists strictly more times in sub than in super
+ -- SOME pred exists less times in sub than in super
+
+ (not $ any (hasLess super sub) combined) && (any (hasLess sub super) combined)
+
+ where hasLess t1 t2 c = (count c t1) < (count c t2)
+
+ cmpPred (ClassP c1 _) (ClassP c2 _) = c1 == c2
+ cmpPred _ _ = False -- TODO: handle other predicates
+
+ count _ [] = 0
+ count a (b:bs) | a `cmpPred` b = 1 + (count a bs)
+ | otherwise = count a bs
+
+ sub = filter isClassPred subTheta
+ super = filter isClassPred superTheta
+
+ combined = sub ++ super
+
+
+--thetaProperSubset :: ThetaType -> ThetaType -> Bool
+--thetaProperSubset sub super =
+-- (all (hasP super) sub) && (not $ all (hasP sub) super)
+-- where hasP [] _ = False
+-- hasP (b:bs) a | tcEqPred a b = True
+-- | otherwise = hasP bs a
+--
+isMoreSpecificInst x y =
+ not $ thetaProperSubset (theta x) (theta y)
+ where theta = instanceTheta.fst
+
+instanceTheta = (\(_,x,_,_) -> x) . instanceHead
+instanceTyVars = (\(x,_,_,_) -> x) . instanceHead
+
+isMostSpecificContext x xs
+-- | null $ tyVars x
+-- = True
+-- | otherwise
+ = all (isMoreSpecificInst x) xs
+ where tyVars = (\(x,_,_,_) -> x) . instanceHead . fst
+ xs' = filter (\y -> not $ tcEqTheta (theta x) (theta y)) xs
+ theta = instanceTheta.fst
+
+eqLength x y = (length x) == (length y)
+
+zipWith' f x y
+ | eqLength x y
+ = and $ zipWith f x y
+ | otherwise
+ = False
+
+tcEqTheta = zipWith' eqVarNamesPred
+
+eqVarNamesPred (ClassP c1 vs1) (ClassP c2 vs2)
+ = c1 == c2 && vs1 `eqVarNamesTypes` vs2
+eqVarNamesPred _ _ = False
+
+eqVarNamesTypes = zipWith' eqVarNamesType
+
+eqVarNamesType (TyVarTy tv1) (TyVarTy tv2) = tv1 `eqVarNamesVar` tv2
+eqVarNamesType (AppTy f1 a1) (AppTy f2 a2) = f1 `eqVarNamesType` f2 && a1 `eqVarNamesType` a2
+eqVarNamesType (TyConApp c1 tys1) (TyConApp c2 tys2) = c1 == c2 && tys1 `eqVarNamesTypes` tys2
+eqVarNamesType (FunTy f1 a1) (FunTy f2 a2) = f1 `eqVarNamesType` f2 && a1 `eqVarNamesType` a2
+eqVarNamesType (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) = tv1 `eqVarNamesVar` tv2 && ty1 `eqVarNamesType` ty2
+
+eqVarNamesVar x y = (getName x) == (getName y)
+
+
+checkAvail _ _ x@([],_) = return x
+checkAvail _ _ x@([_],_) = return x
+checkAvail availP inst (insts,unifs) =
+ do insts' <- filterM (instMatchAvailP availP inst) insts
+ return (insts', unifs)
+
+tcEqInstMatch' (i1, tys1) (i2, tys2)
+ = tcEqTheta theta1 theta2
+ where theta1 = instanceTheta i1
+ theta2 = instanceTheta i2
+
+tcEqInstMatch (i1, _) (i2, _)
+ = case mkInstTypeMap i1 i2 of
+ Nothing -> False
+ (Just tvMap) -> tcEqTheta theta1 theta2
+ where theta1 = mapTyVarsPreds tvMap $ instanceTheta i1
+ -- theta1 = instanceTheta i1
+ theta2 = instanceTheta i2
+
+tcEqInstMatch'' (i1,_) (i2,_)
+ = tcEqTheta theta1 theta2
+ where theta1 = mapTyVarsPreds tvMap $ instanceTheta i1
+ theta2 = instanceTheta i2
+ tvMap = zip tvs1 tvs2
+ tvs1 = instanceTyVars i1
+ tvs2 = instanceTyVars i2
+
+mapTheta (i1, tys1) (i2, tys2)
+ = case mkInstTypeMap tys1 tys2 of
+ Nothing -> []
+ (Just tvMap) -> theta1
+ where theta1 = mapTyVarsPreds tvMap $ instanceTheta i1
+
+mapTyVarsPreds tvMap = map (mapTyVarsPred tvMap)
+mapTyVarsPred tvMap (ClassP cls tys) = ClassP cls $ mapTyVarsTypes tvMap tys
+
+mapTyVarsTypes :: [(TyVar,TyVar)] -> [Type] -> [Type]
+mapTyVarsTypes tvMap tys = map (mapTyVarsType tvMap) tys
+
+mapTyVarsType tvMap (TyVarTy tv)
+ = TyVarTy $ mapTyVar tvMap tv
+
+mapTyVarsType tvMap (AppTy ty1 ty2)
+ = AppTy (mapTyVarsType tvMap ty1) (mapTyVarsType tvMap ty2)
+
+mapTyVarsType tvMap (TyConApp tc tys)
+ = TyConApp tc $ mapTyVarsTypes tvMap tys
+
+mapTyVarsType tvMap (FunTy ty1 ty2)
+ = FunTy (mapTyVarsType tvMap ty1) (mapTyVarsType tvMap ty2)
+
+mapTyVarsType tvMap (ForAllTy tv ty)
+ = ForAllTy (mapTyVar tvMap tv) (mapTyVarsType tvMap ty)
+
+mapTyVarsType tvMap (PredTy pred)
+ = PredTy $ mapTyVarsPred tvMap pred
+
+mapTyVar :: [(TyVar, TyVar)] -> TyVar -> TyVar
+mapTyVar tvMap tv
+ = case lookup' tv of
+ Just tv' -> tv'
+ Nothing -> tv
+ where lookup' tv1 = find (\(tv2,res) -> eqVarNamesVar tv1 tv2) tvMap >>= Just . snd
+
+mkInstTypeMap i1 i2
+ | (length tvs1) == (length tvs2)
+ = Just $ filter (\(v1, v2) -> not $ eqVarNamesVar v1 v2) $ zip tvs1 tvs2
+ | otherwise
+ = Nothing
+ where tvs1 = instanceTyVars i1
+ tvs2 = instanceTyVars i2
+
+--mkInstTypeMap :: [Either TyVar Type] -> [Either TyVar Type] -> Maybe [(TyVar,TyVar)]
+--mkInstTypeMap tys1 tys2 = foldM matchLeft [] $ zip tys1 tys2
+-- where matchLeft ms (Left tv1, Left tv2) = Just ((tv1,tv2):ms)
+-- matchLeft _ _ = Nothing
+
+-- should always be the same length
+tcEqInstTypes [] [] = True
+tcEqInstTypes (x:xs) (y:ys) = tcEqInstType x y && tcEqInstTypes xs ys
+
+tcEqInstType (Left _) (Right _) = False
+tcEqInstType (Right _) (Left _) = False
+tcEqInstType (Left _) (Left _) = True
+tcEqInstType (Right ty1) (Right ty2) = tcEqType ty1 ty2
+
+testInstMatchCompare [] = return ()
+testInstMatchCompare (inst:rest) =
+ do { mapM (testInstMatchCompare' inst) rest
+ ; testInstMatchCompare rest }
+
+testInstMatchCompare' m1@(i1,_) m2@(i2,_) =
+ do { traceTc (text "MATT: COMPARING INSTS" <+> (ppr [m1,m2]))
+ ; let tys1 = instanceTyVars i1
+ ; let tys2 = instanceTyVars i2
+
+ ; traceTc (text "INST1 VARS: " <+> (ppr tys1))
+ ; traceTc (text "INST2 VARS: " <+> (ppr tys2))
+ ; case tcEqInstMatch m1 m2 of
+ False -> traceTc (text "MATT: tcEqInstMatch FAILED")
+ True -> traceTc (text "MATT: tcEqInstMatch OK" )
+ ; case tcEqInstMatch' m1 m2 of
+ False -> traceTc (text "MATT: tcEqInstMatch' FAILED")
+ True -> traceTc (text "MATT: tcEqInstMatch' OK" )
+ ; case tcEqInstMatch'' m1 m2 of
+ False -> traceTc (text "MATT: tcEqInstMatch'' FAILED")
+ True -> traceTc (text "MATT: tcEqInstMatch'' OK" )
+ ; return () }
+
+
+removeDuplicates [] = []
+removeDuplicates [a] = [a]
+removeDuplicates (a:as)
+ | isDuplicate a = removeDuplicates as
+ | otherwise = a:(removeDuplicates as)
+ where isDuplicate a = isJust $ find (tcEqInstMatch a) as
+-- cmp (i1,_) (i2,_) = (theta i1) `tcEqTheta` (theta i2)
+-- theta = (\(_,t,_,_)->t).instanceHead
+
+lookupPred :: Bool -> (Inst -> TcM Bool) -> Inst -> TcM (Maybe (DFunId, [Either TyVar TcType]))
-- Look up a class constraint in the instance environment
hunk ./compiler/typecheck/Inst.lhs 1206
-lookupPred pred@(ClassP clas tys)
- = do { eps <- getEps
+lookupPred force availP inst@(Dict {tci_pred = pred@(ClassP clas tys), tci_loc = loc})
+ = do { ; eps <- getEps
; tcg_env <- getGblEnv
; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
hunk ./compiler/typecheck/Inst.lhs 1210
- ; case lookupInstEnv inst_envs clas tys of {
+ ; let insts = lookupInstEnv inst_envs clas tys
+ ; let (inst_matches, inst_unifs) = insts
+ ; ASSERT( and $ map ((\x -> tcEqInstTypes x x).snd) inst_matches)
+
+ -- TODO: check for ContextConstraints flag
+ case force of
+ True -> traceTc (text "MATT: LOOKUP (FORCE)" <+> ppr pred)
+ False -> traceTc (text "MATT: LOOKUP" <+> ppr pred)
+ ; traceTc (text "MATT: MATCHES" <+> ppr inst_matches)
+ ; constrained <- applyContextConstraints inst availP inst_envs tys insts
+ ; traceTc (text "MATT: CONSTRAINED" <+> ppr constrained)
+ ; avail_insts <- checkAvail availP inst insts
+ ; traceTc (text "MATT: AVAIL INSTS" <+> (ppr avail_insts))
+ ; let best_avail = (\(x,y) -> (bestInstMatches x, y)) avail_insts
+ ; traceTc (text "MATT: BEST AVAIL INSTS" <+> (ppr best_avail))
+ ; avail_insts' <- applyContextConstraints inst availP inst_envs tys avail_insts
+ ; traceTc (text "MATT: CONSTRAINED AVAIL INSTS" <+> (ppr avail_insts'))
+ ; let both_dupes = (\(x1,y1) (x2,y2) -> ((x1++x2),y1++y2)) avail_insts constrained
+ ; traceTc (text "MATT: BOTH WORLDS WITH DUPES" <+> (ppr both_dupes))
+ ; testInstMatchCompare $ fst both_dupes
+ ; let both = (\(x1,y1) (x2,y2) -> (removeDuplicates (x1++x2), (y1++y2))) avail_insts constrained
+ ; traceTc (text "MATT: BOTH WORLDS" <+> (ppr both))
+ ; let best_both = (\(x,y) -> (bestInstMatches x, y)) both
+ ; traceTc (text "MATT: BEST OF BOTH WORLDS" <+> (ppr best_both))
+ ; let (best_matches, _) = best_both
+ ; let best_possible = filter (flip isMostSpecificContext inst_matches) best_matches
+ ; traceTc (text "MATT: BEST POSSIBLE" <+> (ppr best_possible))
+ ; let final = case (not force) && (isTyVarDict inst) of
+ -- if there are unconstrained type vars, don't decide yet
+ -- XXX This is a hack, and *should not* work in general
+ True -> (best_possible, [])
+
+ -- time to decide. pick the best match(es). No guarantee we're not still
+ -- deciding too early.
+ False -> best_both
+ ; traceTc (text "MATT: DONE: " <+> (ppr final))
+ ; case final of {
([(ispec, inst_tys)], [])
-> do { let dfun_id = is_dfun ispec
; traceTc (text "lookupInst success" <+>
hunk ./compiler/typecheck/Inst.lhs 1270
; return Nothing }
}}
-lookupPred (IParam {}) = return Nothing -- Implicit parameters
-lookupPred (EqPred {}) = panic "lookupPred EqPred"
+lookupPred _ _ (Dict {tci_pred = (IParam {})}) = return Nothing -- Implicit parameters
+lookupPred _ _ (Dict {tci_pred = (EqPred {})}) = panic "lookupPred EqPred"
record_dfun_usage :: Id -> TcRn ()
record_dfun_usage dfun_id
hunk ./compiler/typecheck/TcSimplify.lhs 62
import Control.Monad
import Data.List
+import Data.Maybe
\end{code}
hunk ./compiler/typecheck/TcSimplify.lhs 1036
}
-----------------------------------------------------------
+tryReallyHardCheckLoop :: SDoc
+ -> [Inst] -- Wanted
+ -> TcM ([Inst], TcDictBinds)
+
+tryReallyHardCheckLoop doc wanteds
+ = do { (irreds,binds) <- forceCheckLoop (mkInferRedEnv doc try_me) wanteds
+ ; return (irreds,binds)
+ }
+ where
+ try_me _ = ReduceMe
+ -- Here's the try-hard bit
+
tryHardCheckLoop :: SDoc
-> [Inst] -- Wanted
-> TcM ([Inst], TcDictBinds)
hunk ./compiler/typecheck/TcSimplify.lhs 1115
\begin{code}
-----------------------------------------------------------
+checkLoop' True = forceCheckLoop
+checkLoop' False = checkLoop
+
+forceCheckLoop :: RedEnv
+ -> [Inst] -- Wanted
+ -> TcM ([Inst], TcDictBinds)
+-- Precondition: givens are completely rigid
+-- Postcondition: returned Insts are zonked
+
+forceCheckLoop env wanteds
+ = go env wanteds
+ where go env wanteds
+ = do { -- We do need to zonk the givens; cf Note [Zonking RedEnv]
+ ; traceTc (text "MATT: entering forceCheckLoop ")
+ ; env' <- zonkRedEnv env
+ ; wanteds' <- zonkInsts wanteds
+
+ ; (improved, tybinds, binds, irreds)
+ <- reduceContext env' wanteds'
+ ; execTcTyVarBinds tybinds
+ --; if null irreds || not improved then
+ ; if not improved then
+ do {
+ ;(improved1, tybinds1, binds1, irreds1)
+ <- forceReduceContext env' wanteds'
+ ; execTcTyVarBinds tybinds1
+ ; if null irreds1 || not improved1 then
+ do {
+ ; traceTc (text "MATT: forceCheckLoop exiting")
+ ; return (irreds1, binds1) }
+ else do {
+ ; (irreds2, binds2) <- go env' irreds1
+ ; return (irreds2, binds1 `unionBags` binds2) } }
+ else do
+ -- If improvement did some unification, we go round again.
+ -- We start again with irreds, not wanteds
+ -- Using an instance decl might have introduced a fresh type
+ -- variable which might have been unified, so we'd get an
+ -- infinite loop if we started again with wanteds!
+ -- See Note [LOOP]
+ { (irreds1, binds1) <- go env' irreds
+ ; return (irreds1, binds `unionBags` binds1) } }
checkLoop :: RedEnv
-> [Inst] -- Wanted
-> TcM ([Inst], TcDictBinds)
hunk ./compiler/typecheck/TcSimplify.lhs 1167
= go env wanteds
where go env wanteds
= do { -- We do need to zonk the givens; cf Note [Zonking RedEnv]
+ ; traceTc (text "MATT: entering checkLoop ")
; env' <- zonkRedEnv env
; wanteds' <- zonkInsts wanteds
hunk ./compiler/typecheck/TcSimplify.lhs 1176
; execTcTyVarBinds tybinds
; if null irreds || not improved then
- return (irreds, binds)
+ do {
+ ; traceTc (text "MATT: checkLoop exiting")
+ ; return (irreds, binds) }
else do
-- If improvement did some unification, we go round again.
hunk ./compiler/typecheck/TcSimplify.lhs 1680
| otherwise
= do { w' <- zonkInst w -- So that (3::Int) does not generate a call
-- to fromInteger; this looks fragile to me
- ; lookup_result <- lookupSimpleInst w'
+ ; lookup_result <- lookupSimpleInst False (\_ -> return False) w'
; case lookup_result of
NoInstance -> go (w:irreds) binds ws
GenInst ws' rhs -> go irreds binds' (ws' ++ ws)
hunk ./compiler/typecheck/TcSimplify.lhs 1942
TcDictBinds, -- Dictionary bindings
[Inst]) -- Irreducible
-reduceContext env wanteds0
- = do { traceTc (text "reduceContext" <+> (vcat [
+reduceContext = reduceContext' False
+forceReduceContext = reduceContext' True
+reduceContext' force env wanteds0
+ = do {
+ ;if force then traceTc (text "MATT: reduceContext' FORCE")
+ else traceTc (text "MATT reduceContext'")
+ ;traceTc (text "reduceContext" <+> (vcat [
text "----------------------",
red_doc env,
text "given" <+> ppr (red_givens env),
hunk ./compiler/typecheck/TcSimplify.lhs 1987
-- of improvement due to functional dependencies if any of the
-- involved unifications gets deferred.
; let (wanted_implics, wanted_dicts) = partition isImplicInst wanteds'
- ; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
+ ; (avails, extra_eqs) <- getLIE (reduceList' force env wanted_dicts init_state)
-- The getLIE is reqd because reduceList does improvement
-- (via extendAvails) which may in turn do unification
; (dict_binds,
hunk ./compiler/typecheck/TcSimplify.lhs 2007
= givens ++ bound_dicts ++
map wantedToLocalEqInst dict_irreds }
; (implic_binds_s, implic_irreds_s)
- <- mapAndUnzipM (reduceImplication implic_env) wanted_implics
+ <- mapAndUnzipM (reduceImplication' force implic_env) wanted_implics
; let implic_binds = unionManyBags implic_binds_s
implic_irreds = concat implic_irreds_s
hunk ./compiler/typecheck/TcSimplify.lhs 2035
improvedHint = (if avails_improved then " [AVAILS]" else "") ++
(if eq_improved then " [EQ]" else "")
+ ; if force then traceTc (text "MATT: reduceContext FORCE")
+ else traceTc (text "MATT: reduceContext FORCE")
; traceTc (text "reduceContext end" <+> (vcat [
text "----------------------",
red_doc env,
hunk ./compiler/typecheck/TcSimplify.lhs 2158
The main context-reduction function is @reduce@. Here's its game plan.
\begin{code}
-reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails
-reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
- = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
+--reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails
+--reduceList = reduceList' False
+reduceList' force env@(RedEnv {red_stack = (n,stk)}) wanteds state
+ = do {
+ ; (case force of
+ True -> traceTc (text "reduceList (FORCE) " <+> (ppr wanteds $$ ppr state))
+ False -> traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state)))
; dopts <- getDOpts
; when (debugIsOn && (n > 8)) $ do
debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n)
hunk ./compiler/typecheck/TcSimplify.lhs 2175
go wanteds state }
where
go [] state = return state
- go (w:ws) state = do { state' <- reduce (env {red_stack = (n+1, w:stk)}) w state
+ go (w:ws) state = do { state' <- reduce' force (env {red_stack = (n+1, w:stk)}) w state
; go ws state' }
-- Base case: we're done!
hunk ./compiler/typecheck/TcSimplify.lhs 2180
reduce :: RedEnv -> Inst -> Avails -> TcM Avails
-reduce env wanted avails
+reduce = reduce' False
+reduce' force env wanted avails
-- We don't reduce equalities here (and they must not end up as irreds
-- in the Avails!)
hunk ./compiler/typecheck/TcSimplify.lhs 2195
}
| otherwise
- = do { traceTc (text "reduce" <+> ppr wanted $$ ppr avails)
+ = do {
+ ; (case force of
+ True -> traceTc (text "reduce (FORCE)" <+> ppr wanted $$ ppr avails)
+ False -> traceTc (text "reduce" <+> ppr wanted $$ ppr avails))
; case red_try_me env wanted of {
Stop -> try_simple (addIrred NoSCs);
-- See Note [No superclasses for Stop]
hunk ./compiler/typecheck/TcSimplify.lhs 2204
ReduceMe -> do -- It should be reduced
- { (avails, lookup_result) <- reduceInst env avails wanted
+ { (avails, lookup_result) <- reduceInst force env avails wanted
; case lookup_result of
NoInstance -> addIrred AddSCs avails wanted
-- Add it and its superclasses
hunk ./compiler/typecheck/TcSimplify.lhs 2213
GenInst wanteds' rhs
-> do { avails1 <- addIrred NoSCs avails wanted
- ; avails2 <- reduceList env wanteds' avails1
+ ; avails2 <- reduceList' force env wanteds' avails1
; addWanted AddSCs avails2 wanted rhs wanteds' } }
-- Temporarily do addIrred *before* the reduceList,
-- which has the effect of adding the thing we are trying
hunk ./compiler/typecheck/TcSimplify.lhs 2229
-- Works well for literals (1::Int) and constant dictionaries (d::Num Int)
-- Don't bother for implication constraints, which take real work
try_simple do_this_otherwise
- = do { res <- lookupSimpleInst wanted
+ = do { res <- lookupSimpleInst force (return . isJust . findAvail avails) wanted
; case res of
GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
_ -> do_this_otherwise avails wanted }
hunk ./compiler/typecheck/TcSimplify.lhs 2322
\begin{code}
---------------------------------------------
-reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
-reduceInst _ avails other_inst
- = do { result <- lookupSimpleInst other_inst
+reduceInst :: Bool -> RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
+reduceInst force _ avails other_inst
+ = do { result <- lookupSimpleInst force (return . isJust . findAvail avails) other_inst
; return (avails, result) }
\end{code}
hunk ./compiler/typecheck/TcSimplify.lhs 2400
-- where cotv is a simple coercion type variable (and not a more
-- complex coercion term). We require that the extra_givens always
-- have this form and exploit the special form when generating binders.
-reduceImplication env
+reduceImplication = reduceImplication' False
+reduceImplication' force env
orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc,
tci_tyvars = tvs,
tci_given = extra_givens, tci_wanted = wanteds
hunk ./compiler/typecheck/TcSimplify.lhs 2418
; traceTc (text "reduceImplication" <+> vcat
[ ppr (red_givens env), ppr extra_givens,
ppr wanteds])
- ; (irreds, binds) <- checkLoop env' wanteds
+ ; (irreds, binds) <- checkLoop' force env' wanteds
; traceTc (text "reduceImplication result" <+> vcat
[ppr irreds, ppr binds])
hunk ./compiler/typecheck/TcSimplify.lhs 2483
simpler_implic_insts)
}
}
-reduceImplication _ i = pprPanic "reduceImplication" (ppr i)
+reduceImplication' _ _ i = pprPanic "reduceImplication" (ppr i)
\end{code}
Note [Always inline implication constraints]
hunk ./compiler/typecheck/TcSimplify.lhs 2857
; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds))
; traceTc (text "tc_simplify_top 0: " <+> ppr wanteds)
- ; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
+ ; (irreds1, binds1) <- tryReallyHardCheckLoop doc1 wanteds
-- ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1
hunk ./compiler/types/InstEnv.lhs 36
import UniqFM
import Id
import FastString
-import Type (substPred)
import Data.Maybe ( isJust, isNothing )
\end{code}
hunk ./compiler/types/InstEnv.lhs 449
(pkg_matches, pkg_unifs) = lookup pkg_ie
all_matches = home_matches ++ pkg_matches
all_unifs = home_unifs ++ pkg_unifs
- pruned_matches = applyContextConstraints $ foldr insert_overlapping [] all_matches
+ pruned_matches = foldr insert_overlapping [] all_matches
-- Even if the unifs is non-empty (an error situation)
-- we still prune the matches, so that the error message isn't
-- misleading (complaining of multiple matches when some should be
hunk ./compiler/types/InstEnv.lhs 455
-- overlapped away)
- --------------
- applyContextConstraints x@(_:_:_) = reduceContextMatches $ filter matchesContext x
- applyContextConstraints x = x
-
- reduceContextMatches [] = []
- reduceContextMatches [x] = [x]
- reduceContextMatches (x:xs) = collectMostSpecificContexts [] x xs
-
- collectMostSpecificContexts outs x []
- | isMostSpecificContext x outs
- = x:outs
- | otherwise
- = outs
-
- collectMostSpecificContexts outs x ins@(x':ins')
- | isMostSpecificContext x (outs ++ ins)
- = collectMostSpecificContexts (x:outs) x' ins'
- | otherwise
- = collectMostSpecificContexts outs x' ins'
-
- thetaProperSubset :: ThetaType -> ThetaType -> Bool
- thetaProperSubset sub super =
- all inSuper sub
- where inSuper c = inP c super
- cmpPred (ClassP c1 _) (ClassP c2 _) = c1 == c2
- cmpPred _ _ = False -- TODO: handle other predicates
-
- inP _ [] = False
- inP a (b:_) | a `cmpPred` b = True
- inP a as = inP a $ tail as
-
- isMostSpecificContext x xs =
- all (not . thetaProperSubset (theta x)) $ map theta xs
- where theta = (\(_,x,_,_) -> x) . instanceHead . fst
-
- matchesContext (match_inst, _) =
- all matchesPred theta
- where (_, theta, _, _) = instanceHead match_inst
- (Instance { is_tvs = tpl_tvs, is_tys = tpl_tys }) = match_inst
- (Just subst) = tcMatchTys tpl_tvs tpl_tys tys
-
- matchesPred pred@(ClassP _ _) =
- case lookupInstEnv (pkg_ie, home_ie) predC predTys of
- ([_],_) -> True
- (_,_) -> False
- where (ClassP predC predTys) = substPred subst pred
- matchesPred _ = False
-
--------------
lookup env = case lookupUFM env cls of
Nothing -> ([],[]) -- No instances for this class
}
[Partial Cleanup
matt@softmechanics.net**20100316180520
Ignore-this: 842291f863dbd182678882279c91abd6
] {
hunk ./compiler/typecheck/Inst.lhs 884
}}}}
---------------
+applyContextConstraints :: Inst ->
+ (Inst -> TcM Bool) ->
+ (InstEnv, InstEnv) ->
+ [Type] ->
+ ([(Instance,[Either TyVar Type])], [Instance]) ->
+ IOEnv (Env TcGblEnv TcLclEnv) ([(Instance,[Either TyVar Type])], [Instance])
applyContextConstraints _ _ _ _ x@([],_) = return x
applyContextConstraints _ _ _ _ x@([_],_) = return x
applyContextConstraints inst availP ies tys (ms,us) =
hunk ./compiler/typecheck/Inst.lhs 894
do ms' <- filterM matchesContext ms
- return (reduceContextMatches ms', us)
+ return (bestInstMatches ms', us)
where
hunk ./compiler/typecheck/Inst.lhs 896