summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Deriv/Utils.hs
blob: d25db38be03b505a0f27ad4b686b43418b28f498 (plain)
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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}

-- | Error-checking and other utilities for @deriving@ clauses or declarations.
module GHC.Tc.Deriv.Utils (
        DerivM, DerivEnv(..),
        DerivSpec(..), pprDerivSpec, setDerivSpecTheta,
        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
        DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),
        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
        checkOriginativeSideConditions, hasStockDeriving,
        std_class_via_coercible, non_coercible_class,
        newDerivClsInst, extendLocalInstEnv
    ) where

import GHC.Prelude

import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FamInstEnv
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Types.Fixity.Env (lookupFixity)
import GHC.Hs
import GHC.Tc.Utils.Instantiate
import GHC.Core.InstEnv
import GHC.Iface.Load   (loadInterfaceForName)
import GHC.Unit.Module (getModule)
import GHC.Unit.Module.ModIface (mi_fix)
import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Tc.Deriv.Generate
import GHC.Tc.Deriv.Functor
import GHC.Tc.Deriv.Generics
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names.TH (liftClassKey)
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Utils.Misc
import GHC.Types.Var.Set

import Control.Monad.Trans.Reader
import Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.List.SetOps (assocMaybe)

-- | To avoid having to manually plumb everything in 'DerivEnv' throughout
-- various functions in "GHC.Tc.Deriv" and "GHC.Tc.Deriv.Infer", we use 'DerivM', which
-- is a simple reader around 'TcRn'.
type DerivM = ReaderT DerivEnv TcRn

-- | Is GHC processing a standalone deriving declaration?
isStandaloneDeriv :: DerivM Bool
isStandaloneDeriv = asks (go . denv_ctxt)
  where
    go :: DerivContext -> Bool
    go (InferContext wildcard) = isJust wildcard
    go (SupplyContext {})      = True

-- | Is GHC processing a standalone deriving declaration with an
-- extra-constraints wildcard as the context?
-- (e.g., @deriving instance _ => Eq (Foo a)@)
isStandaloneWildcardDeriv :: DerivM Bool
isStandaloneWildcardDeriv = asks (go . denv_ctxt)
  where
    go :: DerivContext -> Bool
    go (InferContext wildcard) = isJust wildcard
    go (SupplyContext {})      = False

-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
mkDerivOrigin :: Bool -> CtOrigin
mkDerivOrigin standalone_wildcard
  | standalone_wildcard = StandAloneDerivOrigin
  | otherwise           = DerivClauseOrigin

-- | Contains all of the information known about a derived instance when
-- determining what its @EarlyDerivSpec@ should be.
-- See @Note [DerivEnv and DerivSpecMechanism]@.
data DerivEnv = DerivEnv
  { denv_overlap_mode :: Maybe OverlapMode
    -- ^ Is this an overlapping instance?
  , denv_tvs          :: [TyVar]
    -- ^ Universally quantified type variables in the instance
  , denv_cls          :: Class
    -- ^ Class for which we need to derive an instance
  , denv_inst_tys     :: [Type]
    -- ^ All arguments to 'denv_cls' in the derived instance.
  , denv_ctxt         :: DerivContext
    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
    --   context of the instance).
    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
    --   uses a wildcard constraint.
    --   See @Note [Inferring the instance context]@.
  , denv_strat        :: Maybe (DerivStrategy GhcTc)
    -- ^ 'Just' if user requests a particular deriving strategy.
    --   Otherwise, 'Nothing'.
  }

instance Outputable DerivEnv where
  ppr (DerivEnv { denv_overlap_mode = overlap_mode
                , denv_tvs          = tvs
                , denv_cls          = cls
                , denv_inst_tys     = inst_tys
                , denv_ctxt         = ctxt
                , denv_strat        = mb_strat })
    = hang (text "DerivEnv")
         2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
                 , text "denv_tvs"          <+> ppr tvs
                 , text "denv_cls"          <+> ppr cls
                 , text "denv_inst_tys"     <+> ppr inst_tys
                 , text "denv_ctxt"         <+> ppr ctxt
                 , text "denv_strat"        <+> ppr mb_strat ])

data DerivSpec theta = DS { ds_loc                 :: SrcSpan
                          , ds_name                :: Name         -- DFun name
                          , ds_tvs                 :: [TyVar]
                          , ds_theta               :: theta
                          , ds_cls                 :: Class
                          , ds_tys                 :: [Type]
                          , ds_overlap             :: Maybe OverlapMode
                          , ds_standalone_wildcard :: Maybe SrcSpan
                              -- See Note [Inferring the instance context]
                              -- in GHC.Tc.Deriv.Infer
                          , ds_mechanism           :: DerivSpecMechanism }
        -- This spec implies a dfun declaration of the form
        --       df :: forall tvs. theta => C tys
        -- The Name is the name for the DFun we'll build
        -- The tyvars bind all the variables in the theta

        -- the theta is either the given and final theta, in standalone deriving,
        -- or the not-yet-simplified list of constraints together with their origin

        -- ds_mechanism specifies the means by which GHC derives the instance.
        -- See Note [Deriving strategies] in GHC.Tc.Deriv

{-
Example:

     newtype instance T [a] = MkT (Tree a) deriving( C s )
==>
     axiom T [a] = :RTList a
     axiom :RTList a = Tree a

     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
        , ds_mechanism = DerivSpecNewtype (Tree a) }
-}

pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
                   ds_tys = tys, ds_theta = rhs,
                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })
  = hang (text "DerivSpec")
       2 (vcat [ text "ds_loc                  =" <+> ppr l
               , text "ds_name                 =" <+> ppr n
               , text "ds_tvs                  =" <+> ppr tvs
               , text "ds_cls                  =" <+> ppr c
               , text "ds_tys                  =" <+> ppr tys
               , text "ds_theta                =" <+> ppr rhs
               , text "ds_standalone_wildcard  =" <+> ppr wildcard
               , text "ds_mechanism            =" <+> ppr mech ])

instance Outputable theta => Outputable (DerivSpec theta) where
  ppr = pprDerivSpec

-- | Set the 'ds_theta' in a 'DerivSpec'.
setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta theta ds = ds{ds_theta = theta}

-- | What action to take in order to derive a class instance.
-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as
-- @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
data DerivSpecMechanism
    -- | \"Standard\" classes
  = DerivSpecStock
    { dsm_stock_dit    :: DerivInstTys
      -- ^ Information about the arguments to the class in the derived
      -- instance, including what type constructor the last argument is
      -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
    , dsm_stock_gen_fns :: StockGenFns
      -- ^ How to generate the instance bindings and associated type family
      -- instances.
    }

    -- | @GeneralizedNewtypeDeriving@
  | DerivSpecNewtype
    { dsm_newtype_dit    :: DerivInstTys
      -- ^ Information about the arguments to the class in the derived
      -- instance, including what type constructor the last argument is
      -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
    , dsm_newtype_rep_ty :: Type
      -- ^ The newtype rep type.
    }

    -- | @DeriveAnyClass@
  | DerivSpecAnyClass

    -- | @DerivingVia@
  | DerivSpecVia
    { dsm_via_cls_tys :: [Type]
      -- ^ All arguments to the class besides the last one.
    , dsm_via_inst_ty :: Type
      -- ^ The last argument to the class.
    , dsm_via_ty      :: Type
      -- ^ The @via@ type
    }

-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
derivSpecMechanismToStrategy DerivSpecStock{}      = StockStrategy noExtField
derivSpecMechanismToStrategy DerivSpecNewtype{}    = NewtypeStrategy noExtField
derivSpecMechanismToStrategy DerivSpecAnyClass     = AnyclassStrategy noExtField
derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t

isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
  :: DerivSpecMechanism -> Bool
isDerivSpecStock (DerivSpecStock{}) = True
isDerivSpecStock _                  = False

isDerivSpecNewtype (DerivSpecNewtype{}) = True
isDerivSpecNewtype _                    = False

isDerivSpecAnyClass DerivSpecAnyClass = True
isDerivSpecAnyClass _                 = False

isDerivSpecVia (DerivSpecVia{}) = True
isDerivSpecVia _                = False

instance Outputable DerivSpecMechanism where
  ppr (DerivSpecStock{dsm_stock_dit = dit})
    = hang (text "DerivSpecStock")
         2 (vcat [ text "dsm_stock_dit" <+> ppr dit ])
  ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty })
    = hang (text "DerivSpecNewtype")
         2 (vcat [ text "dsm_newtype_dit"    <+> ppr dit
                 , text "dsm_newtype_rep_ty" <+> ppr rep_ty ])
  ppr DerivSpecAnyClass = text "DerivSpecAnyClass"
  ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty
                    , dsm_via_ty = via_ty })
    = hang (text "DerivSpecVia")
         2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys
                 , text "dsm_via_inst_ty" <+> ppr inst_ty
                 , text "dsm_via_ty"      <+> ppr via_ty ])

{-
Note [DerivEnv and DerivSpecMechanism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DerivEnv contains all of the bits and pieces that are common to every
deriving strategy. (See Note [Deriving strategies] in GHC.Tc.Deriv.) Some deriving
strategies impose stricter requirements on the types involved in the derived
instance than others, and these differences are factored out into the
DerivSpecMechanism type. Suppose that the derived instance looks like this:

  instance ... => C arg_1 ... arg_n

Each deriving strategy imposes restrictions on arg_1 through arg_n as follows:

* stock (DerivSpecStock):

  Stock deriving requires that:

  - n must be a positive number. This is checked by
    GHC.Tc.Deriv.expectNonNullaryClsArgs
  - arg_n must be an application of an algebraic type constructor. Here,
    "algebraic type constructor" means:

    + An ordinary data type constructor, or
    + A data family type constructor such that the arguments it is applied to
      give rise to a data family instance.

    This is checked by GHC.Tc.Deriv.expectAlgTyConApp.

  This extra structure is witnessed by the DerivInstTys data type, which stores
  arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor
  (dit_tc), and its arguments (dit_tc_args). A DerivInstTys value can be seen
  as a more structured representation of the denv_inst_tys field of DerivEnv.

  If dit_tc is an ordinary data type constructor, then
  dit_rep_tc/dit_rep_tc_args are the same as dit_tc/dit_tc_args. If dit_tc is a
  data family type constructor, then dit_rep_tc is the representation type
  constructor for the data family instance, and dit_rep_tc_args are the
  arguments to the representation type constructor in the corresponding
  instance.

* newtype (DerivSpecNewtype):

  Newtype deriving imposes the same DerivInstTys requirements as stock
  deriving. This is necessary because we need to know what the underlying type
  that the newtype wraps is, and this information can only be learned by
  knowing dit_rep_tc.

* anyclass (DerivSpecAnyclass):

  DeriveAnyClass is the most permissive deriving strategy of all, as it
  essentially imposes no requirements on the derived instance. This is because
  DeriveAnyClass simply derives an empty instance, so it does not need any
  particular knowledge about the types involved. It can do several things
  that stock/newtype deriving cannot do (#13154):

  - n can be 0. That is, one is allowed to anyclass-derive an instance with
    no arguments to the class, such as in this example:

      class C
      deriving anyclass instance C

  - One can derive an instance for a type that is not headed by a type
    constructor, such as in the following example:

      class C (n :: Nat)
      deriving instance C 0
      deriving instance C 1
      ...

  - One can derive an instance for a data family with no data family instances,
    such as in the following example:

      data family Foo a
      class C a
      deriving anyclass instance C (Foo a)

* via (DerivSpecVia):

  Like newtype deriving, DerivingVia requires that n must be a positive number.
  This is because when one derives something like this:

    deriving via Foo instance C Bar

  Then the generated code must specifically mention Bar. However, in
  contrast with newtype deriving, DerivingVia does *not* require Bar to be
  an application of an algebraic type constructor. This is because the
  generated code simply defers to invoking `coerce`, which does not need to
  know anything in particular about Bar (besides that it is representationally
  equal to Foo). This allows DerivingVia to do some things that are not
  possible with newtype deriving, such as deriving instances for data families
  without data instances (#13154):

    data family Foo a
    newtype ByBar a = ByBar a
    class Baz a where ...
    instance Baz (ByBar a) where ...
    deriving via ByBar (Foo a) instance Baz (Foo a)
-}

-- | Whether GHC is processing a @deriving@ clause or a standalone deriving
-- declaration.
data DerivContext
  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
                                 --
                                 -- * A @deriving@ clause (in which case
                                 --   @mb_wildcard@ is 'Nothing').
                                 --
                                 -- * A standalone deriving declaration with
                                 --   an extra-constraints wildcard as the
                                 --   context (in which case @mb_wildcard@ is
                                 --   @'Just' loc@, where @loc@ is the location
                                 --   of the wildcard.
                                 --
                                 -- GHC should infer the context.

  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
                                 -- deriving declaration, where @theta@ is the
                                 -- context supplied by the user.

instance Outputable DerivContext where
  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone
  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta

-- | Records whether a particular class can be derived by way of an
-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).
--
-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
data OriginativeDerivStatus
  = CanDeriveStock StockGenFns -- Stock class, can derive
  | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it
  | CanDeriveAnyClass         -- See Note [Deriving any class]
  | NonDerivableClass -- Cannot derive with either stock or anyclass

-- | Describes how to generate instance bindings ('stock_gen_binds') and
-- associated type family instances ('stock_gen_fam_insts') for a particular
-- stock-derived instance.
data StockGenFns = StockGenFns
  { stock_gen_binds ::
         SrcSpan -> DerivInstTys
      -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
    -- ^ Describes how to generate instance bindings for a stock-derived
    -- instance.
    --
    -- This function takes two arguments:
    --
    -- 1. 'SrcSpan': the source location where the instance is being derived.
    --    This will eventually be instantiated with the 'ds_loc' field of a
    --    'DerivSpec'.
    --
    -- 2. 'DerivInstTys': information about the argument types to which a
    --    class is applied in a derived instance. This will eventually be
    --    instantiated with the 'dsm_stock_dit' field of a
    --    'DerivSpecMechanism'.
    --
    -- This function returns four things:
    --
    -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings
    --    (e.g., @compare (T x) (T y) = compare x y@)
    --
    -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas.
    --    Most likely @INLINE@ pragmas for class methods.
    --
    -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the
    --    derived instance. As examples, derived 'Eq' and 'Ord' instances
    --    sometimes require top-level @con2tag@ functions.
    --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".
    --
    -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be
    --    suppressed. This is used to suppress unused warnings for record
    --    selectors when deriving 'Read', 'Show', or 'Generic'.
    --    See @Note [Deriving and unused record selectors]@.
  , stock_gen_fam_insts ::
         SrcSpan -> DerivInstTys
      -> TcM [FamInst]
    -- ^ Describes how to generate associated type family instances for a
    -- stock-derived instance. This function takes the same arguments as the
    -- 'stock_gen_binds' function but returns a list of 'FamInst's instead.
    -- Generating type family instances is done separately from
    -- 'stock_gen_binds' since the type family instances must be generated
    -- before the instance bindings can be typechecked. See
    -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv".
  }

-- A stock class is one either defined in the Haskell report or for which GHC
-- otherwise knows how to generate code for (possibly requiring the use of a
-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)

-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
-- and whether or the constraint deals in types or kinds.
data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind

-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to
-- simplify when inferring a derived instance's context. These are used in all
-- deriving strategies, but in the particular case of @DeriveAnyClass@, we
-- need extra information. In particular, we need:
--
-- * 'to_anyclass_skols', the list of type variables bound by a class method's
--   regular type signature, which should be rigid.
--
-- * 'to_anyclass_metas', the list of type variables bound by a class method's
--   default type signature. These can be unified as necessary.
--
-- * 'to_anyclass_givens', the list of constraints from a class method's
--   regular type signature, which can be used to help solve constraints
--   in the 'to_wanted_origins'.
--
-- (Note that 'to_wanted_origins' will likely contain type variables from the
-- derived type class or data type, neither of which will appear in
-- 'to_anyclass_skols' or 'to_anyclass_metas'.)
--
-- For all other deriving strategies, it is always the case that
-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are
-- empty.
--
-- Here is an example to illustrate this:
--
-- @
-- class Foo a where
--   bar :: forall b. Ix b => a -> b -> String
--   default bar :: forall y. (Show a, Ix y) => a -> y -> String
--   bar x y = show x ++ show (range (y, y))
--
--   baz :: Eq a => a -> a -> Bool
--   default baz :: Ord a => a -> a -> Bool
--   baz x y = compare x y == EQ
--
-- data Quux q = Quux deriving anyclass Foo
-- @
--
-- Then it would generate two 'ThetaOrigin's, one for each method:
--
-- @
-- [ ThetaOrigin { to_anyclass_skols  = [b]
--               , to_anyclass_metas  = [y]
--               , to_anyclass_givens = [Ix b]
--               , to_wanted_origins  = [ Show (Quux q), Ix y
--                                      , (Quux q -> b -> String) ~
--                                        (Quux q -> y -> String)
--                                      ] }
-- , ThetaOrigin { to_anyclass_skols  = []
--               , to_anyclass_metas  = []
--               , to_anyclass_givens = [Eq (Quux q)]
--               , to_wanted_origins  = [ Ord (Quux q)
--                                      , (Quux q -> Quux q -> Bool) ~
--                                        (Quux q -> Quux q -> Bool)
--                                      ] }
-- ]
-- @
--
-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)
--
-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
-- in "GHC.Tc.Deriv.Infer" for an explanation of how 'to_wanted_origins' are
-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',
-- 'to_anyclass_metas', and 'to_anyclass_givens' are used.
data ThetaOrigin
  = ThetaOrigin { to_anyclass_skols  :: [TyVar]
                , to_anyclass_metas  :: [TyVar]
                , to_anyclass_givens :: ThetaType
                , to_wanted_origins  :: [PredOrigin] }

instance Outputable PredOrigin where
  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging

instance Outputable ThetaOrigin where
  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols
                   , to_anyclass_metas  = ac_metas
                   , to_anyclass_givens = ac_givens
                   , to_wanted_origins  = wanted_origins })
    = hang (text "ThetaOrigin")
         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols
                 , text "to_anyclass_metas  =" <+> ppr ac_metas
                 , text "to_anyclass_givens =" <+> ppr ac_givens
                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])

mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k

mkThetaOrigin :: CtOrigin -> TypeOrKind
              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType
              -> ThetaOrigin
mkThetaOrigin origin t_or_k skols metas givens wanteds
  = ThetaOrigin { to_anyclass_skols  = skols
                , to_anyclass_metas  = metas
                , to_anyclass_givens = givens
                , to_wanted_origins  = map (mkPredOrigin origin t_or_k) wanteds }

-- A common case where the ThetaOrigin only contains wanted constraints, with
-- no givens or locally scoped type variables.
mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
mkThetaOriginFromPreds origins
  = ThetaOrigin { to_anyclass_skols = [], to_anyclass_metas = []
                , to_anyclass_givens = [], to_wanted_origins = origins }

substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
substPredOrigin subst (PredOrigin pred origin t_or_k)
  = PredOrigin (substTy subst pred) origin t_or_k

{-
************************************************************************
*                                                                      *
                Class deriving diagnostics
*                                                                      *
************************************************************************

Only certain blessed classes can be used in a deriving clause (without the
assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
are listed below in the definition of hasStockDeriving. The stockSideConditions
function determines the criteria that needs to be met in order for a particular
stock class to be able to be derived successfully.

A class might be able to be used in a deriving clause if -XDeriveAnyClass
is willing to support it.
-}

hasStockDeriving
  :: Class -> Maybe StockGenFns
hasStockDeriving clas
  = assocMaybe gen_list (getUnique clas)
  where
    gen_list :: [(Unique, StockGenFns)]
    gen_list =
      [ (eqClassKey,          mk (simple_bindsM gen_Eq_binds) no_fam_insts)
      , (ordClassKey,         mk (simple_bindsM gen_Ord_binds) no_fam_insts)
      , (enumClassKey,        mk (simple_bindsM gen_Enum_binds) no_fam_insts)
      , (boundedClassKey,     mk (simple_binds gen_Bounded_binds) no_fam_insts)
      , (ixClassKey,          mk (simple_bindsM gen_Ix_binds) no_fam_insts)
      , (showClassKey,        mk (read_or_show_binds gen_Show_binds) no_fam_insts)
      , (readClassKey,        mk (read_or_show_binds gen_Read_binds) no_fam_insts)
      , (dataClassKey,        mk (simple_bindsM gen_Data_binds) no_fam_insts)
      , (functorClassKey,     mk (simple_binds gen_Functor_binds) no_fam_insts)
      , (foldableClassKey,    mk (simple_binds gen_Foldable_binds) no_fam_insts)
      , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts)
      , (liftClassKey,        mk (simple_binds gen_Lift_binds) no_fam_insts)
      , (genClassKey,         mk (generic_binds Gen0) (generic_fam_inst Gen0))
      , (gen1ClassKey,        mk (generic_binds Gen1) (generic_fam_inst Gen1))
      ]

    mk gen_binds_fn gen_fam_insts_fn = StockGenFns
      { stock_gen_binds     = gen_binds_fn
      , stock_gen_fam_insts = gen_fam_insts_fn
      }

    simple_binds gen_fn loc dit
      = let (binds, aux_specs) = gen_fn loc dit
        in return (binds, [], aux_specs, [])

    -- Like `simple`, but monadic. The only monadic thing that these functions
    -- do is allocate new Uniques, which are used for generating the names of
    -- auxiliary bindings.
    -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
    simple_bindsM gen_fn loc dit
      = do { (binds, aux_specs) <- gen_fn loc dit
           ; return (binds, [], aux_specs, []) }

    read_or_show_binds gen_fn loc dit
      = do { let tc = dit_rep_tc dit
           ; fix_env <- getDataConFixityFun tc
           ; let (binds, aux_specs) = gen_fn fix_env loc dit
                 field_names        = all_field_names tc
           ; return (binds, [], aux_specs, field_names) }

    generic_binds gk loc dit
      = do { let tc = dit_rep_tc dit
           ; (binds, sigs) <- gen_Generic_binds gk loc dit
           ; let field_names = all_field_names tc
           ; return (binds, sigs, emptyBag, field_names) }

    generic_fam_inst gk loc dit
      = do { let tc = dit_rep_tc dit
           ; fix_env <- getDataConFixityFun tc
           ; faminst <- gen_Generic_fam_inst gk fix_env loc dit
           ; return [faminst] }

    no_fam_insts _ _ = pure []

    -- See Note [Deriving and unused record selectors]
    all_field_names = map flSelector . concatMap dataConFieldLabels
                                     . tyConDataCons

{-
Note [Deriving and unused record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see #13919):

  module Main (main) where

  data Foo = MkFoo {bar :: String} deriving Show

  main :: IO ()
  main = print (Foo "hello")

Strictly speaking, the record selector `bar` is unused in this module, since
neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
However, the behavior of `main` is affected by the presence of `bar`, since
it will print different output depending on whether `MkFoo` is defined using
record selectors or not. Therefore, we do not to issue a
"Defined but not used: ‘bar’" warning for this module, since removing `bar`
changes the program's behavior. This is the reason behind the [Name] part of
the return type of `hasStockDeriving`—it tracks all of the record selector
`Name`s for which -Wunused-binds should be suppressed.

Currently, the only three stock derived classes that require this are Read,
Show, and Generic, as their derived code all depend on the record selectors
of the derived data type's constructors.

See also Note [Unused constructors and deriving clauses] in GHC.Tc.Deriv for
another example of a similar trick.
-}

getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
-- If the TyCon is locally defined, we want the local fixity env;
-- but if it is imported (which happens for standalone deriving)
-- we need to get the fixity env from the interface file
-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994
getDataConFixityFun tc
  = do { this_mod <- getModule
       ; if nameIsLocalOrFrom this_mod name
         then do { fix_env <- getFixityEnv
                 ; return (lookupFixity fix_env) }
         else do { iface <- loadInterfaceForName doc name
                            -- Should already be loaded!
                 ; return (mi_fix iface . nameOccName) } }
  where
    name = tyConName tc
    doc = text "Data con fixities for" <+> ppr name

------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for the originative
-- deriving strategies (stock and anyclass).
-- See Note [Deriving strategies] in GHC.Tc.Deriv for an explanation of what
-- "originative" means.
--
-- This is *apart* from the coerce-based strategies, newtype and via.
--
-- Here we get the representation tycon in case of family instances as it has
-- the data constructors - but we need to be careful to fall back to the
-- family tycon (with indexes) in error messages.

checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions dit@(DerivInstTys{dit_cls_tys = cls_tys}) =
  do DerivEnv { denv_cls  = cls
              , denv_ctxt = deriv_ctxt } <- ask
     dflags <- getDynFlags

     if    -- First, check if stock deriving is possible...
        |  Just cond <- stockSideConditions deriv_ctxt cls
        -> case cond dflags dit of
             NotValid err -> pure $ StockClassError err  -- Class-specific error
             IsValid  |  null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
                         -- All stock derivable classes are unary in the sense that
                         -- there should be not types in cls_tys (i.e., no type args
                         -- other than last). Note that cls_types can contain
                         -- invisible types as well (e.g., for Generic1, which is
                         -- poly-kinded), so make sure those are not counted.
                      ,  Just gen_fn <- hasStockDeriving cls
                      -> pure $ CanDeriveStock gen_fn
                      |  otherwise
                      -> pure $ StockClassError $ classArgsErr cls cls_tys
                        -- e.g. deriving( Eq s )

           -- ...if not, try falling back on DeriveAnyClass.
        |  xopt LangExt.DeriveAnyClass dflags
        -> pure CanDeriveAnyClass   -- DeriveAnyClass should work

        |  otherwise
        -> pure NonDerivableClass -- Neither anyclass nor stock work


classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason
classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys)

-- Side conditions (whether the datatype must have at least one constructor,
-- required language extensions, etc.) for using GHC's stock deriving
-- mechanism on certain classes (as opposed to classes that require
-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
-- class for which stock deriving isn't possible.
stockSideConditions :: DerivContext -> Class -> Maybe Condition
stockSideConditions deriv_ctxt cls
  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
                                           cond_vanilla `andCond`
                                           cond_args cls)
  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
                                           cond_vanilla `andCond`
                                           cond_functorOK True False)
  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`
                                           cond_vanilla `andCond`
                                           cond_functorOK False True)
                                           -- Functor/Fold/Trav works ok
                                           -- for rank-n types
  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
                                           cond_vanilla `andCond`
                                           cond_functorOK False False)
  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`
                                           cond_vanilla `andCond`
                                           cond_RepresentableOk)
  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`
                                           cond_vanilla `andCond`
                                           cond_Representable1Ok)
  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
                                           cond_vanilla `andCond`
                                           cond_args cls)
  | otherwise                      = Nothing
  where
    cls_key = getUnique cls
    cond_std     = cond_stdOK deriv_ctxt False
      -- Vanilla data constructors, at least one, and monotype arguments
    cond_vanilla = cond_stdOK deriv_ctxt True
      -- Vanilla data constructors but allow no data cons or polytype arguments

type Condition
   = DynFlags

  -> DerivInstTys -- ^ Information about the type arguments to the class.

  -> Validity' DeriveInstanceErrReason
     -- ^ 'IsValid' if deriving an instance for this type is
     -- possible. Otherwise, it's @'NotValid' err@, where @err@
     -- explains what went wrong.

andCond :: Condition -> Condition -> Condition
andCond c1 c2 dflags dit
  = c1 dflags dit `andValid` c2 dflags dit

-- | Some common validity checks shared among stock derivable classes. One
-- check that absolutely must hold is that if an instance @C (T a)@ is being
-- derived, then @T@ must be a tycon for a data type or a newtype. The
-- remaining checks are only performed if using a @deriving@ clause (i.e.,
-- they're ignored if using @StandaloneDeriving@):
--
-- 1. The data type must have at least one constructor (this check is ignored
--    if using @EmptyDataDeriving@).
--
-- 2. The data type cannot have any GADT constructors.
--
-- 3. The data type cannot have any constructors with existentially quantified
--    type variables.
--
-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
--
-- 5. The data type cannot have fields with higher-rank types.
cond_stdOK
  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
                  -- user-supplied context, 'InferContext' if not.
                  -- If it is the former, we relax some of the validity checks
                  -- we would otherwise perform (i.e., "just go for it").

  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
                  -- types (with no data constructors) even in the absence of
                  -- the -XEmptyDataDeriving extension.

  -> Condition
cond_stdOK deriv_ctxt permissive dflags
           dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc})
  = valid_ADT `andValid` valid_misc
  where
    valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason
    valid_ADT
      | isAlgTyCon tc || isDataFamilyTyCon tc
      = IsValid
      | otherwise
        -- Complain about functions, primitive types, and other tycons that
        -- stock deriving can't handle.
      = NotValid DerivErrLastArgMustBeApp

    valid_misc
      = case deriv_ctxt of
         SupplyContext _ -> IsValid
                -- Don't check these conservative conditions for
                -- standalone deriving; just generate the code
                -- and let the typechecker handle the result
         InferContext wildcard
           | null data_cons -- 1.
           , not permissive
           -> checkFlag LangExt.EmptyDataDeriving dflags dit `orValid`
              NotValid (no_cons_why rep_tc)
           | not (null con_whys)
           -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys
           | otherwise
           -> IsValid

    has_wildcard wildcard
      = case wildcard of
          Just _  -> YesHasWildcard
          Nothing -> NoHasWildcard
    data_cons  = tyConDataCons rep_tc
    con_whys   = getInvalids (map check_con data_cons)

    check_con :: DataCon -> Validity' DeriveInstanceBadConstructor
    check_con con
      | not (null eq_spec) -- 2.
      = bad DerivErrBadConIsGADT
      | not (null ex_tvs) -- 3.
      = bad DerivErrBadConHasExistentials
      | not (null theta) -- 4.
      = bad DerivErrBadConHasConstraints
      | not (permissive || all isTauTy (derivDataConInstArgTys con dit)) -- 5.
      = bad DerivErrBadConHasHigherRankType
      | otherwise
      = IsValid
      where
        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
        bad mkErr = NotValid $ mkErr con

no_cons_why :: TyCon -> DeriveInstanceErrReason
no_cons_why = DerivErrNoConstructors

cond_RepresentableOk :: Condition
cond_RepresentableOk _ dit =
  case canDoGenerics dit of
    IsValid -> IsValid
    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs

cond_Representable1Ok :: Condition
cond_Representable1Ok _ dit =
  case canDoGenerics1 dit of
    IsValid -> IsValid
    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs

cond_enumOrProduct :: Class -> Condition
cond_enumOrProduct cls = cond_isEnumeration `orCond`
                         (cond_isProduct `andCond` cond_args cls)
  where
    orCond :: Condition -> Condition -> Condition
    orCond c1 c2 dflags dit
      = case (c1 dflags dit, c2 dflags dit) of
         (IsValid,    _)          -> IsValid    -- c1 succeeds
         (_,          IsValid)    -> IsValid    -- c21 succeeds
         (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y
                                                -- Both fail


cond_args :: Class -> Condition
-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
-- by generating specialised code.  For others (eg 'Data') we don't.
-- For even others (eg 'Lift'), unlifted types aren't even a special
-- consideration!
cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc})
  = case bad_args of
      []     -> IsValid
      (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty
  where
    bad_args = [ arg_ty | con <- tyConDataCons rep_tc
                        , arg_ty <- derivDataConInstArgTys con dit
                        , mightBeUnliftedType arg_ty
                        , not (ok_ty arg_ty) ]

    cls_key = classKey cls
    ok_ty arg_ty
     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
     | cls_key == showClassKey = check_in arg_ty boxConTbl
     | cls_key == liftClassKey = True     -- Lift is representation-polymorphic
     | otherwise               = False    -- Read, Ix etc

    check_in :: Type -> [(Type,a)] -> Bool
    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl


cond_isEnumeration :: Condition
cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc})
  | isEnumerationTyCon rep_tc = IsValid
  | otherwise                 = NotValid $ DerivErrMustBeEnumType rep_tc

cond_isProduct :: Condition
cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc})
  | Just _ <- tyConSingleDataCon_maybe rep_tc
  = IsValid
  | otherwise
  = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc

cond_functorOK :: Bool -> Bool -> Condition
-- OK for Functor/Foldable/Traversable class
-- Currently: (a) at least one argument
--            (b) don't use argument contravariantly
--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
--            (d) optionally: don't use function types
--            (e) no "stupid context" on data type
cond_functorOK allowFunctions allowExQuantifiedLastTyVar _
               dit@(DerivInstTys{dit_rep_tc = rep_tc})
  | null tc_tvs
  = NotValid $ DerivErrMustHaveSomeParameters rep_tc

    -- We can't handle stupid contexts that mention the last type argument,
    -- so error out if we encounter one.
    -- See Note [The stupid context] in GHC.Core.DataCon.
  | not (null bad_stupid_theta)
  = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta

  | otherwise
  = allValid (map check_con data_cons)
  where
    tc_tvs            = tyConTyVars rep_tc
    last_tv           = last tc_tvs
    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
    is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred
      -- See Note [Check that the type variable is truly universal]

    data_cons = tyConDataCons rep_tc
    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con dit)

    check_universal :: DataCon -> Validity' DeriveInstanceErrReason
    check_universal con
      | allowExQuantifiedLastTyVar
      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
                -- in GHC.Tc.Deriv.Functor
      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
      , tv `elem` dataConUnivTyVars con
      , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))
      = IsValid   -- See Note [Check that the type variable is truly universal]
      | otherwise
      = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con]

    ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
                      , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con]
                      , ft_fun = \x y -> if allowFunctions then x `andValid` y
                                                           else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con]
                      , ft_tup = \_ xs  -> allValid xs
                      , ft_ty_app = \_ _ x -> x
                      , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con]
                      , ft_forall = \_ x   -> x }


checkFlag :: LangExt.Extension -> Condition
checkFlag flag dflags _
  | xopt flag dflags = IsValid
  | otherwise        = NotValid why
  where
    why = DerivErrLangExtRequired the_flag
    the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of
                 [s]   -> s
                 other -> pprPanic "checkFlag" (ppr other)

std_class_via_coercible :: Class -> Bool
-- These standard classes can be derived for a newtype
-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
-- because giving so gives the same results as generating the boilerplate
std_class_via_coercible clas
  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
        -- Not Read/Show because they respect the type
        -- Not Enum, because newtypes are never in Enum


non_coercible_class :: Class -> Bool
-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
-- by Coercible, even with -XGeneralizedNewtypeDeriving
-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
-- instance behave differently if there's a non-lawful Applicative out there.
-- Besides, with roles, Coercible-deriving Traversable is ill-roled.
non_coercible_class cls
  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
                         , genClassKey, gen1ClassKey, typeableClassKey
                         , traversableClassKey, liftClassKey ])

------------------------------------------------------------------

newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst
newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode
                    , ds_tvs = tvs, ds_theta = theta
                    , ds_cls = clas, ds_tys = tys })
  = newClsInst overlap_mode dfun_name tvs theta clas tys

extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances; don't bother to check
-- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance
extendLocalInstEnv dfuns thing_inside
 = do { env <- getGblEnv
      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
             env'      = env { tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }

{-
Note [Deriving any class]
~~~~~~~~~~~~~~~~~~~~~~~~~
Classic uses of a deriving clause, or a standalone-deriving declaration, are
for:
  * a stock class like Eq or Show, for which GHC knows how to generate
    the instance code
  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving

The DeriveAnyClass extension adds a third way to derive instances, based on
empty instance declarations.

The canonical use case is in combination with GHC.Generics and default method
signatures. These allow us to have instance declarations being empty, but still
useful, e.g.

  data T a = ...blah..blah... deriving( Generic )
  instance C a => C (T a)  -- No 'where' clause

where C is some "random" user-defined class.

This boilerplate code can be replaced by the more compact

  data T a = ...blah..blah... deriving( Generic, C )

if DeriveAnyClass is enabled.

This is not restricted to Generics; any class can be derived, simply giving
rise to an empty instance.

See Note [Gathering and simplifying constraints for DeriveAnyClass] in
GHC.Tc.Deriv.Infer for an explanation hof how the instance context is inferred for
DeriveAnyClass.

Note [Check that the type variable is truly universal]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For Functor and Traversable instances, we must check that the *last argument*
of the type constructor is used truly universally quantified.  Example

   data T a b where
     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
     T5 :: b -> T b b           -- No!  'b' is constrained
     T6 :: T a (b,b)            -- No!  'b' is constrained

Notice that only the first of these constructors is vanilla H-98. We only
need to take care about the last argument (b in this case).  See #8678.
Eg. for T1-T3 we can write

     fmap f (T1 a b) = T1 a (f b)
     fmap f (T2 b c) = T2 (f b) c
     fmap f (T3 x)   = T3 (f x)

We need not perform these checks for Foldable instances, however, since
functions in Foldable can only consume existentially quantified type variables,
rather than produce them (as is the case in Functor and Traversable functions.)
As a result, T can have a derived Foldable instance:

    foldr f z (T1 a b) = f b z
    foldr f z (T2 b c) = f b z
    foldr f z (T3 x)   = f x z
    foldr f z (T4 x)   = f x z
    foldr f z (T5 x)   = f x z
    foldr _ z T6       = z

See Note [DeriveFoldable with ExistentialQuantification] in GHC.Tc.Deriv.Functor.

For Functor and Traversable, we must take care not to let type synonyms
unfairly reject a type for not being truly universally quantified. An
example of this is:

    type C (a :: Constraint) b = a
    data T a b = C (Show a) b => MkT b

Here, the existential context (C (Show a) b) does technically mention the last
type variable b. But this is OK, because expanding the type synonym C would give
us the context (Show a), which doesn't mention b. Therefore, we must make sure
to expand type synonyms before performing this check. Not doing so led to #13813.
-}