mirrored from https://gitlab.haskell.org/ghc/ghc.git
/
TcInstDcls.lhs
1528 lines (1271 loc) · 63.2 KB
/
TcInstDcls.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 GRASP/AQUA Project, Glasgow University, 1992-1998
%
TcInstDecls: Typechecking instance declarations
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
#include "HsVersions.h"
import HsSyn
import TcBinds
import TcTyClsDecls( tcAddImplicits, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt,
tcSynFamInstDecl,
wrongKindOfFamily, tcFamTyPats, kcDataDefn, dataDeclChecks,
tcConDecls, checkValidTyCon )
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs,
findMethodBind, instantiateMethod, tcInstanceMethodBody )
import TcPat ( addInlinePrags )
import TcRnMonad
import TcValidity
import TcMType
import TcType
import Coercion( mkSingleCoAxiom, mkBranchedCoAxiom, pprCoAxBranch )
import BuildTyCl
import Inst
import InstEnv
import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
import TcHsType
import TcUnify
import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import CoreSyn ( DFunArg(..) )
import Type
import TcEvidence
import TyCon
import CoAxiom
import DataCon
import Class
import Var
import VarEnv
import VarSet ( mkVarSet, subVarSet, varSetElems )
import Pair
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var), CoreExpr )
import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
import Bag
import BasicTypes
import DynFlags
import ErrUtils
import FastString
import HscTypes ( isHsBoot )
import Id
import MkId
import Name
import NameSet
import Outputable
import SrcLoc
import Util
import Control.Monad
import Maybes ( orElse, isNothing )
\end{code}
Typechecking instance declarations is done in two passes. The first
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.
This pre-processed info includes the as-yet-unprocessed bindings
inside the instance declaration. These are type-checked in the second
pass, when the class-instance envs and GVE contain all the info from
all the instance and value decls. Indeed that's the reason we need
two passes over the instance decls.
Note [How instance declarations are translated]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is how we translation instance declarations into Core
Running example:
class C a where
op1, op2 :: Ix b => a -> b -> b
op2 = <dm-rhs>
instance C a => C [a]
{-# INLINE [2] op1 #-}
op1 = <rhs>
===>
-- Method selectors
op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
op1 = ...
op2 = ...
-- Default methods get the 'self' dictionary as argument
-- so they can call other methods at the same type
-- Default methods get the same type as their method selector
$dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
$dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
-- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
-- Note [Tricky type variable scoping]
-- A top-level definition for each instance method
-- Here op1_i, op2_i are the "instance method Ids"
-- The INLINE pragma comes from the user pragma
{-# INLINE [2] op1_i #-} -- From the instance decl bindings
op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
op1_i = /\a. \(d:C a).
let this :: C [a]
this = df_i a d
-- Note [Subtle interaction of recursion and overlap]
local_op1 :: forall b. Ix b => [a] -> b -> b
local_op1 = <rhs>
-- Source code; run the type checker on this
-- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
-- Note [Tricky type variable scoping]
in local_op1 a d
op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
-- The dictionary function itself
{-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
df_i :: forall a. C a -> C [a]
df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
-- But see Note [Default methods in instances]
-- We can't apply the type checker to the default-method call
-- Use a RULE to short-circuit applications of the class ops
{-# RULE "op1@C[a]" forall a, d:C a.
op1 [a] (df_i d) = op1_i a d #-}
Note [Instances and loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Note that df_i may be mutually recursive with both op1_i and op2_i.
It's crucial that df_i is not chosen as the loop breaker, even
though op1_i has a (user-specified) INLINE pragma.
* Instead the idea is to inline df_i into op1_i, which may then select
methods from the MkC record, and thereby break the recursion with
df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
the same type, it won't mention df_i, so there won't be recursion in
the first place.)
* If op1_i is marked INLINE by the user there's a danger that we won't
inline df_i in it, and that in turn means that (since it'll be a
loop-breaker because df_i isn't), op1_i will ironically never be
inlined. But this is OK: the recursion breaking happens by way of
a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
Note [ClassOp/DFun selection]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One thing we see a lot is stuff like
op2 (df d1 d2)
where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
'op2' and 'df' to get
case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
MkD _ op2 _ _ _ -> op2
And that will reduce to ($cop2 d1 d2) which is what we wanted.
But it's tricky to make this work in practice, because it requires us to
inline both 'op2' and 'df'. But neither is keen to inline without having
seen the other's result; and it's very easy to get code bloat (from the
big intermediate) if you inline a bit too much.
Instead we use a cunning trick.
* We arrange that 'df' and 'op2' NEVER inline.
* We arrange that 'df' is ALWAYS defined in the sylised form
df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
* We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
that lists its methods.
* We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
a suitable constructor application -- inlining df "on the fly" as it
were.
* We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
iff its argument satisfies exprIsConApp_maybe. This is done in
MkId mkDictSelId
* We make 'df' CONLIKE, so that shared uses still match; eg
let d = df d1 d2
in ...(op2 d)...(op1 d)...
Note [Single-method classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the class has just one method (or, more accurately, just one element
of {superclasses + methods}), then we use a different strategy.
class C a where op :: a -> a
instance C a => C [a] where op = <blah>
We translate the class decl into a newtype, which just gives a
top-level axiom. The "constructor" MkC expands to a cast, as does the
class-op selector.
axiom Co:C a :: C a ~ (a->a)
op :: forall a. C a -> (a -> a)
op a d = d |> (Co:C a)
MkC :: forall a. (a->a) -> C a
MkC = /\a.\op. op |> (sym Co:C a)
The clever RULE stuff doesn't work now, because ($df a d) isn't
a constructor application, so exprIsConApp_maybe won't return
Just <blah>.
Instead, we simply rely on the fact that casts are cheap:
$df :: forall a. C a => C [a]
{-# INLINE df #-} -- NB: INLINE this
$df = /\a. \d. MkC [a] ($cop_list a d)
= $cop_list |> forall a. C a -> (sym (Co:C [a]))
$cop_list :: forall a. C a => [a] -> [a]
$cop_list = <blah>
So if we see
(op ($df a d))
we'll inline 'op' and '$df', since both are simply casts, and
good things happen.
Why do we use this different strategy? Because otherwise we
end up with non-inlined dictionaries that look like
$df = $cop |> blah
which adds an extra indirection to every use, which seems stupid. See
Trac #4138 for an example (although the regression reported there
wasn't due to the indirection).
There is an awkward wrinkle though: we want to be very
careful when we have
instance C a => C [a] where
{-# INLINE op #-}
op = ...
then we'll get an INLINE pragma on $cop_list but it's important that
$cop_list only inlines when it's applied to *two* arguments (the
dictionary and the list argument). So we must not eta-expand $df
above. We ensure that this doesn't happen by putting an INLINE
pragma on the dfun itself; after all, it ends up being just a cast.
There is one more dark corner to the INLINE story, even more deeply
buried. Consider this (Trac #3772):
class DeepSeq a => C a where
gen :: Int -> a
instance C a => C [a] where
gen n = ...
class DeepSeq a where
deepSeq :: a -> b -> b
instance DeepSeq a => DeepSeq [a] where
{-# INLINE deepSeq #-}
deepSeq xs b = foldr deepSeq b xs
That gives rise to these defns:
$cdeepSeq :: DeepSeq a -> [a] -> b -> b
-- User INLINE( 3 args )!
$cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
$fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
-- DFun (with auto INLINE pragma)
$fDeepSeq[] a d = $cdeepSeq a d |> blah
$cp1 a d :: C a => DeepSep [a]
-- We don't want to eta-expand this, lest
-- $cdeepSeq gets inlined in it!
$cp1 a d = $fDeepSep[] a (scsel a d)
$fC[] :: C a => C [a]
-- Ordinary DFun
$fC[] a d = MkC ($cp1 a d) ($cgen a d)
Here $cp1 is the code that generates the superclass for C [a]. The
issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
and then $cdeepSeq will inline there, which is definitely wrong. Like
on the dfun, we solve this by adding an INLINE pragma to $cp1.
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
class C a where { op1,op2 :: a -> a }
instance C a => C [a] where
op1 x = op2 x ++ op2 x
op2 x = ...
instance C [Int] where
...
When type-checking the C [a] instance, we need a C [a] dictionary (for
the call of op2). If we look up in the instance environment, we find
an overlap. And in *general* the right thing is to complain (see Note
[Overlapping instances] in InstEnv). But in *this* case it's wrong to
complain, because we just want to delegate to the op2 of this same
instance.
Why is this justified? Because we generate a (C [a]) constraint in
a context in which 'a' cannot be instantiated to anything that matches
other overlapping instances, or else we would not be executing this
version of op1 in the first place.
It might even be a bit disguised:
nullFail :: C [a] => [a] -> [a]
nullFail x = op2 x ++ op2 x
instance C a => C [a] where
op1 x = nullFail x
Precisely this is used in package 'regex-base', module Context.hs.
See the overlapping instances for RegexContext, and the fact that they
call 'nullFail' just like the example above. The DoCon package also
does the same thing; it shows up in module Fraction.hs.
Conclusion: when typechecking the methods in a C [a] instance, we want to
treat the 'a' as an *existential* type variable, in the sense described
by Note [Binding when looking up instances]. That is why isOverlappableTyVar
responds True to an InstSkol, which is the kind of skolem we use in
tcInstDecl2.
Note [Tricky type variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In our example
class C a where
op1, op2 :: Ix b => a -> b -> b
op2 = <dm-rhs>
instance C a => C [a]
{-# INLINE [2] op1 #-}
op1 = <rhs>
note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
in scope in <rhs>. In particular, we must make sure that 'b' is in
scope when typechecking <dm-rhs>. This is achieved by subFunTys,
which brings appropriate tyvars into scope. This happens for both
<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
complained if 'b' is mentioned in <rhs>.
%************************************************************************
%* *
\subsection{Extracting instance decls}
%* *
%************************************************************************
Gather up the instance declarations from their various sources
\begin{code}
tcInstDecls1 -- Deal with both source-code and imported instance decls
:: [LTyClDecl Name] -- For deriving stuff
-> [LInstDecl Name] -- Source code instance decls
-> [LDerivDecl Name] -- Source code stand-alone deriving decls
-> TcM (TcGblEnv, -- The full inst env
[InstInfo Name], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do { -- Stop if addInstInfos etc discovers any errors
-- (they recover, so that we get more than one error each
-- round)
-- Do class and family instance declarations
; env <- getGblEnv
; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
; let (local_infos_s, fam_insts_s) = unzip stuff
fam_insts = concat fam_insts_s
local_infos' = concat local_infos_s
-- Handwritten instances of the poly-kinded Typeable class are
-- forbidden, so we handle those separately
(typeable_instances, local_infos) = splitTypeable env local_infos'
; addClsInsts local_infos $
addFamInsts fam_insts $
do { -- Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
failIfErrsM -- If the addInsts stuff gave any errors, don't
-- try the deriving stuff, because that may give
-- more errors still
; traceTc "tcDeriving" empty
; th_stage <- getStage -- See Note [Deriving inside TH brackets ]
; (gbl_env, deriv_inst_info, deriv_binds)
<- if isBrackStage th_stage
then do { gbl_env <- getGblEnv
; return (gbl_env, emptyBag, emptyValBindsOut) }
else tcDeriving tycl_decls inst_decls deriv_decls
-- Remove any handwritten instance of poly-kinded Typeable and warn
; dflags <- getDynFlags
; when (wopt Opt_WarnTypeableInstances dflags) $
mapM_ (addWarnTc . instMsg) typeable_instances
-- Check that if the module is compiled with -XSafe, there are no
-- hand written instances of old Typeable as then unsafe casts could be
-- performed. Derived instances are OK.
; when (safeLanguageOn dflags) $
mapM_ (\x -> when (typInstCheck x)
(addErrAt (getSrcSpan $ iSpec x) typInstErr))
local_infos
-- As above but for Safe Inference mode.
; when (safeInferOn dflags) $
mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos
; return ( gbl_env
, bagToList deriv_inst_info ++ local_infos
, deriv_binds)
}}
where
-- Separate the Typeable instances from the rest
splitTypeable _ [] = ([],[])
splitTypeable env (i:is) =
let (typeableInsts, otherInsts) = splitTypeable env is
in if -- We will filter out instances of Typeable
(typeableClassName == is_cls_nm (iSpec i))
-- but not those that come from Data.Typeable.Internal
&& tcg_mod env /= tYPEABLE_INTERNAL
-- nor those from an .hs-boot file (deriving can't be used there)
&& not (isHsBoot (tcg_src env))
then (i:typeableInsts, otherInsts)
else (typeableInsts, i:otherInsts)
typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
++ " Haskell! Can only derive them"
instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; ignoring "
++ "the following instance:"))
2 (pprInstance (iSpec i))
addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
addFamInsts :: [FamInst Branched] -> TcM a -> TcM a
-- Extend (a) the family instance envt
-- (b) the type envt with stuff from data type decls
addFamInsts fam_insts thing_inside
= tcExtendLocalFamInstEnv fam_insts $
tcExtendGlobalEnv things $
do { traceTc "addFamInsts" (pprFamInsts fam_insts)
; tcg_env <- tcAddImplicits things
; setGblEnv tcg_env thing_inside }
where
axioms = map famInstAxiom fam_insts
tycons = famInstsRepTyCons fam_insts
things = map ATyCon tycons ++ map ACoAxiom axioms
\end{code}
Note [Deriving inside TH brackets]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given a declaration bracket
[d| data T = A | B deriving( Show ) |]
there is really no point in generating the derived code for deriving(
Show) and then type-checking it. This will happen at the call site
anyway, and the type check should never fail! Moreover (Trac #6005)
the scoping of the generated code inside the bracket does not seem to
work out.
The easy solution is simply not to generate the derived instances at
all. (A less brutal solution would be to generate them with no
bindings.) This will become moot when we shift to the new TH plan, so
the brutal solution will do.
\begin{code}
tcLocalInstDecl :: LInstDecl Name
-> TcM ([InstInfo Name], [FamInst Branched])
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
= do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
; return ([], [fam_inst]) }
tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
= do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl)
; return ([], [toBranchedFamInst fam_inst]) }
tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
= do { (insts, fam_insts) <- tcClsInstDecl (L loc decl)
; return (insts, map toBranchedFamInst fam_insts) }
tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst Unbranched])
tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_datafam_insts = adts }))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
do { is_boot <- tcIsHsBoot
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
mb_info = Just (clas, mini_env)
-- Next, process any associated types.
; traceTc "tcLocalInstDecl" (ppr poly_ty)
; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
mapAndRecoverM (tcAssocTyDecl clas mini_env) ats
; datafam_insts <- tcExtendTyVarEnv tyvars $
mapAndRecoverM (tcDataFamInstDecl mb_info) adts
-- Check for missing associated types and build them
-- from their defaults (if available)
; let defined_ats = mkNameSet $ map (tyFamInstDeclName . unLoc) ats
defined_adts = mkNameSet $ map (unLoc . dfid_tycon . unLoc) adts
mk_deflt_at_instances :: ClassATItem -> TcM [FamInst Unbranched]
mk_deflt_at_instances (fam_tc, defs)
-- User supplied instances ==> everything is OK
| tyConName fam_tc `elemNameSet` defined_ats
|| tyConName fam_tc `elemNameSet` defined_adts
= return []
-- No defaults ==> generate a warning
| null defs
= do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
; return [] }
-- No user instance, have defaults ==> instatiate them
-- Example: class C a where { type F a b :: *; type F a b = () }
-- instance C [x]
-- Then we want to generate the decl: type F [x] b = ()
| otherwise
= forM defs $ \(CoAxBranch { cab_lhs = pat_tys, cab_rhs = rhs }) ->
do { let pat_tys' = substTys mini_subst pat_tys
rhs' = substTy mini_subst rhs
tv_set' = tyVarsOfTypes pat_tys'
tvs' = varSetElems tv_set'
; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs'
; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
newFamInst SynFamilyInst False {- group -} axiom }
; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
-- Dfun location is that of instance *header*
; overlap_flag <- getOverlapFlag
; (subst, tyvars') <- tcInstSkolTyVars tyvars
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }
; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
--------------
tcAssocTyDecl :: Class -- Class of associated type
-> VarEnv Type -- Instantiation of class TyVars
-> LTyFamInstDecl Name
-> TcM (FamInst Unbranched)
tcAssocTyDecl clas mini_env ldecl
= do { fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) ldecl
; return $ toUnbranchedFamInst fam_inst }
\end{code}
%************************************************************************
%* *
Type checking family instances
%* *
%************************************************************************
Family instances are somewhat of a hybrid. They are processed together with
class instance heads, but can contain data constructors and hence they share a
lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
\begin{code}
tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
-> Located Name -> TcM TyCon
tcFamInstDeclCombined mb_clsinfo fam_tc_lname
= do { -- Type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl fam_tc_lname
; checkTc (not is_boot) $ badBootFamInstDeclErr
-- Look up the family TyCon and check for validity including
-- check that toplevel type instances are not for associated types.
; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
; when (isNothing mb_clsinfo && -- Not in a class decl
isTyConAssoc fam_tc) -- but an associated type
(addErr $ assocInClassErr fam_tc_lname)
; return fam_tc }
tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
-> LTyFamInstDecl Name -> TcM (FamInst Branched)
-- "type instance"
tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_group = group
, tfid_eqns = eqns }))
= setSrcSpan loc $
tcAddTyFamInstCtxt decl $
do { let (eqn1:_) = eqns
fam_lname = tfie_tycon (unLoc eqn1)
; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
-- (0) Check it's an open type family
; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
; checkTc (isOpenSynFamilyTyCon fam_tc)
(notOpenFamily fam_tc)
-- (1) do the work of verifying the synonym group
; co_ax_branches <- tcSynFamInstDecl fam_tc decl
-- (2) check for validity and inaccessibility
; foldlM_ (check_valid_branch fam_tc) [] co_ax_branches
-- (3) construct coercion axiom
; rep_tc_name <- newFamInstAxiomName loc
(tyFamInstDeclName decl)
(map cab_lhs co_ax_branches)
; let axiom = mkBranchedCoAxiom rep_tc_name fam_tc co_ax_branches
; newFamInst SynFamilyInst group axiom }
where
check_valid_branch :: TyCon
-> [CoAxBranch] -- previous
-> CoAxBranch -- current
-> TcM [CoAxBranch] -- current : previous
check_valid_branch fam_tc prev_branches cur_branch
= do { -- Check the well-formedness of the instance
checkValidTyFamInst mb_clsinfo fam_tc cur_branch
-- Check whether the branch is dominated by earlier
-- ones and hence is inaccessible
; when (cur_branch `isDominatedBy` prev_branches) $
setSrcSpan (coAxBranchSpan cur_branch) $
addErrTc $ inaccessibleCoAxBranch fam_tc cur_branch
; return $ cur_branch : prev_branches }
tcDataFamInstDecl :: Maybe (Class, VarEnv Type)
-> LDataFamInstDecl Name -> TcM (FamInst Unbranched)
-- "newtype instance" and "data instance"
tcDataFamInstDecl mb_clsinfo
(L loc decl@(DataFamInstDecl
{ dfid_pats = pats
, dfid_tycon = fam_tc_name
, dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = ctxt, dd_cons = cons } }))
= setSrcSpan loc $
tcAddDataFamInstCtxt decl $
do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
-- Check that the family declaration is for the right kind
; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Kind check type patterns
; tcFamTyPats fam_tc pats (kcDataDefn defn) $
\tvs' pats' res_kind -> do
{ -- Check that left-hand side contains no type family applications
-- (vanilla synonyms are fine, though, and we checked for
-- foralls earlier)
checkValidFamPats fam_tc tvs' pats'
-- Check that type patterns match class instance head, if any
; checkConsistentFamInst mb_clsinfo fam_tc tvs' pats'
-- Result kind must be '*' (otherwise, we have too few patterns)
; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
; stupid_theta <- tcHsContext ctxt
; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
-- Construct representation tycon
; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc
; let orig_res_ty = mkTyConApp fam_tc pats'
; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
do { data_cons <- tcConDecls new_or_data rec_rep_tc
(tvs', orig_res_ty) cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
-- freshen tyvars
; let axiom = mkSingleCoAxiom axiom_name tvs' fam_tc pats'
(mkTyConApp rep_tc (mkTyVarTys tvs'))
parent = FamInstTyCon axiom fam_tc pats'
rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs
Recursive
False -- No promotable to the kind level
h98_syntax parent
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
-- dependency. (2) They are always valid loop breakers as
-- they involve a coercion.
; fam_inst <- newFamInst (DataFamilyInst rep_tc) False axiom
; return (rep_tc, fam_inst) }
-- Remember to check validity; no recursion to worry about here
; checkValidTyCon rep_tc
; return fam_inst } }
\end{code}
%************************************************************************
%* *
Type-checking instance declarations, pass 2
%* *
%************************************************************************
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
-> TcM (LHsBinds Id)
-- (a) From each class declaration,
-- generate any default-method bindings
-- (b) From each instance decl
-- generate the dfun binding
tcInstDecls2 tycl_decls inst_decls
= do { -- (a) Default methods from class decls
let class_decls = filter (isClassDecl . unLoc) tycl_decls
; dm_binds_s <- mapM tcClassDecl2 class_decls
; let dm_binds = unionManyBags dm_binds_s
-- (b) instance declarations
; let dm_ids = collectHsBindsBinders dm_binds
-- Add the default method Ids (again)
-- See Note [Default methods and instances]
; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
mapM tcInstDecl2 inst_decls
-- Done
; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
\end{code}
See Note [Default methods and instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The default method Ids are already in the type environment (see Note
[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
don't have their InlinePragmas yet. Usually that would not matter,
because the simplifier propagates information from binding site to
use. But, unusually, when compiling instance decls we *copy* the
INLINE pragma from the default method to the method for that
particular operation (see Note [INLINE and default methods] below).
So right here in tcInstDecls2 we must re-extend the type envt with
the default method Ids replete with their INLINE pragmas. Urk.
\begin{code}
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
-- Returns a binding for the dfun
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
= recoverM (return emptyLHsBinds) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
-- We instantiate the dfun_id with superSkolems.
-- See Note [Subtle interaction of recursion and overlap]
-- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
; dfun_ev_vars <- newEvVars dfun_theta
; (sc_binds, sc_ev_vars, sc_dfun_args)
<- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'
-- Deal with 'SPECIALISE instance' pragmas
-- See Note [SPECIALISE instance pragmas]
; spec_inst_info <- tcSpecInstPrags dfun_id ibinds
-- Typecheck the methods
; (meth_ids, meth_binds)
<- tcExtendTyVarEnv inst_tyvars $
-- The inst_tyvars scope over the 'where' part
-- Those tyvars are inside the dfun_id's type, which is a bit
-- bizarre, but OK so long as you realise it!
tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
inst_tys spec_inst_info
op_items ibinds
-- Create the result bindings
; self_dict <- newDict clas inst_tys
; let class_tc = classTyCon clas
[dict_constr] = tyConDataCons class_tc
dict_bind = mkVarBind self_dict (L loc con_app_args)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- it means that the special cases (e.g. dictionary with only one
-- member) are dealt with by the common MkId.mkDataConWrapId
-- code rather than needing to be repeated here.
-- con_app_tys = MkD ty1 ty2
-- con_app_scs = MkD ty1 ty2 sc1 sc2
-- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
con_app_tys = wrapId (mkWpTyApps inst_tys)
(dataConWrapId dict_constr)
con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
con_app_args = foldl mk_app con_app_scs $
map (wrapId arg_wrapper) meth_ids
mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id
mk_app fun arg = HsApp (L loc fun) (L loc arg)
inst_tv_tys = mkTyVarTys inst_tyvars
arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
dfun_id_w_fun
| isNewTyCon class_tc
= dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args
`setInlinePragma` dfunInlinePragma
dfun_args :: [DFunArg CoreExpr]
dfun_args = sc_dfun_args ++ map (DFunPolyArg . Var) meth_ids
export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun
, abe_mono = self_dict, abe_prags = noSpecPrags }
-- NB: noSpecPrags, see Note [SPECIALISE instance pragmas]
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = sc_binds
, abs_binds = unitBag dict_bind }
; return (unitBag (L loc main_bind) `unionBags`
listToBag meth_binds)
}
where
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
------------------------------
tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType
-> TcM (TcEvBinds, [EvVar], [DFunArg CoreExpr])
-- See Note [Silent superclass arguments]
tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta
= do { -- Check that all superclasses can be deduced from
-- the originally-specified dfun arguments
; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars $
emitWanteds ScOrigin sc_theta
; if null inst_tyvars && null dfun_ev_vars
then return (sc_binds, sc_evs, map (DFunPolyArg . Var) sc_evs)
else return (emptyTcEvBinds, sc_lam_args, sc_dfun_args) }
where
n_silent = dfunNSilent dfun_id
n_tv_args = length inst_tyvars
orig_ev_vars = drop n_silent dfun_ev_vars
(sc_lam_args, sc_dfun_args) = unzip (map (find n_tv_args dfun_ev_vars) sc_theta)
find _ [] pred
= pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred)
find i (ev:evs) pred
| pred `eqPred` evVarPred ev = (ev, DFunLamArg i)
| otherwise = find (i+1) evs pred
----------------------
mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcSigInfo)
mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
= do { let sel_occ = nameOccName sel_name
; meth_name <- newName (mkClassOpAuxOcc sel_occ)
; local_meth_name <- newName sel_occ
-- Base the local_meth_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
; local_meth_sig <- case lookupHsSig sig_fn sel_name of
Just hs_ty -- There is a signature in the instance declaration
-> do { sig_ty <- check_inst_sig hs_ty
; instTcTySig hs_ty sig_ty local_meth_name }
Nothing -- No type signature
-> do { loc <- getSrcSpanM
; instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) }
-- Absent a type sig, there are no new scoped type variables here
-- Only the ones from the instance decl itself, which are already
-- in scope. Example:
-- class C a where { op :: forall b. Eq b => ... }
-- instance C [c] where { op = <rhs> }
-- In <rhs>, 'c' is scope but 'b' is not!
; let meth_id = mkLocalId meth_name meth_ty
; return (meth_id, local_meth_sig) }
where
sel_name = idName sel_id
local_meth_ty = instantiateMethod clas sel_id inst_tys
meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
-- Check that any type signatures have exactly the right type
check_inst_sig hs_ty@(L loc _)
= setSrcSpan loc $
do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty
; inst_sigs <- xoptM Opt_InstanceSigs
; if inst_sigs then
unless (sig_ty `eqType` local_meth_ty)
(badInstSigErr sel_name local_meth_ty)
else
addErrTc (misplacedInstSig sel_name hs_ty)
; return sig_ty }
badInstSigErr :: Name -> Type -> TcM ()
badInstSigErr meth ty
= do { env0 <- tcInitTidyEnv
; let tidy_ty = tidyType env0 ty
-- Tidy the type using the ambient TidyEnv,
-- to avoid apparent name capture (Trac #7475)
-- class C a where { op :: a -> b }
-- instance C (a->b) where
-- op :: forall x. x
-- op = ...blah...
; addErrTc (hang (ptext (sLit "Method signature does not match class; it should be"))
2 (pprPrefixName meth <+> dcolon <+> ppr tidy_ty)) }
misplacedInstSig :: Name -> LHsType Name -> SDoc
misplacedInstSig name hs_ty
= vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
2 (hang (pprPrefixName name)
2 (dcolon <+> ppr hs_ty))
, ptext (sLit "(Use -XInstanceSigs to allow this)") ]
------------------------------
tcSpecInstPrags :: DFunId -> InstBindings Name
-> TcM ([Located TcSpecPrag], PragFun)
tcSpecInstPrags _ (NewTypeDerived {})
= return ([], \_ -> [])
tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
= do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
-- The filter removes the pragmas for methods
; return (spec_inst_prags, mkPragFun uprags binds) }
\end{code}
Note [Silent superclass arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #3731, #4809, #5751, #5913, #6117, which all
describe somewhat more complicated situations, but ones
encountered in practice.
THE PROBLEM
The problem is that it is all too easy to create a class whose
superclass is bottom when it should not be.
Consider the following (extreme) situation:
class C a => D a where ...
instance D [a] => D [a] where ...
Although this looks wrong (assume D [a] to prove D [a]), it is only a
more extreme case of what happens with recursive dictionaries, and it
can, just about, make sense because the methods do some work before
recursing.
To implement the dfun we must generate code for the superclass C [a],
which we had better not get by superclass selection from the supplied
argument:
dfun :: forall a. D [a] -> D [a]
dfun = \d::D [a] -> MkD (scsel d) ..
Otherwise if we later encounter a situation where
we have a [Wanted] dw::D [a] we might solve it thus: