TcDeriv.lhs 80.4 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
41
42
43
44
45
46
47
48
import Class
import Type
import ErrUtils
import MkId
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
49
import CoAxiom
Simon Marlow's avatar
Simon Marlow committed
50
51
52
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
358
                   -> Bag TyCon                 -- ^ Empty data constructors
                   -> Bag (FamInst Unbranched)  -- ^ 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
373
374
375
376
377
-- Prints the representable type family instance
pprRepTy :: FamInst Unbranched -> SDoc
pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
                                                                , fib_rhs = rhs }) })
  = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
      equals <+> ppr rhs 
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
394


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

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

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

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

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

443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
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.

462
463

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

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

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

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

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
496
497
498
499
500
501
502
503
504
505
506
507
508
509
    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))

510
    add_deriv_err eqn
511
       = setSrcSpan (either ds_loc ds_loc eqn) $
512
513
         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
514

515
516
------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
517
518
deriveTyDecl (L _ decl@(DataDecl { tcdLName = L loc tc_name
                                 , tcdDataDefn = HsDataDefn { dd_derivs = preds } }))
519
520
  = tcAddDeclCtxt decl $
    do { tc <- tcLookupTyCon tc_name
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
       ; 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
538

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

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

------------------------------------------------------------------
550
551
552
553
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 $
554
555
556
    do { fam_tc <- tcLookupTyCon tc_name
       ; tcFamTyPats 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

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

------------------------------------------------------------------
594
deriveTyData :: [TyVar] -> TyCon -> [Type]
595
596
             -> LHsType Name           -- The deriving predicate
             -> TcM EarlyDerivSpec
dreixel's avatar
dreixel committed
597
-- The deriving clause of a data or newtype declaration
598
deriveTyData tvs tc tc_args (L loc deriv_pred)
599
600
601
602
603
604
605
606
  = 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]).

607
608
                -- Typeable is special
        ; if className cls == typeableClassName
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
609
610
611
612
613
614
615
          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 }
616
617
          else do {

618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
        -- 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
              kind           = tyVarKind (last cls_tyvars)
              (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
              dropped_tvs    = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
              univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
                                             `minusVarSet` dropped_tvs

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

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
        -- 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)

        ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop &&           -- (a)
                   tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
                  (derivingEtaErr cls cls_tys inst_ty)
                -- Check that
                --  (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 )

        -- Type families can't be partially applied
        -- e.g.   newtype instance T Int a = MkT [a] deriving( Monad )
        -- Note [Deriving, type families, and partial applications]
        ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
                  (typeFamilyPapErr tc cls cls_tys inst_ty)

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
666
667
668
Note [Deriving, type families, and partial applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When there are no type families, it's quite easy:

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

671
672
    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
673
674
675
676
677
678

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)
679
680
    --  :CoF:R1T a :: T Int a ~ :RT a   -- Not eta reduced
    --  :Co:R1T    :: :RT ~ []          -- Eta-reduced
681

682
683
    instance Eq [a] => Eq (T Int a)     -- easy by coercion
    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
684
685
686
687

The "???" bit is that we don't build the :CoF thing in eta-reduced form
Henc the current typeFamilyPapErr, even though the instance makes sense.
After all, we can write it out
688
    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
689
      return x = MkT [x]
dterei's avatar
dterei committed
690
      ... etc ...
691
692

\begin{code}
693
mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
694
695
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
696
697
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
698
--      forall tvs. theta => cls (tys ++ [ty])
699
700
701
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

702
mkEqnHelp orig tvs cls cls_tys tc_app mtheta
703
  | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
704
705
  , className cls == typeableClassName || isAlgTyCon tycon
  -- Avoid functions, primitive types, etc, unless it's Typeable
706
  = mk_alg_eqn tycon tc_args
707
  | otherwise
708
  = failWithTc (derivingThingErr False cls cls_tys tc_app
709
               (ptext (sLit "The last argument of the instance must be a data or newtype application")))
710
711
712
713
714

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

     mk_alg_eqn tycon tc_args
715
716
717
718
      | className cls `elem` oldTypeableClassNames
      = do { dflags <- getDynFlags
           ; case checkOldTypeableConditions (dflags, tycon, tc_args) of
               Just err -> bale_out err
719
               Nothing  -> mkOldTypeableEqn orig tvs cls tycon tc_args mtheta }
720
721

      | className cls == typeableClassName
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
722
723
      -- We checked for errors before, so we don't need to do that again
      = mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta
724
725
726
727
728
729
730

      | isDataFamilyTyCon tycon
      , length tc_args /= tyConArity tycon
      = bale_out (ptext (sLit "Unsaturated data family application"))

      | otherwise
      = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
731
732
733
734
735
736
737
738
                  -- 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
           ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
                                    (isAbstractTyCon rep_tc ||
739
                                     any not_in_scope (tyConDataCons rep_tc))
740
741
742
743
744
745
746
747
748
749
750
                 not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
           ; 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 }
751
752
753
754
\end{code}


%************************************************************************
755
756
757
%*                                                                      *
                Deriving data types
%*                                                                      *
758
759
760
%************************************************************************

\begin{code}
761
mkDataTypeEqn :: CtOrigin
762
763
764
765
              -> 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
766
              -> TyCon                  -- Type constructor for which the instance is requested
767
                                        --    (last parameter to the type class)
768
769
770
              -> [Type]                 -- Parameters to the type constructor
              -> TyCon                  -- rep of the above (for type families)
              -> [Type]                 -- rep of the above
771
              -> DerivContext        -- Context of the instance, for standalone deriving
772
773
774
              -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error

mkDataTypeEqn orig dflags tvs cls cls_tys
775
              tycon tc_args rep_tc rep_tc_args mtheta
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
776
  = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of
777
778
779
780
        -- NB: pass the *representation* tycon to checkSideConditions
        CanDerive               -> go_for_it
        NonDerivableClass       -> bale_out (nonStdErr cls)
        DerivableClassError msg -> bale_out msg
781
  where
782
    go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
783
    bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
784

dterei's avatar
dterei committed
785
mk_data_eqn :: CtOrigin -> [TyVar] -> Class
786
787
            -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
            -> TcM EarlyDerivSpec
788
mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
789
790
791
792
793
794
795
796
797
798
799
800
  = 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
801
802
  where
    inst_tys = [mkTyConApp tycon tc_args]
803

804
----------------------
805
mkOldTypeableEqn :: CtOrigin -> [TyVar] -> Class
806
807
                    -> TyCon -> [TcType] -> DerivContext
                    -> TcM EarlyDerivSpec
808
809
810
-- 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
811
812
813
814
815
816
817
818
819
820
        -- 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
821
  = do  { checkTc (cls `hasKey` oldTypeableClassKey)
822
                  (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
823
        ; real_cls <- tcLookupClass (oldTypeableClassNames `getNth` tyConArity tycon)
824
                      -- See Note [Getting base classes]
825
        ; mkOldTypeableEqn orig tvs real_cls tycon [] (Just []) }
826

827
  | otherwise           -- standalone deriving
828
829
830
831
832
833
834
835
836
837
  = do  { checkTc (null tc_args)
                  (ptext (sLit "Derived typeable instance must be of form (Typeable")
                        <> 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 })  }
838

839
840
841
842
mkPolyKindedTypeableEqn :: CtOrigin -> [TyVar] -> Class -> [TcType]
                        -> TyCon -> [TcType] -> DerivContext
                        -> TcM EarlyDerivSpec
mkPolyKindedTypeableEqn orig tvs cls _cls_tys tycon tc_args mtheta
843
844
  -- The kind-polymorphic Typeable class is less special; namely, there is no
  -- need to select the class with the right kind anymore, as we only have one.
845
  = do  { checkTc (all is_kind_var tc_args)
846
847
848
849
                  (ptext (sLit "Derived typeable instance must be of form (Typeable")
                        <+> ppr tycon <> rparen)
        ; dfun_name <- new_dfun_name cls tycon
        ; loc <- getSrcSpanM
850
        ; let tc_app = mkTyConApp tycon tc_args
851
        ; return (Right $
852
853
                  DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name
                     , ds_tvs = filter isKindVar tvs, ds_cls = cls
854
855
                     , ds_tys = typeKind tc_app : [tc_app]
                         -- Remember, Typeable :: forall k. k -> *
856
857
858
                     , ds_tc = tycon, ds_tc_args = tc_args
                     , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
                     , ds_newtype = False })  }
859
860
861
862
  where 
    is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
                           Just v  -> isKindVar v
                           Nothing -> False
863

864
----------------------
865
inferConstraints :: Class -> [TcType]
866
                 -> TyCon -> [TcType]
867
                 -> TcM ThetaType
868
869
870
-- 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
871
872
inferConstraints cls inst_tys rep_tc rep_tc_args
  | cls `hasKey` genClassKey    -- Generic constraints are easy
873
  = return []
874
875
876
877
878
879
880

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

  | otherwise  -- The others are a bit more complicated
881
  = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
882
883
    return (stupid_constraints ++ extra_constraints
            ++ sc_constraints
884
            ++ con_arg_constraints cls get_std_constrained_tys)
885

886
887
  where
       -- Constraints arising from the arguments of each constructor
888
    con_arg_constraints cls' get_constrained_tys
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
889
      = [ mkClassPred cls' [arg_ty]
890
891
        | data_con <- tyConDataCons rep_tc,
          arg_ty   <- ASSERT( isVanillaDataCon data_con )
892
893
                        get_constrained_tys $
                        dataConInstOrigArgTys data_con all_rep_tc_args,
894
          not (isUnLiftedType arg_ty) ]
895
896
                -- No constraints for unlifted types
                -- See Note [Deriving and unboxed types]
897

898
899
900
901
                -- 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
902
903
    is_functor_like = getUnique cls `elem` functorLikeClassKeys

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
904
905
    get_std_constrained_tys :: [Type] -> [Type]
    get_std_constrained_tys tys
906
        | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
907
        | otherwise       = tys
908
909
910

    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
911
912
    all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
                      = rep_tc_args ++ [mkTyVarTy last_tv]
913
                    | otherwise       = rep_tc_args
914

915
916
        -- Constraints arising from superclasses
        -- See Note [Superclasses of derived instance]
917
    sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
918
                                (classSCTheta cls)
919

920
        -- Stupid constraints
921
922
    stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
    subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
dterei's avatar
dterei committed
923

924
925
926
927
928
929
930
931
        -- 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
932
    extra_constraints
933
      | cls `hasKey` dataClassKey
dterei's avatar
dterei committed
934
      , all (isLiftedTypeKind . typeKind) rep_tc_args
935
      = [mkClassPred cls [ty] | ty <- rep_tc_args]
dterei's avatar
dterei committed
936
      | otherwise
937
      = []
938
939
\end{code}

940
941
Note [Getting base classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
942
Functor and Typeable are defined in package 'base', and that is not available
943
when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
944
945
ghc-prim does not use Functor or Typeable implicitly via these lookups.

946
947
948
949
950
951
952
953
954
955
956
957
958
Note [Deriving and unboxed types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have some special hacks to support things like
   data T = MkT Int# deriving( Ord, Show )

Specifically
  * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
    (which we know how to show)

  * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
    on some primitive types

It's all a bit ad hoc.
959

960
961

\begin{code}
962
963
964
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
965
966
967
968
--
-- 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.
969

970
data DerivStatus = CanDerive
971
972
                 | DerivableClassError SDoc  -- Standard class, but can't do it
                 | NonDerivableClass         -- Non-standard class
973

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
974
975
976
977
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
                    -> TyCon -> [Type] -- tycon and its parameters
                    -> DerivStatus
checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args
978
  | Just cond <- sideConditions mtheta cls
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
979
  = case (cond (dflags, rep_tc, rep_tc_args)) of
980
981
982
983
984
985
        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
986
  where
987
    ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
988

989
checkTypeableConditions, checkOldTypeableConditions :: Condition
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
990
checkTypeableConditions    = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK
991
checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK
992

993
994
nonStdErr :: Class -> SDoc
nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
995

996
997
sideConditions :: DerivContext -> Class -> Maybe Condition
sideConditions mtheta cls
998
999
1000
1001
1002
1003
1004
1005
  | 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`
1006
                                           cond_std `andCond` cond_args cls)
1007
1008
1009
1010
  | 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
1011
  | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
1012
                                           cond_functorOK False)
1013
  | cls_key == genClassKey         = Just (cond_RepresentableOk `andCond`
dreixel's avatar
dreixel committed
1014
                                           checkFlag Opt_DeriveGeneric)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1015
1016
  | cls_key == gen1ClassKey        = Just (cond_Representable1Ok `andCond`
                                           checkFlag Opt_DeriveGeneric)
1017
1018
1019
  | otherwise = Nothing
  where
    cls_key = getUnique cls
1020
    cond_std = cond_stdOK mtheta
1021

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1022
1023
1024
1025
1026
1027
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
1028

1029
orCond :: Condition -> Condition -> Condition
dterei's avatar
dterei committed
1030
orCond c1 c2 tc
1031
  = case c1 tc of
1032
1033
1034
1035
1036
        Nothing -> Nothing          -- c1 succeeds
        Just x  -> case c2 tc of    -- c1 fails
                     Nothing -> Nothing
                     Just y  -> Just (x $$ ptext (sLit "  or") $$ y)
                                    -- Both fail
1037

1038
andCond :: Condition -> Condition -> Condition
1039
andCond c1 c2 tc = case c1 tc of
1040
1041
                     Nothing -> c2 tc   -- c1 succeeds
                     Just x  -> Just x  -- c1 fails
1042

1043
1044
cond_stdOK :: DerivContext -> Condition
cond_stdOK (Just _) _
1045
1046
1047
  = 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
1048
cond_stdOK Nothing (_, rep_tc, _)
1049
  | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
1050
  | not (null con_whys) = Just (vcat con_whys $$ suggestion)
1051
  | otherwise           = Nothing
1052
  where
1053
1054
    suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
    data_cons   = tyConDataCons rep_tc
1055
1056
1057
    con_whys = mapCatMaybes check_con data_cons

    check_con :: DataCon -> Maybe SDoc
dterei's avatar
dterei committed
1058
    check_con con
1059
1060
      | isVanillaDataCon con
      , all isTauTy (dataConOrigArgTys con) = Nothing
1061
      | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
dterei's avatar
dterei committed
1062

1063
no_cons_why :: TyCon -> SDoc
dterei's avatar
dterei committed
1064
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
1065
                     ptext (sLit "must have at least one data constructor")
1066

1067
cond_RepresentableOk :: Condition
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1068
1069
1070
1071
cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args

cond_Representable1Ok :: Condition
cond_Representable1Ok (_, tc, tc_args) = canDoGenerics1 tc tc_args
1072

1073
cond_enumOrProduct :: Class -> Condition
dterei's avatar
dterei committed
1074
cond_enumOrProduct cls = cond_isEnumeration `orCond`
1075
                         (cond_isProduct `andCond` cond_args cls)
1076

1077
cond_args :: Class -> Condition
1078
1079
-- For some classes (eg Eq, Ord) we allow unlifted arg types
-- by generating specilaised code.  For others (eg Data) we don't.
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1080
cond_args cls (_, tc, _)
dterei's avatar
dterei committed
1081
  = case bad_args of
1082
1083
1084
      []      -> Nothing
      (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
                         2 (ptext (sLit "for type") <+> quotes (ppr ty)))
1085
  where
1086
    bad_args = [ arg_ty | con <- tyConDataCons tc
1087
1088
1089
                        , arg_ty <- dataConOrigArgTys con
                        , isUnLiftedType arg_ty
                        , not (ok_ty arg_ty) ]
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100

    cls_key = classKey cls
    ok_ty arg_ty
     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
     | cls_key == showClassKey = check_in arg_ty boxConTbl
     | otherwise               = False    -- Read, Ix etc

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

1101

1102
cond_isEnumeration :: Condition
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
1103
cond_isEnumeration (_, rep_tc, _)
1104
1105
  | isEnumerationTyCon rep_tc = Nothing
  | o