TcDeriv.lhs 83.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6
7
8
%

Handles @deriving@ clauses on @data@ declarations.

\begin{code}
9
module TcDeriv ( tcDeriving ) where
10

11
#include "HsVersions.h"
12

13
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
14
import DynFlags
15

16
import TcRnMonad
17
import FamInst
18
19
import TcErrors( reportAllUnsolved )
import TcValidity( validDerivPred )
Simon Marlow's avatar
Simon Marlow committed
20
import TcEnv
21
import TcTyClsDecls( tcFamTyPats, tcAddDataFamInstCtxt )
22
23
import TcClassDcl( tcAddDeclCtxt )      -- Small helper
import TcGenDeriv                       -- Deriv stuff
24
import TcGenGenerics
Simon Marlow's avatar
Simon Marlow committed
25
26
import InstEnv
import Inst
27
import FamInstEnv
Simon Marlow's avatar
Simon Marlow committed
28
import TcHsType
29
import TcMType
Simon Marlow's avatar
Simon Marlow committed
30
import TcSimplify
31
import TcEvidence
Simon Marlow's avatar
Simon Marlow committed
32
33

import RnBinds
34
import RnEnv
35
import RnSource   ( addTcgDUs )
Simon Marlow's avatar
Simon Marlow committed
36
37
import HscTypes

38
import Id( idType )
Simon Marlow's avatar
Simon Marlow committed
39
40
import Class
import Type
41
import Kind( isKind )
Simon Marlow's avatar
Simon Marlow committed
42
43
44
45
46
47
48
49
50
51
52
import ErrUtils
import MkId
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
import VarSet
53
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
54
55
56
import SrcLoc
import Util
import ListSetOps
57
import Outputable
58
import FastString
59
import Bag
60
61

import Control.Monad
62
import Data.List
63
64
65
\end{code}

%************************************************************************
66
67
68
%*                                                                      *
                Overview
%*                                                                      *
69
70
%************************************************************************

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

2.  Infer the missing contexts for the Left DerivSpecs

3.  Add the derived bindings, generating InstInfos

80

81
82
\begin{code}
-- DerivSpec is purely  local to this module
dterei's avatar
dterei committed
83
data DerivSpec  = DS { ds_loc     :: SrcSpan
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
                     , ds_orig    :: CtOrigin
                     , ds_name    :: Name
                     , ds_tvs     :: [TyVar]
                     , ds_theta   :: ThetaType
                     , ds_cls     :: Class
                     , ds_tys     :: [Type]
                     , ds_tc      :: TyCon
                     , ds_tc_args :: [Type]
                     , ds_newtype :: Bool }
        -- 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
        --       in ds_tc, ds_tc_args is the *representation* tycon
        -- For non-family tycons, both are the same

        -- ds_newtype = True  <=> Newtype deriving
        --              False <=> Vanilla deriving
104
105
106
\end{code}

Example:
107

108
     newtype instance T [a] = MkT (Tree a) deriving( C s )
dterei's avatar
dterei committed
109
==>
110
111
112
113
114
115
116
117
     axiom T [a] = :RTList a
     axiom :RTList a = Tree a

     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
        , ds_tc = :RTList, ds_tc_args = [a]
        , ds_newtype = True }

\begin{code}
118
type DerivContext = Maybe ThetaType
119
   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
120
121
   -- Just theta <=> Standalone deriving: context supplied by programmer

122
type EarlyDerivSpec = Either DerivSpec DerivSpec
123
124
125
126
127
128
129
130
        -- Left  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)
        --                The inference process is to reduce this to a
        --                simpler form (e.g. Eq a)
        --
        -- Right ds => the exact context for the instance is supplied
        --             by the programmer; it is ds_theta
131
132

pprDerivSpec :: DerivSpec -> SDoc
dterei's avatar
dterei committed
133
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
134
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
135
  = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
136
            <+> equals <+> ppr rhs)
137
138
139

instance Outputable DerivSpec where
  ppr = pprDerivSpec
140
141
142
\end{code}


dterei's avatar
dterei committed
143
Inferring missing contexts
144
~~~~~~~~~~~~~~~~~~~~~~~~~~
145
146
Consider

147
148
149
150
        data T a b = C1 (Foo a) (Bar b)
                   | C2 Int (T b a)
                   | C3 (T a a)
                   deriving (Eq)
151

dterei's avatar
dterei committed
152
[NOTE: See end of these comments for what to do with
153
        data (C a, D b) => T a b = ...
154
155
]

156
157
We want to come up with an instance declaration of the form

158
159
        instance (Ping a, Pong b, ...) => Eq (T a b) where
                x == y = ...
160
161
162
163
164
165
166
167

It is pretty easy, albeit tedious, to fill in the code "...".  The
trick is to figure out what the context for the instance decl is,
namely @Ping@, @Pong@ and friends.

Let's call the context reqd for the T instance of class C at types
(a,b, ...)  C (T a b).  Thus:

168
        Eq (T a b) = (Ping a, Pong b, ...)
169
170
171

Now we can get a (recursive) equation from the @data@ decl:

172
173
174
        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                   u Eq (T b a) u Eq Int        -- From C2
                   u Eq (T a a)                 -- From C3
175
176
177
178
179
180
181
182
183
184
185
186
187
188

Foo and Bar may have explicit instances for @Eq@, in which case we can
just substitute for them.  Alternatively, either or both may have
their @Eq@ instances given by @deriving@ clauses, in which case they
form part of the system of equations.

Now all we need do is simplify and solve the equations, iterating to
find the least fixpoint.  Notice that the order of the arguments can
switch around, as here in the recursive calls to T.

Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.

We start with:

189
        Eq (T a b) = {}         -- The empty set
190
191

Next iteration:
192
193
194
        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                   u Eq (T b a) u Eq Int        -- From C2
                   u Eq (T a a)                 -- From C3
195

196
197
198
        After simplification:
                   = Eq a u Ping b u {} u {} u {}
                   = Eq a u Ping b
199
200
201

Next iteration:

202
203
204
        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                   u Eq (T b a) u Eq Int        -- From C2
                   u Eq (T a a)                 -- From C3
205

206
207
208
209
        After simplification:
                   = Eq a u Ping b
                   u (Eq b u Ping a)
                   u (Eq a u Ping a)
210

211
                   = Eq a u Ping b u Eq b u Ping a
212
213
214
215
216

The next iteration gives the same result, so this is the fixpoint.  We
need to make a canonical form of the RHS to ensure convergence.  We do
this by simplifying the RHS to a form in which

217
218
219
        - the classes constrain only tyvars
        - the list is sorted by tyvar (major key) and then class (minor key)
        - no duplicates, of course
220
221
222

So, here are the synonyms for the ``equation'' structures:

223

224
225
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
226
227
Consider

228
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
229
230
231

We will need an instance decl like:

232
233
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
234
235
236

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
237
in RealFloat.
238
239
240
241
242
243
244

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

245
        Read, Enum?
246

247
248
249
250
251
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".

252
253
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
254
255
256
257
258
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
259
Notice the free 'a' in the deriving.  We have to fill this out to
260
261
262
263
    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
264
265


266
267
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
268
269
270
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

271
272
273
274
275
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
276
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
277
Then the Show instance is not done via isomorphism; it shows
278
        Foo 3 as "Foo 3"
279
280
281
282
283
The Num instance is derived via isomorphism, but the Show superclass
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
284
285
        (+) = ((+)@a)
        ...etc...
286
287
288
289
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


290
291
292
293
294
295
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.
296

297
%************************************************************************
298
%*                                                                      *
299
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
300
%*                                                                      *
301
302
303
%************************************************************************

\begin{code}
304
305
tcDeriving  :: [LTyClDecl Name]  -- All type constructors
            -> [LInstDecl Name]  -- All instance declarations
306
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
307
            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
308
tcDeriving tycl_decls inst_decls deriv_decls
309
310
  = recoverM (do { g <- getGblEnv
                 ; return (g, emptyBag, emptyValBindsOut)}) $
311
312
313
314
    do  {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
          is_boot <- tcIsHsBoot
        ; traceTc "tcDeriving" (ppr is_boot)
315

316
        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
317
        ; traceTc "tcDeriving 1" (ppr early_specs)
318

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
319
320
321
322
323
        -- for each type, determine the auxliary declarations that are common
        -- to multiple derivations involving that type (e.g. Generic and
        -- Generic1 should use the same TcGenGenerics.MetaTyCons)
        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map (either id id) early_specs

324
325
326
        ; overlap_flag <- getOverlapFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
        ; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs
327

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
328
329
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
330
        ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
331
                         inferInstanceContexts overlap_flag infer_specs
332

333
        ; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
334

dreixel's avatar
dreixel committed
335
336
        ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
        ; loc <- getSrcSpanM
337
        ; let (binds, newTyCons, famInsts, extraInstances) =
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
338
339
                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))

dreixel's avatar
dreixel committed
340
341
        ; (inst_info, rn_binds, rn_dus) <-
            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
342

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
343
344
345
346
        ; dflags <- getDynFlags
        ; unless (isEmptyBag inst_info) $
            liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
                   (ddump_deriving inst_info rn_binds newTyCons famInsts))
dreixel's avatar
dreixel committed
347

Simon Peyton Jones's avatar
Simon Peyton Jones committed
348
349
350
351
352
        ; let all_tycons = map ATyCon (bagToList newTyCons)
        ; gbl_env <- tcExtendGlobalEnv all_tycons $
                     tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
                     tcExtendLocalFamInstEnv (bagToList famInsts) $
                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
353

Simon Peyton Jones's avatar
Simon Peyton Jones committed
354
        ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
355
  where
356
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
357
                   -> Bag TyCon                 -- ^ Empty data constructors
358
                   -> Bag (FamInst)             -- ^ Rep type family instances
359
                   -> SDoc
360
    ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
dreixel's avatar
dreixel committed
361
      =    hang (ptext (sLit "Derived instances:"))
362
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
363
                 $$ ppr extra_binds)
dreixel's avatar
dreixel committed
364
365
366
367
        $$ hangP "Generic representation:" (
              hangP "Generated datatypes for meta-information:"
               (vcat (map ppr (bagToList repMetaTys)))
           $$ hangP "Representation types:"
368
369
                (vcat (map pprRepTy (bagToList repFamInsts))))

370
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
371

372
-- Prints the representable type family instance
373
374
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
375
  = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
376
377
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393

-- As of 24 April 2012, this only shares MetaTyCons between derivations of
-- Generic and Generic1; thus the types and logic are quite simple.
type CommonAuxiliary = MetaTyCons
type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
commonAuxiliaries :: [DerivSpec] -> TcM (CommonAuxiliaries, BagDerivStuff)
commonAuxiliaries = foldM snoc ([], emptyBag) where
  snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
      extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
    | otherwise = return acc
   where extendComAux m -- don't run m if its already in the accumulator
           | any ((rep_tycon ==) . fst) cas = return acc
           | otherwise = do (ca, new_stuff) <- m
                            return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)

394
renameDeriv :: Bool
395
396
397
            -> [InstInfo RdrName]
            -> Bag (LHsBind RdrName, LSig RdrName)
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
398
renameDeriv is_boot inst_infos bagBinds
399
400
401
402
403
  | 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
404
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
405

406
  | otherwise
407
  = discardWarnings $         -- Discard warnings about unused bindings etc
408
    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have
409
                              --    case x of {}
410
    do  {
dreixel's avatar
dreixel committed
411
412
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
413
414
415
        ; (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
416
        ; let bndrs = collectHsValBinders rn_aux_lhs
417
418
419
420
        ; bindLocalNames bndrs $
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (LocalBindCtxt (mkNameSet bndrs)) rn_aux_lhs
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
421
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
422

423
  where
424
425
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
    rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
426
        = return ( info { iBinds = NewTypeDerived coi tc }
427
                 , mkFVs (map dataConName (tyConDataCons tc)))
428
          -- See Note [Newtype deriving and unused constructors]
429

430
    rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
431
432
433
434
        =       -- Bring the right type variables into
                -- scope (yuk), and rename the method binds
           ASSERT( null sigs )
           bindLocalNames (map Var.varName tyvars) $
435
           do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
436
              ; let binds' = VanillaInst rn_binds [] standalone_deriv
437
              ; return (inst_info { iBinds = binds' }, fvs) }
438
        where
439
          (tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
440
441
\end{code}

442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

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

If you compile with -fwarn-unused-binds you do not expect the warning
"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...

So we want to signal a user of the data constructor 'MkP'.  That's
what we do in rn_inst_info, and it's the only reason we have the TyCon
stored in NewTypeDerived.

461
462

%************************************************************************
463
464
465
%*                                                                      *
                From HsSyn to DerivSpec
%*                                                                      *
466
467
%************************************************************************

468
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
469
470

\begin{code}
471
472
473
474
475
makeDerivSpecs :: Bool
               -> [LTyClDecl Name]
               -> [LInstDecl Name]
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
476
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
477
  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl)   tycl_decls
478
479
480
        ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls
        ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls
        ; let eqns = eqns1 ++ eqns2 ++ eqns3
481
482
483
484
485
486
487
488

        -- If AutoDeriveTypeable is set, we automatically add Typeable instances
        -- for every data type and type class declared in the module
        ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable
        ; let eqns4 = if isAutoTypeable then deriveTypeable tycl_decls eqns else []
        ; eqns4' <- mapAndRecoverM deriveStandalone eqns4
        ; let eqns' = eqns ++ eqns4'

489
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
490
              do { unless (null eqns') (add_deriv_err (head eqns'))
491
                 ; return [] }
492
          else return eqns' }
493
  where
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
    deriveTypeable :: [LTyClDecl Name] -> [EarlyDerivSpec] -> [LDerivDecl Name]
    deriveTypeable tys dss =
      [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName))
                                     (L l (HsTyVar (tcdName t))))))
      | L l t <- tys
        -- Don't add Typeable instances for type synonyms and type families
      , not (isSynDecl t), not (isTypeFamilyDecl t)
        -- ... nor if the user has already given a deriving clause
      , not (hasInstance (tcdName t) dss) ]

    -- Check if an automatically generated DS for deriving Typeable should be
    -- ommitted because the user had manually requested for an instance
    hasInstance :: Name -> [EarlyDerivSpec] -> Bool
    hasInstance n = any (\ds -> n == tyConName (either ds_tc ds_tc ds))

509
    add_deriv_err eqn
510
       = setSrcSpan (either ds_loc ds_loc eqn) $
511
512
         addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
                    2 (ptext (sLit "Use an instance declaration instead")))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
513

514
515
------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
516
517
deriveTyDecl (L _ decl@(DataDecl { tcdLName = L loc tc_name
                                 , tcdDataDefn = HsDataDefn { dd_derivs = preds } }))
518
519
  = tcAddDeclCtxt decl $
    do { tc <- tcLookupTyCon tc_name
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
       ; let tvs  = tyConTyVars tc
             tys  = mkTyVarTys tvs
             pdcs :: [LDerivDecl Name]
             pdcs = [ L loc (DerivDecl (L loc (HsAppTy (noLoc (HsTyVar typeableClassName))
                                       (L loc (HsTyVar (tyConName pdc))))))
                    | Just pdc <- map promoteDataCon_maybe (tyConDataCons tc) ]
        -- If AutoDeriveTypeable and DataKinds is set, we add Typeable instances
        -- for every promoted data constructor of datatypes in this module
       ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable
       ; isDataKinds    <- xoptM Opt_DataKinds
       ; prom_dcs_Typeable_instances <- if isAutoTypeable && isDataKinds
                                        then mapM deriveStandalone pdcs
                                        else return []
       ; other_instances <- case preds of
                              Just preds' -> mapM (deriveTyData tvs tc tys) preds'
                              Nothing     -> return []
       ; return (prom_dcs_Typeable_instances ++ other_instances) }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
537

538
deriveTyDecl _ = return []
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
539

540
541
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
542
543
deriveInstDecl (L _ (TyFamInstD {})) = return []
deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
544
  = deriveFamInst fam_inst
545
deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
546
547
548
  = concatMapM (deriveFamInst . unLoc) fam_insts

------------------------------------------------------------------
549
550
551
552
deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
                                    , dfid_defn = HsDataDefn { dd_derivs = Just preds } })
  = tcAddDataFamInstCtxt decl $
553
    do { fam_tc <- tcLookupTyCon tc_name
554
555
556
       ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $
         \ tvs' pats' _ ->
           mapM (deriveTyData tvs' fam_tc pats') preds }
557
558
559
560
561
562
563
        -- Tiresomely we must figure out the "lhs", which is awkward for type families
        -- E.g.   data T a b = .. deriving( Eq )
        --          Here, the lhs is (T a b)
        --        data instance TF Int b = ... deriving( Eq )
        --          Here, the lhs is (TF Int b)
        -- But if we just look up the tycon_name, we get is the *family*
        -- tycon, but not pattern types -- they are in the *rep* tycon.
564
565

deriveFamInst _ = return []
566

567
------------------------------------------------------------------
568
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
569
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
570
--  e.g.   deriving instance Show a => Show (T a)
571
572
573
574
-- Rather like tcLocalInstDecl
deriveStandalone (L loc (DerivDecl deriv_ty))
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
575
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
dreixel's avatar
dreixel committed
576
       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
577
578
579
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
580
581
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
582
                -- C.f. TcInstDcls.tcLocalInstDecl1
583
       ; checkTc (not (null inst_tys)) derivingNullaryErr
584

585
586
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
587
588
589
590
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
591
592
       ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
                   (Just theta) }
593
594

------------------------------------------------------------------
595
596
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
             -> LHsType Name                 -- The deriving predicate
597
             -> TcM EarlyDerivSpec
dreixel's avatar
dreixel committed
598
-- The deriving clause of a data or newtype declaration
599
deriveTyData tvs tc tc_args (L loc deriv_pred)
600
601
602
603
604
605
606
607
  = setSrcSpan loc     $        -- Use the location of the 'deriving' item
    tcExtendTyVarEnv tvs $      -- Deriving preds may (now) mention
                                -- the type variables for the type constructor

    do  { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
                -- The "deriv_pred" is a LHsType to take account of the fact that for
                -- newtype deriving we allow deriving (forall a. C [a]).

608
609
                -- Typeable is special
        ; if className cls == typeableClassName
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
610
611
612
613
614
615
616
          then do {
        ; dflags <- getDynFlags
        ; case checkTypeableConditions (dflags, tc, tc_args) of
               Just err -> failWithTc (derivingThingErr False cls cls_tys
                                         (mkTyConApp tc tc_args) err)
               Nothing  -> mkEqnHelp DerivOrigin tvs cls cls_tys
                             (mkTyConApp tc (kindVarsOnly tc_args)) Nothing }
617
618
          else do {

619
620
621
        -- Given data T a b c = ... deriving( C d ),
        -- we want to drop type variables from T so that (C d (T a)) is well-kinded
        ; let cls_tyvars     = classTyVars cls
622
623
624
        ; checkTc (not (null cls_tyvars)) derivingNullaryErr

        ; let kind           = tyVarKind (last cls_tyvars)
625
626
627
628
629
630
              (arg_kinds, _) = splitKindFunTys kind
              n_args_to_drop = length arg_kinds
              n_args_to_keep = tyConArity tc - n_args_to_drop
              args_to_drop   = drop n_args_to_keep tc_args
              inst_ty        = mkTyConApp tc (take n_args_to_keep tc_args)
              inst_ty_kind   = typeKind inst_ty
631
              dropped_tvs    = tyVarsOfTypes args_to_drop
632
633
634
635
              univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
                                             `minusVarSet` dropped_tvs

        ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$
636
                     pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty)
dterei's avatar
dterei committed
637

638
639
640
641
        -- Check that the result really is well-kinded
        ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
                  (derivingKindErr tc cls cls_tys kind)

642
643
644
        ; checkTc (all isTyVarTy args_to_drop &&                         -- (a)
                   sizeVarSet dropped_tvs == n_args_to_drop &&           -- (b)
                   tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (c)
645
646
                  (derivingEtaErr cls cls_tys inst_ty)
                -- Check that
647
648
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
649
650
651
652
653
654
                --  (a) The data type can be eta-reduced; eg reject:
                --              data instance T a a = ... deriving( Monad )
                --  (b) The type class args do not mention any of the dropped type
                --      variables
                --              newtype T a s = ... deriving( ST s )

655
        ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } }
656
657
658
659
660
661
  where
    kindVarsOnly :: [Type] -> [Type]
    kindVarsOnly [] = []
    kindVarsOnly (t:ts) | Just v <- getTyVar_maybe t
                        , isKindVar v = t : kindVarsOnly ts
                        | otherwise   =     kindVarsOnly ts
662
\end{code}
663

664
665

\begin{code}
666
mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
667
668
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
669
670
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
671
--      forall tvs. theta => cls (tys ++ [ty])
672
673
674
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

675
mkEqnHelp orig tvs cls cls_tys tc_app mtheta
676
  | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
677
678
  , className cls == typeableClassName || isAlgTyCon tycon
  -- Avoid functions, primitive types, etc, unless it's Typeable
679
  = mk_alg_eqn tycon tc_args
680

681
  | otherwise
682
  = failWithTc (derivingThingErr False cls cls_tys tc_app
683
               (ptext (sLit "The last argument of the instance must be a data or newtype application")))
684
685
686
687
688

  where
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)

     mk_alg_eqn tycon tc_args
689
690
691
692
      | className cls `elem` oldTypeableClassNames
      = do { dflags <- getDynFlags
           ; case checkOldTypeableConditions (dflags, tycon, tc_args) of
               Just err -> bale_out err
693
               Nothing  -> mkOldTypeableEqn orig tvs cls tycon tc_args mtheta }
694
695

      | className cls == typeableClassName
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
696
      -- We checked for errors before, so we don't need to do that again
697
      = mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta
698
699

      | otherwise
700
      = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args
701
702
703
704
705
706
                  -- Be careful to test rep_tc here: in the case of families,
                  -- we want to check the instance tycon, not the family tycon

           -- For standalone deriving (mtheta /= Nothing),
           -- check that all the data constructors are in scope.
           ; rdr_env <- getGlobalRdrEnv
707
708
           ; let data_con_names = map dataConName (tyConDataCons rep_tc)
                 hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
709
                                    (isAbstractTyCon rep_tc ||
710
711
712
713
714
715
716
717
718
719
720
721
722
                                     any not_in_scope data_con_names)
                 not_in_scope dc  = null (lookupGRE_Name rdr_env dc)

                 -- Make a Qual RdrName that will do for each DataCon
                 -- so we can report it as used (Trac #7969)
                 data_con_rdrs = [ mkRdrQual (is_as (is_decl imp_spec)) occ
                                 | dc_name <- data_con_names
                                 , let occ  = nameOccName dc_name
                                       gres = lookupGRE_Name rdr_env dc_name
                                 , not (null gres)
                                 , Imported (imp_spec:_) <- [gre_prov (head gres)] ]

           ; addUsedRdrNames data_con_rdrs
723
724
725
726
727
728
729
730
731
732
           ; unless (isNothing mtheta || not hidden_data_cons)
                    (bale_out (derivingHiddenErr tycon))

           ; dflags <- getDynFlags
           ; if isDataTyCon rep_tc then
                mkDataTypeEqn orig dflags tvs cls cls_tys
                              tycon tc_args rep_tc rep_tc_args mtheta
             else
                mkNewTypeEqn orig dflags tvs cls cls_tys
                             tycon tc_args rep_tc rep_tc_args mtheta }
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747

     lookup_data_fam :: TyCon -> [Type] -> TcM (TyCon, [Type])
     -- Find the instance of a data family
     -- Note [Looking up family instances for deriving]
     lookup_data_fam tycon tys
       | not (isFamilyTyCon tycon)
       = return (tycon, tys)
       | otherwise
       = ASSERT( isAlgTyCon tycon )
         do { maybeFamInst <- tcLookupFamInst tycon tys
            ; case maybeFamInst of
                Nothing -> bale_out (ptext (sLit "No family instance for")
                                     <+> quotes (pprTypeApp tycon tys))
                Just (FamInstMatch { fim_instance = famInst
                                   , fim_tys      = tys })
748
                  -> let tycon' = dataFamInstRepTyCon famInst
749
                     in return (tycon', tys) }
750
751
\end{code}

752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
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 ())
768
when there is no data instance F () in scope.
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799

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 []
800
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
801
802
803
804
805
806
807
808
809

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

See Note [Eta reduction for data family axioms] in TcInstDcls.

810
811

%************************************************************************
812
813
814
%*                                                                      *
                Deriving data types
%*                                                                      *
815
816
817
%************************************************************************

\begin{code}
818
mkDataTypeEqn :: CtOrigin
819
820
821
822
              -> DynFlags
              -> [Var]                  -- Universally quantified type variables in the instance
              -> Class                  -- Class for which we need to derive an instance
              -> [Type]                 -- Other parameters to the class except the last
dterei's avatar
dterei committed
823
              -> TyCon                  -- Type constructor for which the instance is requested
824
                                        --    (last parameter to the type class)
825
826
827
              -> [Type]                 -- Parameters to the type constructor
              -> TyCon                  -- rep of the above (for type families)
              -> [Type]                 -- rep of the above
828
              -> DerivContext        -- Context of the instance, for standalone deriving
829
830
831
              -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error

mkDataTypeEqn orig dflags tvs cls cls_tys
832
              tycon tc_args rep_tc rep_tc_args mtheta
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
833
  = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
834
835
836
837
        -- NB: pass the *representation* tycon to checkSideConditions
        CanDerive               -> go_for_it
        NonDerivableClass       -> bale_out (nonStdErr cls)
        DerivableClassError msg -> bale_out msg
838
  where
839
    go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
840
    bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
841

dterei's avatar
dterei committed
842
mk_data_eqn :: CtOrigin -> [TyVar] -> Class
843
844
            -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
            -> TcM EarlyDerivSpec
845
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
846
847
848
849
850
851
852
853
854
855
856
857
  = do  { loc                  <- getSrcSpanM
        ; dfun_name            <- new_dfun_name cls tycon
        ; inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
        ; let spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs
                        , ds_cls = cls, ds_tys = inst_tys
                        , ds_tc = rep_tc, ds_tc_args = rep_tc_args
                        , ds_theta =  mtheta `orElse` inferred_constraints
                        , ds_newtype = False }

        ; return (if isJust mtheta then Right spec      -- Specified context
                                   else Left spec) }    -- Infer context
858
859
  where
    inst_tys = [mkTyConApp tycon tc_args]
860

861
----------------------
862
mkOldTypeableEqn :: CtOrigin -> [TyVar] -> Class
863
864
                    -> TyCon -> [TcType] -> DerivContext
                    -> TcM EarlyDerivSpec
865
866
867
-- The "old" (pre GHC 7.8 polykinded Typeable) deriving Typeable
-- used a horrid family of classes: Typeable, Typeable1, Typeable2, ... Typeable7
mkOldTypeableEqn orig tvs cls tycon tc_args mtheta
868
869
870
871
872
873
874
875
876
877
        -- The Typeable class is special in several ways
        --        data T a b = ... deriving( Typeable )
        -- gives
        --        instance Typeable2 T where ...
        -- Notice that:
        -- 1. There are no constraints in the instance
        -- 2. There are no type variables either
        -- 3. The actual class we want to generate isn't necessarily
        --      Typeable; it depends on the arity of the type
  | isNothing mtheta    -- deriving on a data type decl
878
  = do  { checkTc (cls `hasKey` oldTypeableClassKey)
879
                  (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
880
        ; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
881
                      -- See Note [Getting base classes]
882
        ; mkOldTypeableEqn orig tvs real_cls tycon [] (Just []) }
883

884
  | otherwise           -- standalone deriving
885
  = do  { checkTc (null tc_args)
886
                  (ptext (sLit "Derived Typeable instance must be of form (Typeable")
887
888
889
890
891
892
893
894
                        <> int (tyConArity tycon) <+> ppr tycon <> rparen)
        ; dfun_name <- new_dfun_name cls tycon
        ; loc <- getSrcSpanM
        ; return (Right $
                  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
                     , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
                     , ds_tc = tycon, ds_tc_args = []
                     , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
895

896
mkPolyKindedTypeableEqn :: CtOrigin -> [TyVar] -> Class
897
898
                        -> TyCon -> [TcType] -> DerivContext
                        -> TcM EarlyDerivSpec
899
mkPolyKindedTypeableEqn orig tvs cls tycon tc_args mtheta
900
  -- The kind-polymorphic Typeable class is less special; namely, there is no
901
902
903
904
905
906
907
  -- need to select the class with the correct kind anymore, as we only have one.
  = do  {    -- Check that we have not said, for example
             --       deriving Typeable (T Int)
             -- or    deriving Typeable (S :: * -> *)     where S is kind-polymorphic 

          polykinds <- xoptM Opt_PolyKinds
        ; checkTc (all is_kind_var tc_args) (mk_msg polykinds)
908
909
        ; dfun_name <- new_dfun_name cls tycon
        ; loc <- getSrcSpanM
910
        ; let tc_app = mkTyConApp tycon tc_args
911
        ; return (Right $
912
913
                  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name
                     , ds_tvs = filter isKindVar tvs, ds_cls = cls
914
915
                     , ds_tys = typeKind tc_app : [tc_app]
                         -- Remember, Typeable :: forall k. k -> *
916
917
918
                     , ds_tc = tycon, ds_tc_args = tc_args
                     , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
                     , ds_newtype = False })  }
919
  where
920
921
922
    is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
                           Just v  -> isKindVar v
                           Nothing -> False
923

924
925
926
927
928
929
930
931
932
    mk_msg polykinds | not polykinds
                     , all isKind tc_args   -- Non-empty, all kinds, at least one not a kind variable
                     = hang (ptext (sLit "To make a Typeable instance of poly-kinded") 
                              <+> quotes (ppr tycon) <> comma)
                          2 (ptext (sLit "use XPolyKinds"))
                     | otherwise     
                     = ptext (sLit "Derived Typeable instance must be of form") 
                       <+> parens (ptext (sLit "Typeable") <+> ppr tycon)

933
----------------------
934
inferConstraints :: Class -> [TcType]
935
                 -> TyCon -> [TcType]
936
                 -> TcM ThetaType
937
938
939
-- 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
940
941
inferConstraints cls inst_tys rep_tc rep_tc_args
  | cls `hasKey` genClassKey    -- Generic constraints are easy
942
  = return []
943
944

  | cls `hasKey` gen1ClassKey   -- Gen1 needs Functor
945
  = ASSERT(length rep_tc_tvs > 0)   -- See Note [Getting base classes]
946
947
948
949
    do { functorClass <- tcLookupClass functorClassName
       ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) }

  | otherwise  -- The others are a bit more complicated
950
  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
951
952
    return (stupid_constraints ++ extra_constraints
            ++ sc_constraints
953
            ++ con_arg_constraints cls get_std_constrained_tys)
954

955
956
  where
       -- Constraints arising from the arguments of each constructor
957
    con_arg_constraints cls' get_constrained_tys
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
958
      = [ mkClassPred cls' [arg_ty]
959
960
        | data_con <- tyConDataCons rep_tc,
          arg_ty   <- ASSERT( isVanillaDataCon data_con )
961
962
                        get_constrained_tys $
                        dataConInstOrigArgTys data_con all_rep_tc_args,
963
          not (isUnLiftedType arg_ty) ]
964
965
                -- No constraints for unlifted types
                -- See Note [Deriving and unboxed types]
966

967
968
969
970
                -- For functor-like classes, two things are different
                -- (a) We recurse over argument types to generate constraints
                --     See Functor examples in TcGenDeriv
                -- (b) The rep_tc_args will be one short
971
972
    is_functor_like = getUnique cls `elem` functorLikeClassKeys

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
973
974
    get_std_constrained_tys :: [Type] -> [Type]
    get_std_constrained_tys tys
975
        | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
976
        | otherwise       = tys
977
978
979

    rep_tc_tvs = tyConTyVars rep_tc
    last_tv = last rep_tc_tvs
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
980
981
    all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
                      = rep_tc_args ++ [mkTyVarTy last_tv]
982
                    | otherwise       = rep_tc_args
983

984
985
        -- Constraints arising from superclasses
        -- See Note [Superclasses of derived instance]
986
    sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
987
                                (classSCTheta cls)
988

989
        -- Stupid constraints
990
991
    stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
    subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
dterei's avatar
dterei committed
992

993
994
995
996
997
998
999
1000
        -- Extra Data constraints
        -- The Data class (only) requires that for
        --    instance (...) => Data (T t1 t2)
        -- IF   t1:*, t2:*
        -- THEN (Data t1, Data t2) are among the (...) constraints
        -- Reason: when the IF holds, we generate a method
        --             dataCast2 f = gcast2 f
        --         and we need the Data constraints to typecheck the method
dterei's avatar
dterei committed
1001
    extra_constraints
1002
      | cls `hasKey` dataClassKey
dterei's avatar
dterei committed
1003
      , all (isLiftedTypeKind . typeKind) rep_tc_args
1004
      = [mkClassPred cls [ty] | ty <- rep_tc_args]
dterei's avatar
dterei committed
1005
      | otherwise
1006
      = []
1007
1008
\end{code}

1009
1010
Note [Getting base classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1011
Functor and Typeable are defined in package 'base', and that is not available
1012
when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
1013
1014
ghc-prim does not use Functor or Typeable implicitly via these lookups.

1015
1016
1017
Note [Deriving and unboxed types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have some special hacks to support things like
1018
   data T = MkT Int# deriving ( Show )
1019

1020
1021
Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
(which we know how to show). It's a bit ad hoc.
1022

1023
1024

\begin{code}
1025
1026
1027
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
1028
1029
1030
1031
--
-- Here we get the representation tycon in case of family instances as it has
-- the data constructors - but we need to be careful to fall back to the
-- family tycon (with indexes) in error messages.
1032

1033
data DerivStatus = CanDerive
1034
1035
                 | DerivableClassError SDoc  -- Standard class, but can't do it
                 | NonDerivableClass         -- Non-standard class
1036

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1037
1038
1039
1040
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
                    -> TyCon -> [Type] -- tycon and its parameters
                    -> DerivStatus
checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
1041
  | Just cond <- sideConditions mtheta cls
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1042
  = case (cond (dflags, rep_tc, rep_tc_args)) of
1043
1044
1045
1046
1047
1048
        Just err -> DerivableClassError err     -- Class-specific error
        Nothing  | null cls_tys -> CanDerive    -- All derivable classes are unary, so
                                                -- cls_tys (the type args other than last)
                                                -- should be null
                 | otherwise    -> DerivableClassError ty_args_why      -- e.g. deriving( Eq s )
  | otherwise = NonDerivableClass       -- Not a standard class
1049
  where
1050
    ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
1051

1052
checkTypeableConditions, checkOldTypeableConditions :: Condition
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1053
checkTypeableConditions    = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK
1054
checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
1055

1056
1057
nonStdErr :: Class -> SDoc
nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
1058

1059
1060
sideConditions :: DerivContext -> Class -> Maybe Condition
sideConditions mtheta cls
1061
1062
1063
1064
1065
1066
1067
1068
  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
  | cls_key == dataClassKey        = Just (checkFlag Opt_DeriveDataTypeable `andCond`
1069
                                           cond_std `andCond` cond_args cls)
1070
1071
1072
1073
  | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
                                           cond_functorOK True)  -- NB: no cond_std!
  | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
                                           cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
1074
  | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
1075
                                           cond_functorOK False)
1076
  | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
dreixel's avatar
dreixel committed
1077
                                           checkFlag Opt_DeriveGeneric)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1078
1079
  | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
                                           checkFlag Opt_DeriveGeneric)
1080
1081
1082
  | otherwise = Nothing
  where
    cls_key = getUnique cls
1083
    cond_std = cond_stdOK mtheta
1084

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1085
1086
1087
1088
1089
1090
type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc
        -- first Bool is whether or not we are allowed to derive Data and Typeable
        -- second Bool is whether or not we are allowed to derive Functor
        -- TyCon is the *representation* tycon if the data type is an indexed one
        -- [Type] are the type arguments to the (representation) TyCon
        -- Nothing => OK
1091

1092
orCond :: Condition -> Condition -> Condition
dterei's avatar
dterei committed
1093
orCond c1 c2 tc
1094
  = case c1 tc of
1095
1096
1097
1098
1099
        Nothing -> Nothing          -- c1 succeeds
        Just x  -> case c2 tc of    -- c1 fails
                     Nothing -> Nothing
                     Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
                                    -- Both fail
1100

1101
andCond :: Condition -> Condition -> Condition
1102
andCond c1 c2 tc = case c1 tc of
1103
1104
                     Nothing -> c2 tc   -- c1 succeeds
                     Just x  -> Just x  -- c1 fails
1105

1106
1107
cond_stdOK :: DerivContext -> Condition
cond_stdOK (Just _) _
1108
1109
1110
  = Nothing     -- Don't check these conservative conditions for
                -- standalone deriving; just generate the code
                -- and let the typechecker handle the result
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1111
cond_stdOK Nothing (_, rep_tc, _)
1112
  | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
1113
  | not (null con_whys) = Just (vcat con_whys $$ suggestion)