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

5 6

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

9 10
{-# LANGUAGE CPP #-}

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

13
#include "HsVersions.h"
14

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

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

32
import RnNames( extendGlobalRdrEnvRn )
Simon Marlow's avatar
Simon Marlow committed
33
import RnBinds
34
import RnEnv
35
import RnSource   ( addTcgDUs )
36
import Avail
Simon Marlow's avatar
Simon Marlow committed
37

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

import Control.Monad
64
import Data.List
65

Austin Seipp's avatar
Austin Seipp committed
66 67 68
{-
************************************************************************
*                                                                      *
69
                Overview
Austin Seipp's avatar
Austin Seipp committed
70 71
*                                                                      *
************************************************************************
72

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

78
2.  Infer the missing contexts for the InferTheta's
79 80

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

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

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

splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta spec : specs) =
    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
splitEarlyDerivSpec (GivenTheta spec : specs) =
    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
106

107
instance Outputable EarlyDerivSpec where
108 109
  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
110

Ryan Scott's avatar
Ryan Scott committed
111
{-
112 113
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
114 115
Consider

116
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
117 118 119

We will need an instance decl like:

120 121
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
122 123 124

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
125
in RealFloat.
126 127 128 129 130 131 132

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

133
        Read, Enum?
134

135 136 137 138 139
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".

140 141
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
142 143 144 145 146
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
147
Notice the free 'a' in the deriving.  We have to fill this out to
148 149 150 151
    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
152 153


154 155
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
156 157 158
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

159 160 161 162 163
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
164
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
165
Then the Show instance is not done via Coercible; it shows
166
        Foo 3 as "Foo 3"
167
The Num instance is derived via Coercible, but the Show superclass
168 169 170 171
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
172 173
        (+) = ((+)@a)
        ...etc...
174 175 176 177
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


178 179 180 181 182 183
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.
184

185 186
-}

Ryan Scott's avatar
Ryan Scott committed
187 188
-- | Stuff needed to process a datatype's `deriving` clauses
data DerivInfo = DerivInfo { di_rep_tc  :: TyCon
189 190
                             -- ^ The data tycon for normal datatypes,
                             -- or the *representation* tycon for data families
Ryan Scott's avatar
Ryan Scott committed
191 192
                           , di_clauses :: [LHsDerivingClause Name]
                           , di_ctxt    :: SDoc -- ^ error context
193 194 195
                           }

-- | Extract `deriving` clauses of proper data type (skips data families)
196 197
mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo]
mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
198 199 200 201
  where

    mk_deriv decl@(DataDecl { tcdLName = L _ data_name
                            , tcdDataDefn =
Ryan Scott's avatar
Ryan Scott committed
202
                                HsDataDefn { dd_derivs = L _ clauses } })
203
      = do { tycon <- tcLookupTyCon data_name
Ryan Scott's avatar
Ryan Scott committed
204
           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses
205 206 207 208 209
                               , di_ctxt = tcMkDeclCtxt decl }] }
    mk_deriv _ = return []

{-

Austin Seipp's avatar
Austin Seipp committed
210 211
************************************************************************
*                                                                      *
212
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
213 214 215
*                                                                      *
************************************************************************
-}
216

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

228
        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
229
        ; traceTc "tcDeriving 1" (ppr early_specs)
230

231
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
232
        ; insts1 <- mapM genInst given_specs
233

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
234 235
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
236
        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
237
                         simplifyInstanceContexts infer_specs
238

239
        ; insts2 <- mapM genInst final_specs
240

241
        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
242
        ; loc <- getSrcSpanM
243
        ; let (binds, famInsts) = genAuxBinds loc (unionManyBags deriv_stuff)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
244

245 246
        ; dflags <- getDynFlags

dreixel's avatar
dreixel committed
247
        ; (inst_info, rn_binds, rn_dus) <-
248
            renameDeriv is_boot inst_infos binds
249

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
250
        ; unless (isEmptyBag inst_info) $
251
             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
252
                        (ddump_deriving inst_info rn_binds famInsts))
dreixel's avatar
dreixel committed
253

254
        ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
255
                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
niteria's avatar
niteria committed
256
        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs)
257
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
258
  where
259
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
260
                   -> Bag FamInst             -- ^ Rep type family instances
261
                   -> SDoc
262
    ddump_deriving inst_infos extra_binds repFamInsts
263
      =    hang (text "Derived instances:")
264
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
265
                 $$ ppr extra_binds)
266 267
        $$ hangP "GHC.Generics representation types:"
             (vcat (map pprRepTy (bagToList repFamInsts)))
268

269
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
270

271
-- Prints the representable type family instance
272 273
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
274
  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
275 276
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
277

278
renameDeriv :: Bool
279
            -> [InstInfo RdrName]
280
            -> Bag (LHsBind RdrName, LSig RdrName)
281
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
282
renameDeriv is_boot inst_infos bagBinds
283 284 285 286 287
  | 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
288
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
289

290
  | otherwise
291
  = discardWarnings $         -- Discard warnings about unused bindings etc
292 293 294 295
    setXOptM LangExt.EmptyCase $  -- Derived decls (for empty types) can have
                                  --    case x of {}
    setXOptM LangExt.ScopedTypeVariables $  -- Derived decls (for newtype-deriving) can
    setXOptM LangExt.KindSignatures $       -- used ScopedTypeVariables & KindSignatures
296
    do  {
dreixel's avatar
dreixel committed
297 298
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
299
        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
300 301 302
        ; (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
303
        ; let bndrs = collectHsValBinders rn_aux_lhs
304
        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
305
        ; setEnvs envs $
306
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
307 308
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
309
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
310

311
  where
312
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
313 314 315 316
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
317
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
318
                            , ib_pragmas = sigs
319
                            , ib_extensions = exts -- Only for type-checking
320
                            , ib_derived = sa } })
321 322
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
323
           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
324
              ; let binds' = InstBindings { ib_binds = rn_binds
325 326 327 328
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
329
              ; return (inst_info { iBinds = binds' }, fvs) }
330

Austin Seipp's avatar
Austin Seipp committed
331
{-
332 333 334 335 336 337 338
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

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

339
If you compile with -Wunused-binds you do not expect the warning
340 341 342 343 344 345 346
"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...

347 348 349
So we want to signal a user of the data constructor 'MkP'.
This is the reason behind the (Maybe Name) part of the return type
of genInst.
350

351 352 353 354 355 356 357 358 359 360 361 362 363 364
Note [Why we don't pass rep_tc into deriveTyData]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
the rep_tc by means of a lookup. And yet we have the rep_tc right here!
Why look it up again? Answer: it's just easier this way.
We drop some number of arguments from the end of the datatype definition
in deriveTyData. The arguments are dropped from the fam_tc.
This action may drop a *different* number of arguments
passed to the rep_tc, depending on how many free variables, etc., the
dropped patterns have.

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

Austin Seipp's avatar
Austin Seipp committed
365 366
************************************************************************
*                                                                      *
367
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
368 369
*                                                                      *
************************************************************************
370

371
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
372
-}
373

374
makeDerivSpecs :: Bool
375
               -> [DerivInfo]
376 377
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
378 379 380 381
makeDerivSpecs is_boot deriv_infos deriv_decls
  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo)  deriv_infos
        ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
        ; let eqns = eqns1 ++ eqns2
382

383
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
384
              do { unless (null eqns) (add_deriv_err (head eqns))
385
                 ; return [] }
386
          else return eqns }
387
  where
388
    add_deriv_err eqn
389
       = setSrcSpan (earlyDSLoc eqn) $
390 391
         addErr (hang (text "Deriving not permitted in hs-boot file")
                    2 (text "Use an instance declaration instead"))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
392

393
------------------------------------------------------------------
394 395
-- | Process a `deriving` clause
deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
Ryan Scott's avatar
Ryan Scott committed
396
deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
397 398
                           , di_ctxt = err_ctxt })
  = addErrCtxt err_ctxt $
Ryan Scott's avatar
Ryan Scott committed
399
    concatMapM (deriveForClause . unLoc) clauses
400 401 402 403 404 405 406
  where
    tvs = tyConTyVars rep_tc
    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
                        -- data family:
                  Just (fam_tc, pats, _) -> (fam_tc, pats)
      -- NB: deriveTyData wants the *user-specified*
      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
407

408
                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
409

Ryan Scott's avatar
Ryan Scott committed
410 411 412 413 414
    deriveForClause :: HsDerivingClause Name -> TcM [EarlyDerivSpec]
    deriveForClause (HsDerivingClause { deriv_clause_strategy = dcs
                                      , deriv_clause_tys      = L _ preds })
      = concatMapM (deriveTyData tvs tc tys (fmap unLoc dcs)) preds

415
------------------------------------------------------------------
416
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
417
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
418
--  e.g.   deriving instance Show a => Show (T a)
419
-- Rather like tcLocalInstDecl
Ryan Scott's avatar
Ryan Scott committed
420
deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
421 422
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
423
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
Ryan Scott's avatar
Ryan Scott committed
424 425 426
       ; let deriv_strat = fmap unLoc deriv_strat'
       ; traceTc "Deriving strategy (standalone deriving)" $
           vcat [ppr deriv_strat, ppr deriv_ty]
427
       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
428 429 430
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
431 432
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
433
                -- C.f. TcInstDcls.tcLocalInstDecl1
434
       ; checkTc (not (null inst_tys)) derivingNullaryErr
435

436 437
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
438 439 440 441
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
442

443 444 445
       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                              inst_ty deriv_strat msg)

446
       ; case tcSplitTyConApp_maybe inst_ty of
447
           Just (tc, tc_args)
448
              | className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
449
              -> do warnUselessTypeable
450
                    return []
451

452 453 454 455 456 457
              | isUnboxedTupleTyCon tc
              -> bale_out $ unboxedTyConErr "tuple"

              | isUnboxedSumTyCon tc
              -> bale_out $ unboxedTyConErr "sum"

Ben Gamari's avatar
Ben Gamari committed
458
              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
459
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
460
                                        tvs cls cls_tys tc tc_args
Ryan Scott's avatar
Ryan Scott committed
461
                                        (Just theta) deriv_strat
462
                    ; return [spec] }
463 464

           _  -> -- Complain about functions, primitive types, etc,
465
                 bale_out $
466
                 text "The last argument of the instance must be a data or newtype application"
467
        }
468

Ben Gamari's avatar
Ben Gamari committed
469 470 471
warnUselessTypeable :: TcM ()
warnUselessTypeable
  = do { warn <- woptM Opt_WarnDerivingTypeable
472
       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
473 474
                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                     text "has no effect: all types now auto-derive Typeable" }
Ben Gamari's avatar
Ben Gamari committed
475

476
------------------------------------------------------------------
477
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
478
                                             --   Can be a data instance, hence [Type] args
Ryan Scott's avatar
Ryan Scott committed
479
             -> Maybe DerivStrategy          -- The optional deriving strategy
480
             -> LHsSigType Name              -- The deriving predicate
481
             -> TcM [EarlyDerivSpec]
dreixel's avatar
dreixel committed
482
-- The deriving clause of a data or newtype declaration
483
-- I.e. not standalone deriving
Ryan Scott's avatar
Ryan Scott committed
484
deriveTyData tvs tc tc_args deriv_strat deriv_pred
485
  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
486
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
487 488
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
489 490
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
491 492 493
                -- The "deriv_pred" is a LHsType to take account of the fact that for
                -- newtype deriving we allow deriving (forall a. C [a]).

Gabor Greif's avatar
Gabor Greif committed
494
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
495 496
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
497 498 499
        ; when (length cls_arg_kinds /= 1) $
            failWithTc (nonUnaryErr deriv_pred)
        ; let [cls_arg_kind] = cls_arg_kinds
500
        ; if className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
501
          then do warnUselessTypeable
502
                  return []
503
          else
504

505
     do {  -- Given data T a b c = ... deriving( C d ),
506
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
507
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
508 509
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
510 511
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
512 513
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)

514 515 516 517
              -- Match up the kinds, and apply the resulting kind substitution
              -- to the types.  See Note [Unify kinds in deriving]
              -- We are assuming the tycon tyvars and the class tyvars are distinct
              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind
Ryan Scott's avatar
Ryan Scott committed
518 519 520 521 522
              enough_args     = n_args_to_keep >= 0

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

Ryan Scott's avatar
Ryan Scott committed
524 525
        ; let Just kind_subst = mb_match
              ki_subst_range  = getTCvSubstRangeFVs kind_subst
526
              all_tkvs        = toposortTyVars $
niteria's avatar
niteria committed
527 528 529
                                fvVarList $ unionFV
                                  (tyCoFVsOfTypes tc_args_to_keep)
                                  (FV.mkFVs deriv_tvs)
530 531 532 533 534
              -- See Note [Unification of two kind variables in deriving]
              unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
                                      && not (v `elemVarSet` ki_subst_range))
                                       all_tkvs
              (subst, _)      = mapAccumL substTyVarBndr
535 536 537
                                          kind_subst unmapped_tkvs
              final_tc_args   = substTys subst tc_args_to_keep
              final_cls_tys   = substTys subst cls_tys
538 539
              tkvs            = tyCoVarsOfTypesWellScoped $
                                final_cls_tys ++ final_tc_args
540

Ryan Scott's avatar
Ryan Scott committed
541 542 543
        ; traceTc "Deriving strategy (deriving clause)" $
            vcat [ppr deriv_strat, ppr deriv_pred]

Simon Peyton Jones's avatar
Simon Peyton Jones committed
544
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
545
                                       , pprTvBndrs (tyCoVarsOfTypesList tc_args)
546
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
547 548
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
549

550
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
551

552
        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
553
                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
554
                -- Check that
555 556
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
557 558 559 560 561
                --  (b) The args to drop are all *distinct* type variables; eg reject:
                --              class C (a :: * -> * -> *) where ...
                --              data instance T a a = ... deriving( C )
                --  (c) The type class args, or remaining tycon args,
                --      do not mention any of the dropped type variables
562
                --              newtype T a s = ... deriving( ST s )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
563
                --              newtype instance K a a = ... deriving( Monad )
Ryan Scott's avatar
Ryan Scott committed
564 565 566 567
                --
                -- It is vital that the implementation of allDistinctTyVars
                -- expand any type synonyms.
                -- See Note [Eta-reducing type synonyms]
568

569
        ; spec <- mkEqnHelp Nothing tkvs
Ryan Scott's avatar
Ryan Scott committed
570 571
                            cls final_cls_tys tc final_tc_args
                            Nothing deriv_strat
572
        ; traceTc "derivTyData" (ppr spec)
573
        ; return [spec] } }
574

575

Austin Seipp's avatar
Austin Seipp committed
576
{-
577
Note [Unify kinds in deriving]
578 579 580 581 582 583 584 585 586
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (Trac #8534)
    data T a b = MkT a deriving( Functor )
    -- where Functor :: (*->*) -> Constraint

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

587 588 589 590 591 592
Moreover, as well as instantiating T's kind arguments, we may need to instantiate
C's kind args.  Consider (Trac #8865):
  newtype T a b = MkT (Either a b) deriving( Category )
where
  Category :: forall k. (k -> k -> *) -> Constraint
We need to generate the instance
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
593 594
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
595 596 597 598 599 600 601 602 603

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

In the two examples,
604 605 606 607 608 609 610 611
 * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )
         i.e.      (k -> *) ~ (* -> *)   to find k:=*.
         yielding  k:=*

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

612
Now we get a kind substitution.  We then need to:
613

614
  1. Remove the substituted-out kind variables from the quantified kind vars
615 616 617 618 619 620 621 622 623 624 625 626 627 628

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

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

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

When deriving Functor for P, we unify k to *, but we then want
an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
629
and similarly for C.  Notice the modified kind of x, both at binding
630
and occurrence sites.
631

632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680
This can lead to some surprising results when *visible* kind binder is
unified (in contrast to the above examples, in which only non-visible kind
binders were considered). Consider this example from Trac #11732:

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

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

    instance Functor (T *) where ...

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

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

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

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

    data S a = S a deriving Eq

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

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

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

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

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

Even though we requested an derived instance of the form (Cat k Fun), the
kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
the user wrote deriving (Cat *)).

681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720
Note [Unification of two kind variables in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As a special case of the Note above, it is possible to derive an instance of
a poly-kinded typeclass for a poly-kinded datatype. For example:

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

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

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

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

We used to accomplish this by doing the following:

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

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

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

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

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

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

721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740
Note [Eta-reducing type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One can instantiate a type in a data family instance with a type synonym that
mentions other type variables:

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

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

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

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

745 746
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
747 748
          -> Class -> [Type]
          -> TyCon -> [Type]
749 750
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
Ryan Scott's avatar
Ryan Scott committed
751
          -> Maybe DerivStrategy
752 753
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
754
--      forall tvs. theta => cls (tys ++ [ty])
755 756 757
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

Ryan Scott's avatar
Ryan Scott committed
758
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
759 760 761 762 763 764
  = do {      -- Find the instance of a data family
              -- Note [Looking up family instances for deriving]
         fam_envs <- tcGetFamInstEnvs
       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
              -- If it's still a data family, the lookup failed; i.e no instance exists
       ; when (isDataFamilyTyCon rep_tc)
765
              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
766 767 768

       ; dflags <- getDynFlags
       ; if isDataTyCon rep_tc then
769
            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
Ryan Scott's avatar
Ryan Scott committed
770
                          tycon tc_args rep_tc rep_tc_args mtheta deriv_strat
771
         else
772
            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
Ryan Scott's avatar
Ryan Scott committed
773
                         tycon tc_args rep_tc rep_tc_args mtheta deriv_strat }
774
  where
Ryan Scott's avatar
Ryan Scott committed
775 776
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                      (mkTyConApp tycon tc_args) deriv_strat msg)
777

Austin Seipp's avatar
Austin Seipp committed
778
{-
779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794
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 ())
795
when there is no data instance F () in scope.
796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826

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

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

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

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

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

860
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
Ryan Scott's avatar
Ryan Scott committed
861 862 863 864 865 866 867 868 869 870
              tycon tc_args rep_tc rep_tc_args mtheta deriv_strat
  = case deriv_strat of
      Just DerivStock -> mk_eqn_stock dflags mtheta cls cls_tys rep_tc
                           go_for_it bale_out
      Just DerivAnyclass -> mk_eqn_anyclass dflags rep_tc cls
                              go_for_it bale_out
      -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
      Just DerivNewtype -> bale_out gndNonNewtypeErr
      -- Lacking a user-requested deriving strategy, we will try to pick
      -- between the stock or anyclass strategies
871
      Nothing -> mk_eqn_no_mechanism dflags tycon mtheta cls cls_tys rep_tc
Ryan Scott's avatar
Ryan Scott committed
872
                   go_for_it bale_out
873
  where
874 875
    go_for_it    = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args
                     rep_tc rep_tc_args mtheta (isJust deriv_strat)
Ryan Scott's avatar
Ryan Scott committed
876 877
    bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                     (mkTyConApp tycon tc_args) deriv_strat msg)
878

879
mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
880
            -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
881 882
            -> Bool -- True if an explicit deriving strategy keyword was
                    -- provided
Ryan Scott's avatar
Ryan Scott committed
883 884 885
            -> DerivSpecMechanism -- How GHC should proceed attempting to
                                  -- derive this instance, determined in
                                  -- mkDataTypeEqn/mkNewTypeEqn
886
            -> TcM EarlyDerivSpec
Ryan Scott's avatar
Ryan Scott committed
887
mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
888 889 890 891
            mtheta strat_used mechanism
  = do doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tc mtheta
                               strat_used mechanism
       loc                  <- getSrcSpanM
892
       dfun_name            <- newDFunName' cls tycon
893
       case mtheta