TcDeriv.hs 80.1 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
6

Handles @deriving@ clauses on @data@ declarations.
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE CPP #-}
10
{-# LANGUAGE TypeFamilies #-}
11

12
module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
13

14
#include "HsVersions.h"
15

16
17
import GhcPrelude

18
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
19
import DynFlags
20

21
import TcRnMonad
22
import FamInst
Ryan Scott's avatar
Ryan Scott committed
23
24
25
import TcDerivInfer
import TcDerivUtils
import TcValidity( allDistinctTyVars )
26
import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
Simon Marlow's avatar
Simon Marlow committed
27
import TcEnv
28
import TcGenDeriv                       -- Deriv stuff
Simon Marlow's avatar
Simon Marlow committed
29
30
import InstEnv
import Inst
31
import FamInstEnv
Simon Marlow's avatar
Simon Marlow committed
32
33
import TcHsType

34
import RnNames( extendGlobalRdrEnvRn )
Simon Marlow's avatar
Simon Marlow committed
35
import RnBinds
36
import RnEnv
37
import RnUtils    ( bindLocalNamesFV )
38
import RnSource   ( addTcgDUs )
39
import Avail
Simon Marlow's avatar
Simon Marlow committed
40

41
import Unify( tcUnifyTy )
Ryan Scott's avatar
Ryan Scott committed
42
import BasicTypes ( DerivStrategy(..) )
Simon Marlow's avatar
Simon Marlow committed
43
44
45
46
47
48
49
50
51
52
53
import Class
import Type
import ErrUtils
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
54
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
55
import VarSet
56
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
57
58
import SrcLoc
import Util
59
import Outputable
60
import FastString
61
import Bag
62
import Pair
niteria's avatar
niteria committed
63
import FV (fvVarList, unionFV, mkFVs)
64
import qualified GHC.LanguageExtensions as LangExt
65
66

import Control.Monad
67
68
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
69
import Data.List
70

Austin Seipp's avatar
Austin Seipp committed
71
72
73
{-
************************************************************************
*                                                                      *
74
                Overview
Austin Seipp's avatar
Austin Seipp committed
75
76
*                                                                      *
************************************************************************
77

78
79
Overall plan
~~~~~~~~~~~~
dterei's avatar
dterei committed
80
1.  Convert the decls (i.e. data/newtype deriving clauses,
81
82
    plus standalone deriving) to [EarlyDerivSpec]

83
2.  Infer the missing contexts for the InferTheta's
84
85

3.  Add the derived bindings, generating InstInfos
Austin Seipp's avatar
Austin Seipp committed
86
-}
87

88
data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
89
90
                    | GivenTheta (DerivSpec ThetaType)
        -- InferTheta ds => the context for the instance should be inferred
91
92
93
        --      In this case ds_theta is the list of all the sets of
        --      constraints needed, such as (Eq [a], Eq a), together with a
        --      suitable CtLoc to get good error messages.
94
95
        --      The inference process is to reduce this to a
        --      simpler form (e.g. Eq a)
96
        --
97
98
        -- GivenTheta ds => the exact context for the instance is supplied
        --                  by the programmer; it is ds_theta
Ryan Scott's avatar
Ryan Scott committed
99
        -- See Note [Inferring the instance context] in TcDerivInfer
100
101
102
103
104

earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta spec) = ds_loc spec
earlyDSLoc (GivenTheta spec) = ds_loc spec

105
106
splitEarlyDerivSpec :: [EarlyDerivSpec]
                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
107
108
109
110
111
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta spec : specs) =
    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
splitEarlyDerivSpec (GivenTheta spec : specs) =
    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
112

113
instance Outputable EarlyDerivSpec where
114
115
  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
116

Ryan Scott's avatar
Ryan Scott committed
117
{-
118
119
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
120
121
Consider

122
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
123
124
125

We will need an instance decl like:

126
127
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
128
129
130

The RealFloat in the context is because the read method for Complex is bound
to construct a Complex, and doing that requires that the argument type is
dterei's avatar
dterei committed
131
in RealFloat.
132
133
134
135
136
137
138

But this ain't true for Show, Eq, Ord, etc, since they don't construct
a Complex; they only take them apart.

Our approach: identify the offending classes, and add the data type
context to the instance decl.  The "offending classes" are

139
        Read, Enum?
140

141
142
143
144
145
FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
pattern matching against a constructor from a data type with a context
gives rise to the constraints for that context -- or at least the thinned
version.  So now all classes are "offending".

146
147
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
148
149
150
151
152
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
153
Notice the free 'a' in the deriving.  We have to fill this out to
154
155
156
157
    newtype T = T Char deriving( forall a. C [a] )

And then translate it to:
    instance C [a] Char => C [a] T where ...
dterei's avatar
dterei committed
158
159


160
161
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
162
163
164
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

165
166
167
168
169
The 'tys' here come from the partial application in the deriving
clause. The last arg is the new instance type.

We must pass the superclasses; the newtype might be an instance
of them in a different way than the representation type
170
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
171
Then the Show instance is not done via Coercible; it shows
172
        Foo 3 as "Foo 3"
173
The Num instance is derived via Coercible, but the Show superclass
174
175
176
177
dictionary must the Show instance for Foo, *not* the Show dictionary
gotten from the Num dictionary. So we must build a whole new dictionary
not just use the Num one.  The instance we want is something like:
     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
178
179
        (+) = ((+)@a)
        ...etc...
180
181
182
183
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


184
185
186
187
188
189
Note [Unused constructors and deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #3221.  Consider
   data T = T1 | T2 deriving( Show )
Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
both of them.  So we gather defs/uses from deriving just like anything else.
190

191
192
-}

Ryan Scott's avatar
Ryan Scott committed
193
194
-- | Stuff needed to process a datatype's `deriving` clauses
data DerivInfo = DerivInfo { di_rep_tc  :: TyCon
195
196
                             -- ^ The data tycon for normal datatypes,
                             -- or the *representation* tycon for data families
197
                           , di_clauses :: [LHsDerivingClause GhcRn]
Ryan Scott's avatar
Ryan Scott committed
198
                           , di_ctxt    :: SDoc -- ^ error context
199
200
201
                           }

-- | Extract `deriving` clauses of proper data type (skips data families)
202
mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
203
mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
204
205
206
207
  where

    mk_deriv decl@(DataDecl { tcdLName = L _ data_name
                            , tcdDataDefn =
Ryan Scott's avatar
Ryan Scott committed
208
                                HsDataDefn { dd_derivs = L _ clauses } })
209
      = do { tycon <- tcLookupTyCon data_name
Ryan Scott's avatar
Ryan Scott committed
210
           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses
211
212
213
214
215
                               , di_ctxt = tcMkDeclCtxt decl }] }
    mk_deriv _ = return []

{-

Austin Seipp's avatar
Austin Seipp committed
216
217
************************************************************************
*                                                                      *
218
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
219
220
221
*                                                                      *
************************************************************************
-}
222

223
tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
224
225
            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
226
tcDeriving deriv_infos deriv_decls
227
228
  = recoverM (do { g <- getGblEnv
                 ; return (g, emptyBag, emptyValBindsOut)}) $
229
230
    do  {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
231
          is_boot <- tcIsHsBootOrSig
232
        ; traceTc "tcDeriving" (ppr is_boot)
233

234
        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
235
        ; traceTc "tcDeriving 1" (ppr early_specs)
236

237
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
238
        ; insts1 <- mapM genInst given_specs
239
        ; insts2 <- mapM genInst infer_specs
240

Sylvain Henry's avatar
Sylvain Henry committed
241
242
        ; dflags <- getDynFlags

243
        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
244
        ; loc <- getSrcSpanM
Sylvain Henry's avatar
Sylvain Henry committed
245
246
        ; let (binds, famInsts) = genAuxBinds dflags loc
                                    (unionManyBags deriv_stuff)
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
        ; let mk_inst_infos1 = map fstOf3 insts1
        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs

          -- We must put all the derived type family instances (from both
          -- infer_specs and given_specs) in the local instance environment
          -- before proceeding, or else simplifyInstanceContexts might
          -- get stuck if it has to reason about any of those family instances.
          -- See Note [Staging of tcDeriving]
        ; tcExtendLocalFamInstEnv (bagToList famInsts) $
          -- NB: only call tcExtendLocalFamInstEnv once, as it performs
          -- validity checking for all of the family instances you give it.
          -- If the family instances have errors, calling it twice will result
          -- in duplicate error messages!

     do {
        -- the stand-alone derived instances (@inst_infos1@) are used when
        -- inferring the contexts for "deriving" clauses' instances
        -- (@infer_specs@)
        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $
                         simplifyInstanceContexts infer_specs

        ; let mk_inst_infos2 = map fstOf3 insts2
        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs
        ; let inst_infos = inst_infos1 ++ inst_infos2

dreixel's avatar
dreixel committed
273
        ; (inst_info, rn_binds, rn_dus) <-
274
            renameDeriv is_boot inst_infos binds
275

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
276
        ; unless (isEmptyBag inst_info) $
277
             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
278
                        (ddump_deriving inst_info rn_binds famInsts))
dreixel's avatar
dreixel committed
279

280
281
        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
                                          getGblEnv
282
        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
283
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
284
  where
285
    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
Simon Peyton Jones's avatar
Simon Peyton Jones committed
286
                   -> Bag FamInst             -- ^ Rep type family instances
287
                   -> SDoc
288
    ddump_deriving inst_infos extra_binds repFamInsts
289
      =    hang (text "Derived class instances:")
290
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
291
                 $$ ppr extra_binds)
292
        $$ hangP "Derived type family instances:"
293
             (vcat (map pprRepTy (bagToList repFamInsts)))
294

295
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
296

297
298
    -- Apply the suspended computations given by genInst calls.
    -- See Note [Staging of tcDeriving]
299
300
    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
301
302
    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))

303
-- Prints the representable type family instance
304
305
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
306
  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
307
308
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
309

310
renameDeriv :: Bool
311
312
313
            -> [InstInfo GhcPs]
            -> Bag (LHsBind GhcPs, LSig GhcPs)
            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
dreixel's avatar
dreixel committed
314
renameDeriv is_boot inst_infos bagBinds
315
316
317
318
319
  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
                -- The inst-info bindings will all be empty, but it's easier to
                -- just use rn_inst_info to change the type appropriately
  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
        ; return ( listToBag rn_inst_infos
dreixel's avatar
dreixel committed
320
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
321

322
  | otherwise
323
324
325
326
327
328
329
330
331
332
333
  = discardWarnings $
    -- Discard warnings about unused bindings etc
    setXOptM LangExt.EmptyCase $
    -- Derived decls (for empty types) can have
    --    case x of {}
    setXOptM LangExt.ScopedTypeVariables $
    setXOptM LangExt.KindSignatures $
    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
    -- KindSignatures
    unsetXOptM LangExt.RebindableSyntax $
    -- See Note [Avoid RebindableSyntax when deriving]
334
    do  {
dreixel's avatar
dreixel committed
335
336
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
337
        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
338
339
340
        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
        ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
341
        ; let bndrs = collectHsValBinders rn_aux_lhs
342
        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
343
        ; setEnvs envs $
344
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
345
346
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
347
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
348

349
  where
350
    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
351
352
353
354
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
355
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
356
                            , ib_pragmas = sigs
357
                            , ib_extensions = exts -- Only for type-checking
358
                            , ib_derived = sa } })
359
360
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
361
           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
362
              ; let binds' = InstBindings { ib_binds = rn_binds
363
364
365
366
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
367
              ; return (inst_info { iBinds = binds' }, fvs) }
368

Austin Seipp's avatar
Austin Seipp committed
369
{-
370
371
372
373
374
375
376
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

  module Bug(P) where
  newtype P a = MkP (IO a) deriving Monad

377
If you compile with -Wunused-binds you do not expect the warning
Gabor Greif's avatar
Gabor Greif committed
378
"Defined but not used: data constructor MkP". Yet the newtype deriving
379
380
381
382
383
384
code does not explicitly mention MkP, but it should behave as if you
had written
  instance Monad P where
     return x = MkP (return x)
     ...etc...

385
So we want to signal a user of the data constructor 'MkP'.
386
This is the reason behind the [Name] part of the return type
387
of genInst.
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
Note [Staging of tcDeriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a tricky corner case for deriving (adapted from Trac #2721):

    class C a where
      type T a
      foo :: a -> T a

    instance C Int where
      type T Int = Int
      foo = id

    newtype N = N Int deriving C

This will produce an instance something like this:

    instance C N where
      type T N = T Int
      foo = coerce (foo :: Int -> T Int) :: N -> T N

We must be careful in order to typecheck this code. When determining the
context for the instance (in simplifyInstanceContexts), we need to determine
that T N and T Int have the same representation, but to do that, the T N
instance must be in the local family instance environment. Otherwise, GHC
would be unable to conclude that T Int is representationally equivalent to
T Int, and simplifyInstanceContexts would get stuck.

Previously, tcDeriving would defer adding any derived type family instances to
the instance environment until the very end, which meant that
simplifyInstanceContexts would get called without all the type family instances
it needed in the environment in order to properly simplify instance like
the C N instance above.

To avoid this scenario, we carefully structure the order of events in
tcDeriving. We first call genInst on the standalone derived instance specs and
the instance specs obtained from deriving clauses. Note that the return type of
genInst is a triple:

    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)

The type family instances are in the BagDerivStuff. The first field of the
triple is a suspended computation which, given an instance context, produces
the rest of the instance. The fact that it is suspended is important, because
right now, we don't have ThetaTypes for the instances that use deriving clauses
(only the standalone-derived ones).

Now we can can collect the type family instances and extend the local instance
environment. At this point, it is safe to run simplifyInstanceContexts on the
deriving-clause instance specs, which gives us the ThetaTypes for the
deriving-clause instances. Now we can feed all the ThetaTypes to the
suspended computations and obtain our InstInfos, at which point
tcDeriving is done.

An alternative design would be to split up genInst so that the
family instances are generated separately from the InstInfos. But this would
require carving up a lot of the GHC deriving internals to accommodate the
change. On the other hand, we can keep all of the InstInfo and type family
instance logic together in genInst simply by converting genInst to
continuation-returning style, so we opt for that route.

449
450
451
452
453
454
455
456
457
458
459
460
461
462
Note [Why we don't pass rep_tc into deriveTyData]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
the rep_tc by means of a lookup. And yet we have the rep_tc right here!
Why look it up again? Answer: it's just easier this way.
We drop some number of arguments from the end of the datatype definition
in deriveTyData. The arguments are dropped from the fam_tc.
This action may drop a *different* number of arguments
passed to the rep_tc, depending on how many free variables, etc., the
dropped patterns have.

Also, this technique carries over the kind substitution from deriveTyData
nicely.

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
Note [Avoid RebindableSyntax when deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The RebindableSyntax extension interacts awkwardly with the derivation of
any stock class whose methods require the use of string literals. The Show
class is a simple example (see Trac #12688):

  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
  newtype Text = Text String
  fromString :: String -> Text
  fromString = Text

  data Foo = Foo deriving Show

This will generate code to the effect of:

  instance Show Foo where
    showsPrec _ Foo = showString "Foo"

But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
string literal is now of type Text, not String, which showString doesn't
accept! This causes the generated Show instance to fail to typecheck.

To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
in derived code.

Austin Seipp's avatar
Austin Seipp committed
488
489
************************************************************************
*                                                                      *
490
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
491
492
*                                                                      *
************************************************************************
493

494
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
495
-}
496

497
makeDerivSpecs :: Bool
498
               -> [DerivInfo]
499
               -> [LDerivDecl GhcRn]
500
               -> TcM [EarlyDerivSpec]
501
makeDerivSpecs is_boot deriv_infos deriv_decls
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
  = do  { -- We carefully set up uses of recoverM to minimize error message
          -- cascades. See Note [Flattening deriving clauses].
        ; eqns1 <- sequenceA
                     [ recoverM (pure Nothing)
                                (deriveClause rep_tc (fmap unLoc dcs)
                                                      pred err_ctxt)
                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
                                 , di_ctxt = err_ctxt } <- deriv_infos
                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs
                                             , deriv_clause_tys = L _ preds })
                         <- clauses
                     , pred <- preds
                     ]
        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
        ; let eqns = catMaybes (eqns1 ++ eqns2)
517

518
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
519
              do { unless (null eqns) (add_deriv_err (head eqns))
520
                 ; return [] }
521
          else return eqns }
522
  where
523
    add_deriv_err eqn
524
       = setSrcSpan (earlyDSLoc eqn) $
525
526
         addErr (hang (text "Deriving not permitted in hs-boot file")
                    2 (text "Use an instance declaration instead"))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
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
{-
Note [Flattening deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider what happens if you run this program (from Trac #10684) without
DeriveGeneric enabled:

    data A = A deriving (Show, Generic)
    data B = B A deriving (Show)

Naturally, you'd expect GHC to give an error to the effect of:

    Can't make a derived instance of `Generic A':
      You need -XDeriveGeneric to derive an instance for this class

And *only* that error, since the other two derived Show instances appear to be
independent of this derived Generic instance. Yet GHC also used to give this
additional error on the program above:

    No instance for (Show A)
      arising from the 'deriving' clause of a data type declaration
    When deriving the instance for (Show B)

This was happening because when GHC encountered any error within a single
data type's set of deriving clauses, it would call recoverM and move on
to the next data type's deriving clauses. One unfortunate consequence of
this design is that if A's derived Generic instance failed, so its derived
Show instance would be skipped entirely, leading to the "No instance for
(Show A)" error cascade.

The solution to this problem is to "flatten" the set of classes that are
derived for a particular data type via deriving clauses. That is, if
you have:

    newtype C = C D
      deriving (E, F, G)
      deriving anyclass (H, I, J)
      deriving newtype  (K, L, M)

Then instead of processing instances E through M under the scope of a single
recoverM, we flatten these deriving clauses into the list:

    [ E (Nothing)
    , F (Nothing)
    , G (Nothing)
    , H (Just anyclass)
    , I (Just anyclass)
    , J (Just anyclass)
    , K (Just newtype)
    , L (Just newtype)
    , M (Just newtype) ]

And then process each class individually, under its own recoverM scope. That
way, failure to derive one class doesn't cancel out other classes in the
same set of clause-derived classes.
-}

584
------------------------------------------------------------------
585
586
587
588
-- | Process a single class in a `deriving` clause.
deriveClause :: TyCon -> Maybe DerivStrategy -> LHsSigType GhcRn -> SDoc
             -> TcM (Maybe EarlyDerivSpec)
deriveClause rep_tc mb_strat pred err_ctxt
589
  = addErrCtxt err_ctxt $
590
    deriveTyData tvs tc tys mb_strat pred
591
592
593
594
595
596
597
  where
    tvs = tyConTyVars rep_tc
    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
                        -- data family:
                  Just (fam_tc, pats, _) -> (fam_tc, pats)
      -- NB: deriveTyData wants the *user-specified*
      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
598

599
                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
600

601
------------------------------------------------------------------
602
603
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
-- Process a single standalone deriving declaration
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
604
--  e.g.   deriving instance Show a => Show (T a)
605
-- Rather like tcLocalInstDecl
606
607
608
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
Ryan Scott's avatar
Ryan Scott committed
609
deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
610
611
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
612
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
Ryan Scott's avatar
Ryan Scott committed
613
614
615
       ; let deriv_strat = fmap unLoc deriv_strat'
       ; traceTc "Deriving strategy (standalone deriving)" $
           vcat [ppr deriv_strat, ppr deriv_ty]
616
       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
617
618
619
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
620
621
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
622
                -- C.f. TcInstDcls.tcLocalInstDecl1
623
       ; checkTc (not (null inst_tys)) derivingNullaryErr
624

625
626
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
627
628
629
630
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
631

632
633
634
       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                              inst_ty deriv_strat msg)

635
       ; case tcSplitTyConApp_maybe inst_ty of
636
           Just (tc, tc_args)
637
              | className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
638
              -> do warnUselessTypeable
639
                    return Nothing
640

641
642
643
644
645
646
              | isUnboxedTupleTyCon tc
              -> bale_out $ unboxedTyConErr "tuple"

              | isUnboxedSumTyCon tc
              -> bale_out $ unboxedTyConErr "sum"

Ben Gamari's avatar
Ben Gamari committed
647
              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
648
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
649
                                        tvs cls cls_tys tc tc_args
Ryan Scott's avatar
Ryan Scott committed
650
                                        (Just theta) deriv_strat
651
                    ; return $ Just spec }
652
653

           _  -> -- Complain about functions, primitive types, etc,
654
                 bale_out $
655
                 text "The last argument of the instance must be a data or newtype application"
656
        }
657

Ben Gamari's avatar
Ben Gamari committed
658
659
660
warnUselessTypeable :: TcM ()
warnUselessTypeable
  = do { warn <- woptM Opt_WarnDerivingTypeable
661
       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
662
663
                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                     text "has no effect: all types now auto-derive Typeable" }
Ben Gamari's avatar
Ben Gamari committed
664

665
------------------------------------------------------------------
666
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
667
                                             --   Can be a data instance, hence [Type] args
Ryan Scott's avatar
Ryan Scott committed
668
             -> Maybe DerivStrategy          -- The optional deriving strategy
669
             -> LHsSigType GhcRn             -- The deriving predicate
670
             -> TcM (Maybe EarlyDerivSpec)
dreixel's avatar
dreixel committed
671
-- The deriving clause of a data or newtype declaration
672
-- I.e. not standalone deriving
673
674
675
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
Ryan Scott's avatar
Ryan Scott committed
676
deriveTyData tvs tc tc_args deriv_strat deriv_pred
677
  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
678
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
679
680
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
681
682
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
683
684
685
                -- The "deriv_pred" is a LHsType to take account of the fact that for
                -- newtype deriving we allow deriving (forall a. C [a]).

Gabor Greif's avatar
Gabor Greif committed
686
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
687
688
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
689
        ; when (cls_arg_kinds `lengthIsNot` 1) $
690
691
            failWithTc (nonUnaryErr deriv_pred)
        ; let [cls_arg_kind] = cls_arg_kinds
692
        ; if className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
693
          then do warnUselessTypeable
694
                  return Nothing
695
          else
696

697
     do {  -- Given data T a b c = ... deriving( C d ),
698
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
699
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
700
701
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
702
703
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
704
705
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)

706
707
708
709
              -- Match up the kinds, and apply the resulting kind substitution
              -- to the types.  See Note [Unify kinds in deriving]
              -- We are assuming the tycon tyvars and the class tyvars are distinct
              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind
Ryan Scott's avatar
Ryan Scott committed
710
711
712
713
714
              enough_args     = n_args_to_keep >= 0

        -- Check that the result really is well-kinded
        ; checkTc (enough_args && isJust mb_match)
                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)
715

Ryan Scott's avatar
Ryan Scott committed
716
717
        ; let Just kind_subst = mb_match
              ki_subst_range  = getTCvSubstRangeFVs kind_subst
718
              all_tkvs        = toposortTyVars $
niteria's avatar
niteria committed
719
720
721
                                fvVarList $ unionFV
                                  (tyCoFVsOfTypes tc_args_to_keep)
                                  (FV.mkFVs deriv_tvs)
722
723
724
725
726
              -- See Note [Unification of two kind variables in deriving]
              unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
                                      && not (v `elemVarSet` ki_subst_range))
                                       all_tkvs
              (subst, _)      = mapAccumL substTyVarBndr
727
728
729
                                          kind_subst unmapped_tkvs
              final_tc_args   = substTys subst tc_args_to_keep
              final_cls_tys   = substTys subst cls_tys
730
731
              tkvs            = tyCoVarsOfTypesWellScoped $
                                final_cls_tys ++ final_tc_args
732

Ryan Scott's avatar
Ryan Scott committed
733
734
735
        ; traceTc "Deriving strategy (deriving clause)" $
            vcat [ppr deriv_strat, ppr deriv_pred]

Ben Gamari's avatar
Ben Gamari committed
736
737
738
        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args
                                       , ppr deriv_pred
                                       , pprTyVars (tyCoVarsOfTypesList tc_args)
739
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
740
741
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
742

743
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
744

745
        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
746
                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
747
                -- Check that
748
749
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
750
751
752
753
754
                --  (b) The args to drop are all *distinct* type variables; eg reject:
                --              class C (a :: * -> * -> *) where ...
                --              data instance T a a = ... deriving( C )
                --  (c) The type class args, or remaining tycon args,
                --      do not mention any of the dropped type variables
755
                --              newtype T a s = ... deriving( ST s )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
756
                --              newtype instance K a a = ... deriving( Monad )
Ryan Scott's avatar
Ryan Scott committed
757
758
759
760
                --
                -- It is vital that the implementation of allDistinctTyVars
                -- expand any type synonyms.
                -- See Note [Eta-reducing type synonyms]
761

762
        ; spec <- mkEqnHelp Nothing tkvs
Ryan Scott's avatar
Ryan Scott committed
763
764
                            cls final_cls_tys tc final_tc_args
                            Nothing deriv_strat
765
        ; traceTc "derivTyData" (ppr spec)
766
        ; return $ Just spec } }
767

768

Austin Seipp's avatar
Austin Seipp committed
769
{-
770
Note [Unify kinds in deriving]
771
772
773
774
775
776
777
778
779
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (Trac #8534)
    data T a b = MkT a deriving( Functor )
    -- where Functor :: (*->*) -> Constraint

So T :: forall k. * -> k -> *.   We want to get
    instance Functor (T * (a:*)) where ...
Notice the '*' argument to T.

780
781
782
783
784
785
Moreover, as well as instantiating T's kind arguments, we may need to instantiate
C's kind args.  Consider (Trac #8865):
  newtype T a b = MkT (Either a b) deriving( Category )
where
  Category :: forall k. (k -> k -> *) -> Constraint
We need to generate the instance
Krzysztof Gogolewski's avatar
Typos    
Krzysztof Gogolewski committed
786
787
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
788
789
790
791
792
793
794
795
796

So we need to
 * drop arguments from (T a b) to match the number of
   arrows in the (last argument of the) class;
 * and then *unify* kind of the remaining type against the
   expected kind, to figure out how to instantiate C's and T's
   kind arguments.

In the two examples,
797
798
799
800
801
802
803
804
 * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )
         i.e.      (k -> *) ~ (* -> *)   to find k:=*.
         yielding  k:=*

 * we unify   kind-of( Either ) ~ kind-of( Category )
         i.e.      (* -> * -> *)  ~ (k -> k -> k)
         yielding  k:=*

805
Now we get a kind substitution.  We then need to:
806

807
  1. Remove the substituted-out kind variables from the quantified kind vars
808
809
810
811
812
813
814
815
816
817
818
819
820
821

  2. Apply the substitution to the kinds of quantified *type* vars
     (and extend the substitution to reflect this change)

  3. Apply that extended substitution to the non-dropped args (types and
     kinds) of the type and class

Forgetting step (2) caused Trac #8893:
  data V a = V [a] deriving Functor
  data P (x::k->*) (a:k) = P (x a) deriving Functor
  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor

When deriving Functor for P, we unify k to *, but we then want
an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
822
and similarly for C.  Notice the modified kind of x, both at binding
823
and occurrence sites.
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
This can lead to some surprising results when *visible* kind binder is
unified (in contrast to the above examples, in which only non-visible kind
binders were considered). Consider this example from Trac #11732:

    data T k (a :: k) = MkT deriving Functor

Since unification yields k:=*, this results in a generated instance of:

    instance Functor (T *) where ...

which looks odd at first glance, since one might expect the instance head
to be of the form Functor (T k). Indeed, one could envision an alternative
generated instance of:

    instance (k ~ *) => Functor (T k) where

But this does not typecheck as the result of a -XTypeInType design decision:
kind equalities are not allowed to be bound in types, only terms. But in
essence, the two instance declarations are entirely equivalent, since even
though (T k) matches any kind k, the only possibly value for k is *, since
anything else is ill-typed. As a result, we can just as comfortably use (T *).

Another way of thinking about is: deriving clauses often infer constraints.
For example:

    data S a = S a deriving Eq

infers an (Eq a) constraint in the derived instance. By analogy, when we
are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
The only distinction is that GHC instantiates equality constraints directly
during the deriving process.

Another quirk of this design choice manifests when typeclasses have visible
kind parameters. Consider this code (also from Trac #11732):

    class Cat k (cat :: k -> k -> *) where
      catId   :: cat a a
      catComp :: cat b c -> cat a b -> cat a c

    instance Cat * (->) where
      catId   = id
      catComp = (.)

    newtype Fun a b = Fun (a -> b) deriving (Cat k)

Gabor Greif's avatar
Gabor Greif committed
870
Even though we requested a derived instance of the form (Cat k Fun), the
871
872
873
kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
the user wrote deriving (Cat *)).

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
Note [Unification of two kind variables in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As a special case of the Note above, it is possible to derive an instance of
a poly-kinded typeclass for a poly-kinded datatype. For example:

    class Category (cat :: k -> k -> *) where
    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category

This case is suprisingly tricky. To see why, let's write out what instance GHC
will attempt to derive (using -fprint-explicit-kinds syntax):

    instance Category k1 (T k2 c) where ...

GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
the type variable binder for c, since its kind is (k2 -> k2 -> *).

We used to accomplish this by doing the following:

    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
    (subst, _)    = mapAccumL substTyVarBndr kind_subst unmapped_tkvs

Where all_tkvs contains all kind variables in the class and instance types (in
this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
This is bad, because applying that substitution yields the following instance:

   instance Category k_new (T k1 c) where ...

In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
in an ill-kinded instance (this caused Trac #11837).

To prevent this, we need to filter out any variable from all_tkvs which either

1. Appears in the domain of kind_subst. notElemTCvSubst checks this.
2. Appears in the range of kind_subst. To do this, we compute the free
   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check
   if a kind variable appears in that set.

914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
Note [Eta-reducing type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One can instantiate a type in a data family instance with a type synonym that
mentions other type variables:

  type Const a b = a
  data family Fam (f :: * -> *) (a :: *)
  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor

With -XTypeInType, it is also possible to define kind synonyms, and they can
mention other types in a datatype declaration. For example,

  type Const a b = a
  newtype T f (a :: Const * f) = T (f a) deriving Functor

When deriving, we need to perform eta-reduction analysis to ensure that none of
the eta-reduced type variables are mentioned elsewhere in the declaration. But
we need to be careful, because if we don't expand through the Const type
synonym, we will mistakenly believe that f is an eta-reduced type variable and
fail to derive Functor, even though the code above is correct (see Trac #11416,
Ryan Scott's avatar
Ryan Scott committed
934
935
where this was first noticed). For this reason, we expand the type synonyms in
the eta-reduced types before doing any analysis.
Austin Seipp's avatar
Austin Seipp committed
936
-}
937

938
939
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
940
941
          -> Class -> [Type]
          -> TyCon -> [Type]
942
943
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
Ryan Scott's avatar
Ryan Scott committed
944
          -> Maybe DerivStrategy
945
946
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
947
--      forall tvs. theta => cls (tys ++ [ty])
948
949
950
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

Ryan Scott's avatar
Ryan Scott committed
951
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
952
953
954
955
956
957
  = do {      -- Find the instance of a data family
              -- Note [Looking up family instances for deriving]
         fam_envs <- tcGetFamInstEnvs
       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
              -- If it's still a data family, the lookup failed; i.e no instance exists
       ; when (isDataFamilyTyCon rep_tc)
958
              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
959
960
961
962
       ; is_boot <- tcIsHsBootOrSig
       ; when is_boot $
              bale_out (text "Cannot derive instances in hs-boot files"
                    $+$ text "Write an instance declaration instead")
963

964
965
966
967
968
969
970
971
972
973
974
975
976
       ; let deriv_env = DerivEnv
                         { denv_overlap_mode = overlap_mode
                         , denv_tvs          = tvs
                         , denv_cls          = cls
                         , denv_cls_tys      = cls_tys
                         , denv_tc           = tycon
                         , denv_tc_args      = tc_args
                         , denv_rep_tc       = rep_tc
                         , denv_rep_tc_args  = rep_tc_args
                         , denv_mtheta       = mtheta
                         , denv_strat        = deriv_strat }
       ; flip runReaderT deriv_env $
         if isDataTyCon rep_tc then mkDataTypeEqn else mkNewTypeEqn }
977
  where
Ryan Scott's avatar
Ryan Scott committed
978
979
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                      (mkTyConApp tycon tc_args) deriv_strat msg)
980

Austin Seipp's avatar
Austin Seipp committed
981
{-
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
Note [Looking up family instances for deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcLookupFamInstExact is an auxiliary lookup wrapper which requires
that looked-up family instances exist.  If called with a vanilla
tycon, the old type application is simply returned.

If we have
  data instance F () = ... deriving Eq
  data instance F () = ... deriving Eq
then tcLookupFamInstExact will be confused by the two matches;
but that can't happen because tcInstDecls1 doesn't call tcDeriving
if there are any overlaps.

There are two other things that might go wrong with the lookup.
First, we might see a standalone deriving clause
   deriving Eq (F ())
998
when there is no data instance F () in scope.
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

Note that it's OK to have
  data instance F [a] = ...
  deriving Eq (F [(a,b)])
where the match is not exact; the same holds for ordinary data types
with standalone deriving declarations.

Note [Deriving, type families, and partial applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When there are no type families, it's quite easy:

    newtype S a = MkS [a]
    -- :CoS :: S  ~ []  -- Eta-reduced

    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S

When type familes are involved it's trickier:

    data family T a b
    newtype instance T Int a = MkT [a] deriving( Eq, Monad )
    -- :RT is the representation type for (T Int a)
    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!

    instance Eq [a] => Eq (T Int a)     -- easy by coercion
       -- d1 :: Eq [a]
       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))

    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
       -- d1 :: Monad []
1030
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
1031
1032
1033
1034
1035
1036
1037

Note the need for the eta-reduced rule axioms.  After all, we can
write it out
    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
      return x = MkT [x]
      ... etc ...

1038
See Note [Eta reduction for data families] in FamInstEnv
1039

1040
1041
%************************************************************************
%*                                                                      *
1042
                Deriving data types
Austin Seipp's avatar
Austin Seipp committed
1043
1044
1045
*                                                                      *
************************************************************************
-}
1046

1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
mkDataTypeEqn :: DerivM EarlyDerivSpec
mkDataTypeEqn
  = do mb_strat <- asks denv_strat
       let bale_out msg = do err <- derivingThingErrM False msg
                             lift $ failWithTc err
       case mb_strat of
         Just StockStrategy    -> mk_eqn_stock    mk_data_eqn bale_out
         Just AnyclassStrategy -> mk_eqn_anyclass mk_data_eqn bale_out
         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr
         -- Lacking a user-requested deriving strategy, we will try to pick
         -- between the stock or anyclass strategies
         Nothing -> mk_eqn_no_mechanism mk_data_eqn bale_out

mk_data_eqn :: DerivSpecMechanism -- How GHC should proceed attempting to
Ryan Scott's avatar
Ryan Scott committed
1062
1063
                                  -- derive this instance, determined in
                                  -- mkDataTypeEqn/mkNewTypeEqn
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
            -> DerivM EarlyDerivSpec
mk_data_eqn mechanism
  = do DerivEnv { denv_overlap_mode = overlap_mode
                , denv_tvs          = tvs
                , denv_tc           = tc
                , denv_tc_args      = tc_args
                , denv_rep_tc       = rep_tc
                , denv_cls          = cls
                , denv_cls_tys      = cls_tys
                , denv_mtheta       = mtheta } <- ask
       let inst_ty  = mkTyConApp tc tc_args
           inst_tys = cls_tys ++ [inst_ty]
       doDerivInstErrorChecks1 mechanism
       loc       <- lift getSrcSpanM
       dfun_name <- lift $ newDFunName' cls tc
1079
       case mtheta of
1080
        Nothing -> -- Infer context
1081
          do { (inferred_constraints, tvs', inst_tys')
1082
                 <- inferConstraints mechanism
1083
             ; return $ InferTheta $ DS
1084
                   { ds_loc = loc
1085
1086
                   , ds_name = dfun_name, ds_tvs = tvs'
                   , ds_cls = cls, ds_tys = inst_tys'
1087
                   , ds_tc = rep_tc
1088
                   , ds_theta = inferred_constraints
1089
                   , ds_overlap = overlap_mode
1090
1091
                   , ds_mechanism = mechanism } }

1092
1093
1094
1095
1096
        Just theta -> do -- Specified context
            return $ GivenTheta $ DS
                   { ds_loc = loc
                   , ds_name = dfun_name, ds_tvs = tvs
                   , ds_cls = cls, ds_tys = inst_tys
1097
                   , ds_tc = rep_tc
1098
                   , ds_theta = theta
1099
                   , ds_overlap = overlap_mode
Ryan Scott's avatar
Ryan Scott committed
1100
                   , ds_mechanism = mechanism }
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160

mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
             -> (SDoc -> DerivM EarlyDerivSpec)
             -> DerivM EarlyDerivSpec
mk_eqn_stock go_for_it bale_out
  = do DerivEnv { denv_rep_tc  = rep_tc
                , denv_cls     = cls
                , denv_cls_tys = cls_tys
                , denv_mtheta  = mtheta } <- ask
       dflags <- getDynFlags
       case checkSideConditions dflags mtheta cls cls_tys rep_tc of
         CanDerive               -> mk_eqn_stock' go_for_it
         DerivableClassError msg -> bale_out msg
         _                       -> bale_out (nonStdErr cls)

mk_eqn_stock' :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
              -> DerivM EarlyDerivSpec
mk_eqn_stock' go_for_it
  = do cls <- asks denv_cls
       go_for_it $
         case hasStockDeriving cls of
           Just gen_fn -> DerivSpecStock gen_fn
           Nothing ->
             pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)

mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
                -> (SDoc -> DerivM EarlyDerivSpec)
                -> DerivM EarlyDerivSpec
mk_eqn_anyclass go_for_it bale_out
  = do dflags <- getDynFlags
       case canDeriveAnyClass dflags of
         IsValid      -> go_for_it DerivSpecAnyClass
         NotValid msg -> bale_out msg

mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
                    -> (SDoc -> DerivM EarlyDerivSpec)
                    -> DerivM EarlyDerivSpec
mk_eqn_no_mechanism go_for_it bale_out
  = do DerivEnv { denv_tc      = tc
                , denv_rep_tc  = rep_tc
                , denv_cls     = cls
                , denv_cls_tys = cls_tys
                , denv_mtheta  = mtheta } <- ask
       dflags <- getDynFlags

           -- See Note [Deriving instances for classes themselves]
       let dac_error msg
             | isClassTyCon rep_tc
             = quotes (ppr tc) <+> text "is a type class,"
                               <+> text "and can only have a derived instance"
                               $+$ text "if DeriveAnyClass is enabled"
             | otherwise
             = nonStdErr cls $$ msg

       case checkSideConditions dflags mtheta cls cls_tys rep_tc of
           -- NB: pass the *representation* tycon to checkSideConditions
           NonDerivableClass   msg -> bale_out (dac_error msg)
           DerivableClassError msg -> bale_out msg
           CanDerive               -> mk_eqn_stock' go_for_it
           DerivableViaInstance    -> go_for_it DerivSpecAnyClass
Ryan Scott's avatar
Ryan Scott committed
1161

Austin Seipp's avatar
Austin Seipp committed
1162
1163
1164
{-
************************************************************************
*                                                                      *
1165
                Deriving newtypes
Austin Seipp's avatar
Austin Seipp committed
1166
1167
1168
*                                                                      *
************************************************************************
-}
1169