TcDeriv.hs 94 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
10
{-# LANGUAGE CPP #-}

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

13
#include "HsVersions.h"
14

15
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
16
import DynFlags
17

18
import TcRnMonad
19
import FamInst
20
21
import TcErrors( reportAllUnsolved )
import TcValidity( validDerivPred )
22
import TcClassDcl( tcATDefault, tcMkDeclCtxt )
Simon Marlow's avatar
Simon Marlow committed
23
import TcEnv
24
import TcGenDeriv                       -- Deriv stuff
25
import TcGenGenerics
Simon Marlow's avatar
Simon Marlow committed
26
27
import InstEnv
import Inst
28
import FamInstEnv
Simon Marlow's avatar
Simon Marlow committed
29
import TcHsType
30
import TcMType
Simon Marlow's avatar
Simon Marlow committed
31
import TcSimplify
32
import TcUnify( buildImplicationFor )
33
import LoadIface( loadInterfaceForName )
34
import Module( getModule )
Simon Marlow's avatar
Simon Marlow committed
35

36
import RnNames( extendGlobalRdrEnvRn )
Simon Marlow's avatar
Simon Marlow committed
37
import RnBinds
38
import RnEnv
39
import RnSource   ( addTcgDUs )
Simon Marlow's avatar
Simon Marlow committed
40
import HscTypes
41
import Avail
Simon Marlow's avatar
Simon Marlow committed
42

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

import Control.Monad
68
import Data.List
69

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

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

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

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

-- DerivSpec is purely  local to this module
88
data DerivSpec theta = DS { ds_loc     :: SrcSpan
89
                          , ds_name    :: Name           -- DFun name
90
91
92
93
94
                          , ds_tvs     :: [TyVar]
                          , ds_theta   :: theta
                          , ds_cls     :: Class
                          , ds_tys     :: [Type]
                          , ds_tc      :: TyCon
95
                          , ds_overlap :: Maybe OverlapMode
96
                          , ds_newtype :: Maybe Type }  -- The newtype rep type
97
98
99
100
101
102
        -- 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
        -- For type families, the tycon in
        --       in ds_tys is the *family* tycon
103
        --       in ds_tc is the *representation* type
104
105
        -- For non-family tycons, both are the same

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

109
110
        -- ds_newtype = Just rep_ty  <=> Generalised Newtype Deriving (GND)
        --              Nothing      <=> Vanilla deriving
111

Austin Seipp's avatar
Austin Seipp committed
112
{-
113
Example:
114

115
     newtype instance T [a] = MkT (Tree a) deriving( C s )
dterei's avatar
dterei committed
116
==>
117
118
119
120
     axiom T [a] = :RTList a
     axiom :RTList a = Tree a

     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
121
        , ds_tc = :RTList, ds_newtype = Just (Tree a) }
Austin Seipp's avatar
Austin Seipp committed
122
-}
123

124
type DerivContext = Maybe ThetaType
125
   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
126
127
   -- Just theta <=> Standalone deriving: context supplied by programmer

128
data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
129
130
type ThetaOrigin = [PredOrigin]

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

134
135
mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
136
137
138
139
140
141
142

data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
                    | GivenTheta (DerivSpec ThetaType)
        -- InferTheta ds => the context for the instance should be inferred
        --      In this case ds_theta is the list of all the constraints
        --      needed, such as (Eq [a], Eq a), together with a suitable CtLoc
        --      to get good error messages.
143
144
        --      The inference process is to reduce this to a
        --      simpler form (e.g. Eq a)
145
        --
146
147
        -- GivenTheta ds => the exact context for the instance is supplied
        --                  by the programmer; it is ds_theta
148
        -- See Note [Inferring the instance context]
149
150
151
152
153
154
155
156
157
158
159

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

splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType])
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)
160

161
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
dterei's avatar
dterei committed
162
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
163
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
164
165
166
167
168
169
170
  = 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 ])
171

172
instance Outputable theta => Outputable (DerivSpec theta) where
173
  ppr = pprDerivSpec
174
175

instance Outputable EarlyDerivSpec where
176
177
  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
178
179

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

182
183
184
{- Note [Inferring the instance context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are two sorts of 'deriving':
185

186
187
188
189
190
  * InferTheta: the deriving clause for a data type
      data T a = T1 a deriving( Eq )
    Here we must infer an instance context,
    and generate instance declaration
      instance Eq a => Eq (T a) where ...
191

192
193
194
195
  * CheckTheta: standalone deriving
      deriving instance Eq a => Eq (T a)
    Here we only need to fill in the bindings;
    the instance context is user-supplied
196

197
198
199
200
201
For a deriving clause (InferTheta) we must figure out the
instance context (inferConstraints). Suppose we are inferring
the instance context for
    C t1 .. tn (T s1 .. sm)
There are two cases
202

203
204
205
206
  * (T s1 .. sm) :: *         (the normal case)
    Then we behave like Eq and guess (C t1 .. tn t)
    for each data constructor arg of type t.  More
    details below.
207

208
209
  * (T s1 .. sm) :: * -> *    (the functor-like case)
    Then we behave like Functor.
210

211
212
213
In both cases we produce a bunch of un-simplified constraints
and them simplify them in simplifyInstanceContexts; see
Note [Simplifying the instance context].
214

215

216
217
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
218
219
Consider

220
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
221
222
223

We will need an instance decl like:

224
225
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
226
227
228

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
229
in RealFloat.
230
231
232
233
234
235
236

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

237
        Read, Enum?
238

239
240
241
242
243
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".

244
245
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
246
247
248
249
250
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
251
Notice the free 'a' in the deriving.  We have to fill this out to
252
253
254
255
    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
256
257


258
259
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
260
261
262
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

263
264
265
266
267
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
268
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
269
Then the Show instance is not done via Coercible; it shows
270
        Foo 3 as "Foo 3"
271
The Num instance is derived via Coercible, but the Show superclass
272
273
274
275
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
276
277
        (+) = ((+)@a)
        ...etc...
278
279
280
281
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


282
283
284
285
286
287
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.
288

289
290
291
292
293
294
-}

-- | Stuff needed to process a `deriving` clause
data DerivInfo = DerivInfo { di_rep_tc :: TyCon
                             -- ^ The data tycon for normal datatypes,
                             -- or the *representation* tycon for data families
295
                           , di_preds  :: [LHsSigType Name]
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
                           , di_ctxt   :: SDoc -- ^ error context
                           }

-- | Extract `deriving` clauses of proper data type (skips data families)
mkDerivInfos :: [TyClGroup Name] -> TcM [DerivInfo]
mkDerivInfos tycls = concatMapM mk_derivs tycls
  where
    mk_derivs (TyClGroup { group_tyclds = decls })
      = concatMapM (mk_deriv . unLoc) decls

    mk_deriv decl@(DataDecl { tcdLName = L _ data_name
                            , tcdDataDefn =
                                HsDataDefn { dd_derivs = Just (L _ preds) } })
      = do { tycon <- tcLookupTyCon data_name
           ; return [DerivInfo { di_rep_tc = tycon, di_preds = preds
                               , di_ctxt = tcMkDeclCtxt decl }] }
    mk_deriv _ = return []

{-

Austin Seipp's avatar
Austin Seipp committed
316
317
************************************************************************
*                                                                      *
318
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
319
320
321
*                                                                      *
************************************************************************
-}
322

323
tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
324
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
325
            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
326
tcDeriving deriv_infos deriv_decls
327
328
  = recoverM (do { g <- getGblEnv
                 ; return (g, emptyBag, emptyValBindsOut)}) $
329
330
    do  {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
331
          is_boot <- tcIsHsBootOrSig
332
        ; traceTc "tcDeriving" (ppr is_boot)
333

334
        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
335
        ; traceTc "tcDeriving 1" (ppr early_specs)
336

337
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
338
        ; insts1 <- mapM genInst given_specs
339

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
340
341
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
342
        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
343
                         simplifyInstanceContexts infer_specs
344

345
        ; insts2 <- mapM genInst final_specs
346

347
        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
348
        ; loc <- getSrcSpanM
349
350
        ; let (binds, famInsts, extraInstances) =
                genAuxBinds loc (unionManyBags deriv_stuff)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
351

352
353
        ; dflags <- getDynFlags

dreixel's avatar
dreixel committed
354
355
        ; (inst_info, rn_binds, rn_dus) <-
            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
356

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
357
        ; unless (isEmptyBag inst_info) $
358
             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
359
                        (ddump_deriving inst_info rn_binds famInsts))
dreixel's avatar
dreixel committed
360

361
        ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
362
                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
363
364
        ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
365
  where
366
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
367
                   -> Bag FamInst             -- ^ Rep type family instances
368
                   -> SDoc
369
    ddump_deriving inst_infos extra_binds repFamInsts
370
      =    hang (text "Derived instances:")
371
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
372
                 $$ ppr extra_binds)
373
374
        $$ hangP "GHC.Generics representation types:"
             (vcat (map pprRepTy (bagToList repFamInsts)))
375

376
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
377

378
-- Prints the representable type family instance
379
380
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
381
  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
382
383
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
384

385
renameDeriv :: Bool
386
            -> [InstInfo RdrName]
387
            -> Bag (LHsBind RdrName, LSig RdrName)
388
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
389
renameDeriv is_boot inst_infos bagBinds
390
391
392
393
394
  | 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
395
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
396

397
  | otherwise
398
  = discardWarnings $         -- Discard warnings about unused bindings etc
399
400
401
402
    setXOptM LangExt.EmptyCase $  -- Derived decls (for empty types) can have
                                  --    case x of {}
    setXOptM LangExt.ScopedTypeVariables $  -- Derived decls (for newtype-deriving) can
    setXOptM LangExt.KindSignatures $       -- used ScopedTypeVariables & KindSignatures
403
    do  {
dreixel's avatar
dreixel committed
404
405
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
406
        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
407
408
409
        ; (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
410
        ; let bndrs = collectHsValBinders rn_aux_lhs
411
        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
412
        ; setEnvs envs $
413
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
414
415
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
416
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
417

418
  where
419
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
420
421
422
423
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
424
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
425
                            , ib_pragmas = sigs
426
                            , ib_extensions = exts -- Only for type-checking
427
                            , ib_derived = sa } })
428
429
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
430
           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
431
              ; let binds' = InstBindings { ib_binds = rn_binds
432
433
434
435
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
436
              ; return (inst_info { iBinds = binds' }, fvs) }
437

Austin Seipp's avatar
Austin Seipp committed
438
{-
439
440
441
442
443
444
445
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

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

446
If you compile with -Wunused-binds you do not expect the warning
447
448
449
450
451
452
453
"Defined but not used: data consructor MkP". Yet the newtype deriving
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...

454
455
456
So we want to signal a user of the data constructor 'MkP'.
This is the reason behind the (Maybe Name) part of the return type
of genInst.
457

458
459
460
461
462
463
464
465
466
467
468
469
470
471
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.

Austin Seipp's avatar
Austin Seipp committed
472
473
************************************************************************
*                                                                      *
474
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
475
476
*                                                                      *
************************************************************************
477

478
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
479
-}
480

481
makeDerivSpecs :: Bool
482
               -> [DerivInfo]
483
484
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
485
486
487
488
makeDerivSpecs is_boot deriv_infos deriv_decls
  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo)  deriv_infos
        ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
        ; let eqns = eqns1 ++ eqns2
489

490
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
491
              do { unless (null eqns) (add_deriv_err (head eqns))
492
                 ; return [] }
493
          else return eqns }
494
  where
495
    add_deriv_err eqn
496
       = setSrcSpan (earlyDSLoc eqn) $
497
498
         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
499

500
------------------------------------------------------------------
501
502
503
504
505
506
507
508
509
510
511
512
513
-- | Process a `deriving` clause
deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
                           , di_ctxt = err_ctxt })
  = addErrCtxt err_ctxt $
    concatMapM (deriveTyData tvs tc tys) preds
  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]
514

515
                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
516

517
------------------------------------------------------------------
518
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
519
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
520
--  e.g.   deriving instance Show a => Show (T a)
521
-- Rather like tcLocalInstDecl
522
deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
523
524
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
525
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
526
       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
527
528
529
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
530
531
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
532
                -- C.f. TcInstDcls.tcLocalInstDecl1
533
       ; checkTc (not (null inst_tys)) derivingNullaryErr
534

535
536
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
537
538
539
540
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
541
542

       ; case tcSplitTyConApp_maybe inst_ty of
543
           Just (tc, tc_args)
544
              | className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
545
              -> do warnUselessTypeable
546
                    return []
547

Ben Gamari's avatar
Ben Gamari committed
548
              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
549
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
550
551
                                        tvs cls cls_tys tc tc_args
                                        (Just theta)
552
                    ; return [spec] }
553
554
555

           _  -> -- Complain about functions, primitive types, etc,
                 failWithTc $ derivingThingErr False cls cls_tys inst_ty $
556
                 text "The last argument of the instance must be a data or newtype application"
557
        }
558

Ben Gamari's avatar
Ben Gamari committed
559
560
561
562
warnUselessTypeable :: TcM ()
warnUselessTypeable
  = do { warn <- woptM Opt_WarnDerivingTypeable
       ; when warn $ addWarnTc
563
564
                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                     text "has no effect: all types now auto-derive Typeable" }
Ben Gamari's avatar
Ben Gamari committed
565

566
------------------------------------------------------------------
567
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
568
                                             --   Can be a data instance, hence [Type] args
569
             -> LHsSigType Name              -- The deriving predicate
570
             -> TcM [EarlyDerivSpec]
dreixel's avatar
dreixel committed
571
-- The deriving clause of a data or newtype declaration
572
-- I.e. not standalone deriving
573
574
deriveTyData tvs tc tc_args deriv_pred
  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
575
576
577
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
578
579
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
580
581
582
                -- 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
583
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
584
585
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
586
        ; if className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
587
          then do warnUselessTypeable
588
                  return []
589
          else
590

591
     do {  -- Given data T a b c = ... deriving( C d ),
592
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
593
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
594
595
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
596
597
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
598
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
599
600
601
602
603
              -- Use exactTyCoVarsOfTypes, not tyCoVarsOfTypes, so that we
              -- don't mistakenly grab a type variable mentioned in a type
              -- synonym that drops it.
              -- See Note [Eta-reducing type synonyms].
              dropped_tvs     = exactTyCoVarsOfTypes args_to_drop
604

605
606
607
608
              -- 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
609
              Just kind_subst = mb_match
610
611
612
613
614
615
616
617
618

              all_tkvs        = varSetElemsWellScoped $
                                mkVarSet deriv_tvs `unionVarSet`
                                tyCoVarsOfTypes tc_args_to_keep
              unmapped_tkvs   = filter (`notElemTCvSubst` kind_subst) all_tkvs
              (subst, tkvs)   = mapAccumL substTyVarBndr
                                          kind_subst unmapped_tkvs
              final_tc_args   = substTys subst tc_args_to_keep
              final_cls_tys   = substTys subst cls_tys
619

Simon Peyton Jones's avatar
Simon Peyton Jones committed
620
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
621
                                       , pprTvBndrs (tyCoVarsOfTypesList tc_args)
622
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
623
624
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
625

626
        -- Check that the result really is well-kinded
627
        ; checkTc (n_args_to_keep >= 0 && isJust mb_match)
628
                  (derivingKindErr tc cls cls_tys cls_arg_kind)
629

630
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
631

632
        ; checkTc (allDistinctTyVars args_to_drop &&              -- (a) and (b)
633
                   not (any (`elemVarSet` dropped_tvs) tkvs))     -- (c)
634
                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
635
                -- Check that
636
637
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
638
639
640
641
642
                --  (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
643
                --              newtype T a s = ... deriving( ST s )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
644
                --              newtype instance K a a = ... deriving( Monad )
645

646
        ; spec <- mkEqnHelp Nothing tkvs
647
                            cls final_cls_tys tc final_tc_args Nothing
648
        ; traceTc "derivTyData" (ppr spec)
649
        ; return [spec] } }
650

651

Austin Seipp's avatar
Austin Seipp committed
652
{-
653
Note [Unify kinds in deriving]
654
655
656
657
658
659
660
661
662
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

663
664
665
666
667
668
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
669
670
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
671
672
673
674
675
676
677
678
679

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,
680
681
682
683
684
685
686
687
 * 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:=*

688
Now we get a kind substitution.  We then need to:
689

690
  1. Remove the substituted-out kind variables from the quantified kind vars
691
692
693
694
695
696
697
698
699
700
701
702
703
704

  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:*->*))
705
and similarly for C.  Notice the modified kind of x, both at binding
706
and occurrence sites.
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

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,
where this was first noticed).

For this reason, we call exactTyCoVarsOfTypes on the eta-reduced types so that
we only consider the type variables that remain after expanding through type
synonyms.
Austin Seipp's avatar
Austin Seipp committed
733
-}
734

735
736
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
737
738
          -> Class -> [Type]
          -> TyCon -> [Type]
739
740
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
741
742
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
743
--      forall tvs. theta => cls (tys ++ [ty])
744
745
746
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

747
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
748
749
750
751
752
753
  = 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)
754
              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
755
756
757
758
759
760
761
762
763
764

       -- For standalone deriving (mtheta /= Nothing),
       -- check that all the data constructors are in scope.
       ; rdr_env <- getGlobalRdrEnv
       ; let data_con_names = map dataConName (tyConDataCons rep_tc)
             hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
                                (isAbstractTyCon rep_tc ||
                                 any not_in_scope data_con_names)
             not_in_scope dc  = null (lookupGRE_Name rdr_env dc)

765
       ; addUsedDataCons rdr_env rep_tc
766
767
768
769
770
       ; unless (isNothing mtheta || not hidden_data_cons)
                (bale_out (derivingHiddenErr tycon))

       ; dflags <- getDynFlags
       ; if isDataTyCon rep_tc then
771
            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
772
773
                          tycon tc_args rep_tc rep_tc_args mtheta
         else
774
            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
775
                         tycon tc_args rep_tc rep_tc_args mtheta }
776
  where
777
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
778

Austin Seipp's avatar
Austin Seipp committed
779
{-
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
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 ())
796
when there is no data instance F () in scope.
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

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 []
828
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
829
830
831
832
833
834
835

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 ...

836
See Note [Eta reduction for data families] in FamInstEnv
837

838
839
%************************************************************************
%*                                                                      *
840
                Deriving data types
Austin Seipp's avatar
Austin Seipp committed
841
842
843
*                                                                      *
************************************************************************
-}
844

845
mkDataTypeEqn :: DynFlags
846
              -> Maybe OverlapMode
847
              -> [TyVar]                -- Universally quantified type variables in the instance
848
849
              -> Class                  -- Class for which we need to derive an instance
              -> [Type]                 -- Other parameters to the class except the last
dterei's avatar
dterei committed
850
              -> TyCon                  -- Type constructor for which the instance is requested
851
                                        --    (last parameter to the type class)
852
853
854
              -> [Type]                 -- Parameters to the type constructor
              -> TyCon                  -- rep of the above (for type families)
              -> [Type]                 -- rep of the above
855
              -> DerivContext        -- Context of the instance, for standalone deriving
856
857
              -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error

858
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
859
              tycon tc_args rep_tc rep_tc_args mtheta
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
860
  = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
861
        -- NB: pass the *representation* tycon to checkSideConditions
862
        NonDerivableClass   msg -> bale_out (nonStdErr cls $$ msg)
863
        DerivableClassError msg -> bale_out msg
864
865
        CanDerive               -> go_for_it
        DerivableViaInstance    -> go_for_it
866
  where
867
    go_for_it    = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
868
    bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
869

870
mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
871
872
            -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
            -> TcM EarlyDerivSpec
873
mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
874
  = do loc                  <- getSrcSpanM
875
       dfun_name            <- newDFunName' cls tycon
876
877
       case mtheta of
        Nothing -> do --Infer context
878
            inferred_constraints <- inferConstraints cls cls_tys inst_ty rep_tc rep_tc_args
879
880
881
882
            return $ InferTheta $ DS
                   { ds_loc = loc
                   , ds_name = dfun_name, ds_tvs = tvs
                   , ds_cls = cls, ds_tys = inst_tys
883
                   , ds_tc = rep_tc
884
                   , ds_theta = inferred_constraints
885
                   , ds_overlap = overlap_mode
886
                   , ds_newtype = Nothing }
887
888
889
890
891
        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
892
                   , ds_tc = rep_tc
893
                   , ds_theta = theta
894
                   , ds_overlap = overlap_mode
895
                   , ds_newtype = Nothing }
896
  where
897
898
    inst_ty  = mkTyConApp tycon tc_args
    inst_tys = cls_tys ++ [inst_ty]
899

900
----------------------
901

902
inferConstraints :: Class -> [TcType] -> TcType
903
                 -> TyCon -> [TcType]
904
                 -> TcM ThetaOrigin
905
906
907
908
909
910
911
912
913
914
-- inferConstraints figures out the constraints needed for the
-- instance declaration generated by a 'deriving' clause on a
-- data type declaration.
-- See Note [Inferring the instance context]

-- e.g. inferConstraints
--        C Int (T [a])    -- Class and inst_tys
--        :RTList a        -- Rep tycon and its arg tys
-- where T [a] ~R :RTList a
--
915
916
917
-- Generate a sufficiently large set of constraints that typechecking the
-- generated method definitions should succeed.   This set will be simplified
-- before being used in the instance declaration
918
919
inferConstraints main_cls cls_tys inst_ty rep_tc rep_tc_args
  | main_cls `hasKey` genClassKey    -- Generic constraints are easy
920
  = return []
921

922
923
924
  | main_cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
  = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]
    ASSERT( null cls_tys )
925
    do { functorClass <- tcLookupClass functorClassName
926
       ; return (con_arg_constraints (get_gen1_constraints functorClass)) }
927
928

  | otherwise  -- The others are a bit more complicated
929
930
931
932
  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
           , ppr main_cls <+> ppr rep_tc
             $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
    do { traceTc "inferConstraints" (vcat [ppr main_cls <+> ppr inst_tys, ppr arg_constraints])
933
934
935
       ; return (stupid_constraints ++ extra_constraints
                 ++ sc_constraints
                 ++ arg_constraints) }
936
  where
937
938
939
940
941
942
943
    (tc_binders, _) = splitPiTys (tyConKind rep_tc)
    choose_level bndr
      | isNamedBinder bndr = KindLevel
      | otherwise          = TypeLevel
    t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
       -- want to report *kind* errors when possible

944