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

5 6

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

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

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

14
#include "HsVersions.h"
15

16 17
import GhcPrelude

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

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

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

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

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

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

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

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

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

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

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

106 107
splitEarlyDerivSpec :: [EarlyDerivSpec]
                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
108 109 110 111 112
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)
113

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

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

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

We will need an instance decl like:

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

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
132
in RealFloat.
133 134 135 136 137 138 139

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

140
        Read, Enum?
141

142 143 144 145 146
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".

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

dterei's avatar
dterei committed
154
Notice the free 'a' in the deriving.  We have to fill this out to
155 156 157 158
    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
159 160


161 162
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
163 164 165
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

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


185 186 187 188 189 190
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.
191

192 193
-}

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

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

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

{-

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

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

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

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

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

244
        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
245
        ; loc <- getSrcSpanM
Sylvain Henry's avatar
Sylvain Henry committed
246 247
        ; let (binds, famInsts) = genAuxBinds dflags loc
                                    (unionManyBags deriv_stuff)
248

249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
        ; let mk_inst_infos1 = map fstOf3 insts1
        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs

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

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

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

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

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

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

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

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

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

311
renameDeriv :: Bool
312 313 314
            -> [InstInfo GhcPs]
            -> Bag (LHsBind GhcPs, LSig GhcPs)
            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
dreixel's avatar
dreixel committed
315
renameDeriv is_boot inst_infos bagBinds
316 317 318 319 320
  | 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
321
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
322

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

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

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

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

378
If you compile with -Wunused-binds you do not expect the warning
Gabor Greif's avatar
Gabor Greif committed
379
"Defined but not used: data constructor MkP". Yet the newtype deriving
380 381 382 383 384 385
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...

386
So we want to signal a user of the data constructor 'MkP'.
387
This is the reason behind the [Name] part of the return type
388
of genInst.
389

390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
Note [Staging of tcDeriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a tricky corner case for deriving (adapted from Trac #2721):

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

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

    newtype N = N Int deriving C

This will produce an instance something like this:

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

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

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

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

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

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

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

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

450 451 452 453 454 455 456 457 458 459 460 461 462 463
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.

464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488
Note [Avoid RebindableSyntax when deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The RebindableSyntax extension interacts awkwardly with the derivation of
any stock class whose methods require the use of string literals. The Show
class is a simple example (see Trac #12688):

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

  data Foo = Foo deriving Show

This will generate code to the effect of:

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

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

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

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

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

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

519
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
520
              do { unless (null eqns) (add_deriv_err (head eqns))
521
                 ; return [] }
522
          else return eqns }
523
  where
524
    add_deriv_err eqn
525
       = setSrcSpan (earlyDSLoc eqn) $
526 527
         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
528

529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584
{-
Note [Flattening deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider what happens if you run this program (from Trac #10684) without
DeriveGeneric enabled:

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

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

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

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

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

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

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

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

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

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

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

585
------------------------------------------------------------------
586
-- | Process a single class in a `deriving` clause.
Ryan Scott's avatar
Ryan Scott committed
587 588
deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)
             -> LHsSigType GhcRn -> SDoc
589 590
             -> TcM (Maybe EarlyDerivSpec)
deriveClause rep_tc mb_strat pred err_ctxt
591
  = addErrCtxt err_ctxt $
592
    deriveTyData tvs tc tys mb_strat pred
593 594 595 596 597 598 599
  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]
600

601
                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
602

603
------------------------------------------------------------------
604 605
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
-- Process a single standalone deriving declaration
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
606
--  e.g.   deriving instance Show a => Show (T a)
607
-- Rather like tcLocalInstDecl
608 609 610
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
Ryan Scott's avatar
Ryan Scott committed
611
deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
612 613
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
614
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
Ryan Scott's avatar
Ryan Scott committed
615
       ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat
616
             ctxt           = TcType.InstDeclCtxt True
Ryan Scott's avatar
Ryan Scott committed
617
       ; traceTc "Deriving strategy (standalone deriving)" $
Ryan Scott's avatar
Ryan Scott committed
618 619
           vcat [ppr mb_deriv_strat, ppr deriv_ty]
       ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))
620
           <- tcDerivStrategy ctxt mb_deriv_strat $ do
Ryan Scott's avatar
Ryan Scott committed
621
                (tvs, deriv_ctxt, cls, inst_tys)
622
                  <- tcStandaloneDerivInstType ctxt deriv_ty
Ryan Scott's avatar
Ryan Scott committed
623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645
                pure (tvs, (deriv_ctxt, cls, inst_tys))
       ; checkTc (not (null inst_tys')) derivingNullaryErr
       ; let inst_ty' = last inst_tys'
         -- See Note [Unify kinds in deriving]
       ; (tvs, deriv_ctxt, inst_tys) <-
           case mb_deriv_strat' of
             -- Perform an additional unification with the kind of the `via`
             -- type and the result of the previous kind unification.
             Just (ViaStrategy via_ty) -> do
               let via_kind     = typeKind via_ty
                   inst_ty_kind = typeKind inst_ty'
                   mb_match     = tcUnifyTy inst_ty_kind via_kind

               checkTc (isJust mb_match)
                       (derivingViaKindErr cls inst_ty_kind
                                           via_ty via_kind)

               let Just kind_subst = mb_match
                   ki_subst_range  = getTCvSubstRangeFVs kind_subst
                   -- See Note [Unification of two kind variables in deriving]
                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
                                        && not (v `elemVarSet` ki_subst_range))
                                          tvs'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
646
                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
Ryan Scott's avatar
Ryan Scott committed
647 648 649 650 651 652 653 654 655 656 657 658 659 660
                   (final_deriv_ctxt, final_deriv_ctxt_tys)
                     = case deriv_ctxt' of
                         InferContext wc -> (InferContext wc, [])
                         SupplyContext theta ->
                           let final_theta = substTheta subst theta
                           in (SupplyContext final_theta, final_theta)
                   final_inst_tys   = substTys subst inst_tys'
                   final_tvs        = tyCoVarsOfTypesWellScoped $
                                      final_deriv_ctxt_tys ++ final_inst_tys
               pure (final_tvs, final_deriv_ctxt, final_inst_tys)

             _ -> pure (tvs', deriv_ctxt', inst_tys')
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
661 662
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
Ryan Scott's avatar
Ryan Scott committed
663
              , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'
664
              , text "deriv_ctxt:" <+> ppr deriv_ctxt
665 666
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
667
                -- C.f. TcInstDcls.tcLocalInstDecl1
668 669 670 671
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
672

673
       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
Ryan Scott's avatar
Ryan Scott committed
674
                              inst_ty mb_deriv_strat' msg)
675

676
       ; case tcSplitTyConApp_maybe inst_ty of
677
           Just (tc, tc_args)
678
              | className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
679
              -> do warnUselessTypeable
680
                    return Nothing
681

682 683 684
              | otherwise
              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
                                    tvs cls cls_tys tc tc_args
Ryan Scott's avatar
Ryan Scott committed
685
                                    deriv_ctxt mb_deriv_strat'
686 687

           _  -> -- Complain about functions, primitive types, etc,
688
                 bale_out $
689
                 text "The last argument of the instance must be a data or newtype application"
690
        }
691
deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"
692

693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712
-- Typecheck the type in a standalone deriving declaration.
--
-- This may appear dense, but it's mostly huffing and puffing to recognize
-- the special case of a type with an extra-constraints wildcard context, e.g.,
--
--   deriving instance _ => Eq (Foo a)
--
-- If there is such a wildcard, we typecheck this as if we had written
-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
-- as the 'DerivContext', where loc is the location of the wildcard used for
-- error reporting. This indicates that we should infer the context as if we
-- were deriving Eq via a deriving clause
-- (see Note [Inferring the instance context] in TcDerivInfer).
--
-- If there is no wildcard, then proceed as normal, and instead return
-- @'SupplyContext' theta@, where theta is the typechecked context.
--
-- Note that this will never return @'InferContext' 'Nothing'@, as that can
-- only happen with @deriving@ clauses.
tcStandaloneDerivInstType
713
  :: UserTypeCtxt -> LHsSigWcType GhcRn
714
  -> TcM ([TyVar], DerivContext, Class, [Type])
715
tcStandaloneDerivInstType ctxt
716
    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
717 718 719 720 721
                                       , hsib_body   = deriv_ty_body })})
  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
  , L _ [wc_pred] <- theta
  , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
  = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys)
722
         <- tcHsClsInstType ctxt $
723
            HsIB { hsib_ext = vars
724 725 726
                 , hsib_body
                     = L (getLoc deriv_ty_body) $
                       HsForAllTy { hst_bndrs = tvs
727
                                  , hst_xforall = noExt
728 729 730 731
                                  , hst_body  = rho }}
       pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys)
  | otherwise
  = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys)
732
         <- tcHsClsInstType ctxt deriv_ty
733
       pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys)
734 735

tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
736
  = panic "tcStandaloneDerivInstType"
737
tcStandaloneDerivInstType _ (XHsWildCardBndrs _)
738
  = panic "tcStandaloneDerivInstType"
739

Ben Gamari's avatar
Ben Gamari committed
740 741 742
warnUselessTypeable :: TcM ()
warnUselessTypeable
  = do { warn <- woptM Opt_WarnDerivingTypeable
743
       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
744 745
                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                     text "has no effect: all types now auto-derive Typeable" }
Ben Gamari's avatar
Ben Gamari committed
746

747
------------------------------------------------------------------
748
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
749
                                             --   Can be a data instance, hence [Type] args
Ryan Scott's avatar
Ryan Scott committed
750 751
             -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy
             -> LHsSigType GhcRn             -- The deriving predicate
752
             -> TcM (Maybe EarlyDerivSpec)
dreixel's avatar
dreixel committed
753
-- The deriving clause of a data or newtype declaration
754
-- I.e. not standalone deriving
755 756 757
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
Ryan Scott's avatar
Ryan Scott committed
758
deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
759 760
  = setSrcSpan (getLoc (hsSigType deriv_pred)) $
    -- Use loc of the 'deriving' item
Ryan Scott's avatar
Ryan Scott committed
761
    do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))
762 763 764
                   -- Why not scopeTyVars? Because these are *TyVar*s, not TcTyVars.
                   -- Their kinds are fully settled. No need to worry about skolem
                   -- escape.
765
                <- tcExtendTyVarEnv tvs $
766 767
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
768 769 770
                -- 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
771
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
772 773
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
Ryan Scott's avatar
Ryan Scott committed
774 775 776
                     tcDerivStrategy TcType.DerivClauseCtxt mb_deriv_strat $
                     tcHsDeriv deriv_pred

777
        ; when (cls_arg_kinds `lengthIsNot` 1) $
778 779
            failWithTc (nonUnaryErr deriv_pred)
        ; let [cls_arg_kind] = cls_arg_kinds
780
        ; if className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
781
          then do warnUselessTypeable
782
                  return Nothing
783
          else
784

785
     do {  -- Given data T a b c = ... deriving( C d ),
786
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
787
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
788 789
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
790 791
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
792 793
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)

794 795 796 797
              -- 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
798 799 800 801 802
              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)
803

Ryan Scott's avatar
Ryan Scott committed
804 805 806 807 808 809 810 811
        ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'
                = (final_tkvs, final_cls_tys, final_tc_args)
                where
                  ki_subst_range  = getTCvSubstRangeFVs kind_subst
                  -- See Note [Unification of two kind variables in deriving]
                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
                                         && not (v `elemVarSet` ki_subst_range))
                                           tkvs'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
812
                  (subst, _)      = substTyVarBndrs kind_subst unmapped_tkvs
Ryan Scott's avatar
Ryan Scott committed
813 814 815 816 817
                  final_tc_args   = substTys subst tc_args'
                  final_cls_tys   = substTys subst cls_tys'
                  final_tkvs      = tyCoVarsOfTypesWellScoped $
                                    final_cls_tys ++ final_tc_args

Tobias Dammers's avatar
Tobias Dammers committed
818
        ; let tkvs = scopedSort $ fvVarList $
Ryan Scott's avatar
Ryan Scott committed
819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850
                     unionFV (tyCoFVsOfTypes tc_args_to_keep)
                             (FV.mkFVs deriv_tvs)
              Just kind_subst = mb_match
              (tkvs', final_cls_tys', final_tc_args')
                = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep

          -- See Note [Unify kinds in deriving]
        ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-
            case mb_deriv_strat' of
              -- Perform an additional unification with the kind of the `via`
              -- type and the result of the previous kind unification.
              Just (ViaStrategy via_ty) -> do
                let final_via_ty   = via_ty
                    final_via_kind = typeKind final_via_ty
                    final_inst_ty_kind
                              = typeKind (mkTyConApp tc final_tc_args')
                    via_match = tcUnifyTy final_inst_ty_kind final_via_kind

                checkTc (isJust via_match)
                        (derivingViaKindErr cls final_inst_ty_kind
                                            final_via_ty final_via_kind)

                let Just via_subst = via_match
                    (final_tkvs, final_cls_tys, final_tc_args)
                      = propagate_subst via_subst tkvs'
                                        final_cls_tys' final_tc_args'
                pure ( final_tkvs, final_cls_tys, final_tc_args
                     , Just $ ViaStrategy $ substTy via_subst via_ty
                     )

              _ -> pure ( tkvs', final_cls_tys', final_tc_args'
                        , mb_deriv_strat' )
851

Ryan Scott's avatar
Ryan Scott committed
852
        ; traceTc "Deriving strategy (deriving clause)" $
Ryan Scott's avatar
Ryan Scott committed
853
            vcat [ppr final_mb_deriv_strat, ppr deriv_pred]
Ryan Scott's avatar
Ryan Scott committed
854

Ben Gamari's avatar
Ben Gamari committed
855 856 857
        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args
                                       , ppr deriv_pred
                                       , pprTyVars (tyCoVarsOfTypesList tc_args)
858
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
859 860
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
861

862
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
863

864
        ; let final_tc_app = mkTyConApp tc final_tc_args
865
        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
866
                  (derivingEtaErr cls final_cls_tys final_tc_app)
867
                -- Check that
868 869
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
870 871 872 873 874
                --  (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
875
                --              newtype T a s = ... deriving( ST s )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
876
                --              newtype instance K a a = ... deriving( Monad )
877 878 879 880
                --
                -- It is vital that the implementation of allDistinctTyVars
                -- expand any type synonyms.
                -- See Note [Eta-reducing type synonyms]
881

882 883 884 885 886
        ; checkValidInstHead DerivClauseCtxt cls $
                             final_cls_tys ++ [final_tc_app]
                -- Check that we aren't deriving an instance of a magical
                -- type like (~) or Coercible (#14916).

887
        ; spec <- mkEqnHelp Nothing tkvs
Ryan Scott's avatar
Ryan Scott committed
888
                            cls final_cls_tys tc final_tc_args
Ryan Scott's avatar
Ryan Scott committed
889
                            (InferContext Nothing) final_mb_deriv_strat
890
        ; traceTc "derivTyData" (ppr spec)
891
        ; return $ Just spec } }
892

893

Austin Seipp's avatar
Austin Seipp committed
894
{-
895
Note [Unify kinds in deriving]
896 897 898 899 900 901 902 903 904
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

905 906 907 908 909 910
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
911 912
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
913 914 915 916 917 918 919 920 921

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,
922 923 924 925 926 927 928 929
 * 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:=*

930
Now we get a kind substitution.  We then need to:
931

932
  1. Remove the substituted-out kind variables from the quantified kind vars
933 934 935 936 937 938 939 940 941 942 943 944 945 946

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

950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965
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

966 967 968 969 970
But this does not typecheck by design: 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 *).
971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994

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

    data S a = S a deriving Eq

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

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

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

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

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

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

Ryan Scott's avatar
Ryan Scott committed
999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012
What happens with DerivingVia, when you have yet another type? Consider:

  newtype Foo (a :: Type) = MkFoo (Proxy a)
    deriving Functor via Proxy

As before, we unify the kind of Foo (* -> *) with the kind of the argument to
Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
(k -> *), which is more general than what we want. So we must additionally
unify (k -> *) with (* -> *).

Currently, all of this unification is implemented kludgily with the pure
unifier, which is rather tiresome. Trac #14331 lays out a plan for how this
might be made cleaner.

1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032
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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1033
    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052

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.

1053 1054 1055 1056 1057 1058 1059 1060 1061
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

1062 1063
It is also possible to define kind synonyms, and they can mention other types in
a datatype declaration. For example,
1064 1065 1066 1067 1068 1069 1070 1071 1072

  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,
1073 1074
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
1075
-}
1076

1077 1078
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
1079 1080
          -> Class -> [Type]
          -> TyCon -> [Type]
1081 1082 1083 1084
          -> DerivContext
               -- SupplyContext => context supplied (standalone deriving)
               -- InferContext  => context inferred (deriving on data decl, or
               --                  standalone deriving decl with a wildcard)
Ryan Scott's avatar
Ryan Scott committed
1085
          -> Maybe (DerivStrategy GhcTc)
1086 1087
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
1088
--      forall tvs. theta => cls (tys ++ [ty])
1089 1090 1091
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

1092
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
1093 1094 1095 1096 1097 1098
  = 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)
1099
              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
1100 1101 1102 1103
       ; is_boot <- tcIsHsBootOrSig
       ; when is_boot $
              bale_out (text "Cannot derive instances in hs-boot files"
                    $+$ text "Write an instance declaration instead")
1104

1105 1106 1107 1108 1109 1110 1111 1112 1113
       ; let deriv_env = DerivEnv
                         { denv_overlap_mode = overlap_mode
                         , denv_tvs          = tvs
                         , denv_cls          = cls
                         , denv_cls_tys      = cls_tys
                         , denv_tc           = tycon
                         , denv_tc_args      = tc_args
                         , denv_rep_tc       = rep_tc
                         , denv_rep_tc_args  = rep_tc_args
1114
                         , denv_ctxt         = deriv_ctxt
1115 1116
                         , denv_strat        = deriv_strat }
       ; flip runReaderT deriv_env $
1117
         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
1118
  where
Ryan Scott's avatar
Ryan Scott committed
1119 1120
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                      (mkTyConApp tycon tc_args) deriv_strat msg)
1121

Austin Seipp's avatar
Austin Seipp committed
1122
{-
1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138
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 ())
1139
when there is no data instance F () in scope.
1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170

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 []
1171
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
1172 1173 1174 1175 1176 1177 1178

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

1179
See Note [Eta reduction for data families] in FamInstEnv
1180

1181 1182
%************************************************************************
%*                                                                      *