TcDeriv.hs 103 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 ImplicitParams #-}
11

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

14
#include "HsVersions.h"
15

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

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

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

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

import Control.Monad
67
import Data.List
68

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

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

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

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

-- DerivSpec is purely  local to this module
87
data DerivSpec theta = DS { ds_loc     :: SrcSpan
88
                          , ds_name    :: Name           -- DFun name
89 90 91 92 93
                          , ds_tvs     :: [TyVar]
                          , ds_theta   :: theta
                          , ds_cls     :: Class
                          , ds_tys     :: [Type]
                          , ds_tc      :: TyCon
94
                          , ds_overlap :: Maybe OverlapMode
95
                          , ds_newtype :: Maybe Type }  -- The newtype rep type
96 97 98 99 100 101
        -- This spec implies a dfun declaration of the form
        --       df :: forall tvs. theta => C tys
        -- The Name is the name for the DFun we'll build
        -- The tyvars bind all the variables in the theta
        -- For type families, the tycon in
        --       in ds_tys is the *family* tycon
102
        --       in ds_tc is the *representation* type
103 104
        -- For non-family tycons, both are the same

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

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

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

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

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

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

127 128
-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
-- and whether or the constraint deals in types or kinds.
129
data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
130 131
type ThetaOrigin = [PredOrigin]

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

135 136
mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
137

Ben Gamari's avatar
Ben Gamari committed
138
substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
139 140 141
substPredOrigin subst (PredOrigin pred origin t_or_k)
  = PredOrigin (substTy subst pred) origin t_or_k

Ben Gamari's avatar
Ben Gamari committed
142
substThetaOrigin :: HasCallStack => TCvSubst -> ThetaOrigin -> ThetaOrigin
143 144
substThetaOrigin subst = map (substPredOrigin subst)

145 146 147 148 149 150
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.
151 152
        --      The inference process is to reduce this to a
        --      simpler form (e.g. Eq a)
153
        --
154 155
        -- GivenTheta ds => the exact context for the instance is supplied
        --                  by the programmer; it is ds_theta
156
        -- See Note [Inferring the instance context]
157 158 159 160 161 162 163 164 165 166 167

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

169
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
dterei's avatar
dterei committed
170
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
171
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
172 173 174 175 176 177 178
  = hang (text "DerivSpec")
       2 (vcat [ text "ds_loc   =" <+> ppr l
               , text "ds_name  =" <+> ppr n
               , text "ds_tvs   =" <+> ppr tvs
               , text "ds_cls   =" <+> ppr c
               , text "ds_tys   =" <+> ppr tys
               , text "ds_theta =" <+> ppr rhs ])
179

180
instance Outputable theta => Outputable (DerivSpec theta) where
181
  ppr = pprDerivSpec
182 183

instance Outputable EarlyDerivSpec where
184 185
  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
186 187

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

190 191 192
{- Note [Inferring the instance context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are two sorts of 'deriving':
193

194 195 196 197 198
  * InferTheta: the deriving clause for a data type
      data T a = T1 a deriving( Eq )
    Here we must infer an instance context,
    and generate instance declaration
      instance Eq a => Eq (T a) where ...
199

200 201 202 203
  * CheckTheta: standalone deriving
      deriving instance Eq a => Eq (T a)
    Here we only need to fill in the bindings;
    the instance context is user-supplied
204

205 206 207 208 209
For a deriving clause (InferTheta) we must figure out the
instance context (inferConstraints). Suppose we are inferring
the instance context for
    C t1 .. tn (T s1 .. sm)
There are two cases
210

211 212 213 214
  * (T s1 .. sm) :: *         (the normal case)
    Then we behave like Eq and guess (C t1 .. tn t)
    for each data constructor arg of type t.  More
    details below.
215

216 217
  * (T s1 .. sm) :: * -> *    (the functor-like case)
    Then we behave like Functor.
218

219 220 221
In both cases we produce a bunch of un-simplified constraints
and them simplify them in simplifyInstanceContexts; see
Note [Simplifying the instance context].
222

223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
In the functor-like case, we may need to unify some kind variables with * in
order for the generated instance to be well-kinded. An example from
Trac #10524:

  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
    = Compose (f (g a)) deriving Functor

Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
alone isn't enough, since k2 wasn't unified with *:

  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
    Functor (Compose f g) where ...

The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:

  1. Collect all of a datatype's subtypes which require functor-like
     constraints.
  2. For each subtype, create a substitution by unifying the subtype's kind
     with (* -> *).
  3. Compose all the substitutions into one, then apply that substitution to
     all of the in-scope type variables and the instance types.
245

246 247
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
248 249
Consider

250
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
251 252 253

We will need an instance decl like:

254 255
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
256 257 258

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
259
in RealFloat.
260 261 262 263 264 265 266

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

267
        Read, Enum?
268

269 270 271 272 273
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".

274 275
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
276 277 278 279 280
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
281
Notice the free 'a' in the deriving.  We have to fill this out to
282 283 284 285
    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
286 287


288 289
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
290 291 292
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

293 294 295 296 297
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
298
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
299
Then the Show instance is not done via Coercible; it shows
300
        Foo 3 as "Foo 3"
301
The Num instance is derived via Coercible, but the Show superclass
302 303 304 305
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
306 307
        (+) = ((+)@a)
        ...etc...
308 309 310 311
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


312 313 314 315 316 317
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.
318

319 320 321 322 323 324
-}

-- | Stuff needed to process a `deriving` clause
data DerivInfo = DerivInfo { di_rep_tc :: TyCon
                             -- ^ The data tycon for normal datatypes,
                             -- or the *representation* tycon for data families
325
                           , di_preds  :: [LHsSigType Name]
326 327 328 329
                           , di_ctxt   :: SDoc -- ^ error context
                           }

-- | Extract `deriving` clauses of proper data type (skips data families)
330 331
mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo]
mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
332 333 334 335 336 337 338 339 340 341 342 343
  where

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

{-

Austin Seipp's avatar
Austin Seipp committed
344 345
************************************************************************
*                                                                      *
346
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
347 348 349
*                                                                      *
************************************************************************
-}
350

351
tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
352
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
353
            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
354
tcDeriving deriv_infos deriv_decls
355 356
  = recoverM (do { g <- getGblEnv
                 ; return (g, emptyBag, emptyValBindsOut)}) $
357 358
    do  {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
359
          is_boot <- tcIsHsBootOrSig
360
        ; traceTc "tcDeriving" (ppr is_boot)
361

362
        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
363
        ; traceTc "tcDeriving 1" (ppr early_specs)
364

365
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
366
        ; insts1 <- mapM genInst given_specs
367

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
368 369
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
370
        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
371
                         simplifyInstanceContexts infer_specs
372

373
        ; insts2 <- mapM genInst final_specs
374

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

379 380
        ; dflags <- getDynFlags

dreixel's avatar
dreixel committed
381
        ; (inst_info, rn_binds, rn_dus) <-
382
            renameDeriv is_boot inst_infos binds
383

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
384
        ; unless (isEmptyBag inst_info) $
385
             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
386
                        (ddump_deriving inst_info rn_binds famInsts))
dreixel's avatar
dreixel committed
387

388
        ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
389
                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
niteria's avatar
niteria committed
390
        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs)
391
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
392
  where
393
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
394
                   -> Bag FamInst             -- ^ Rep type family instances
395
                   -> SDoc
396
    ddump_deriving inst_infos extra_binds repFamInsts
397
      =    hang (text "Derived instances:")
398
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
399
                 $$ ppr extra_binds)
400 401
        $$ hangP "GHC.Generics representation types:"
             (vcat (map pprRepTy (bagToList repFamInsts)))
402

403
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
404

405
-- Prints the representable type family instance
406 407
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
408
  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
409 410
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
411

412
renameDeriv :: Bool
413
            -> [InstInfo RdrName]
414
            -> Bag (LHsBind RdrName, LSig RdrName)
415
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
416
renameDeriv is_boot inst_infos bagBinds
417 418 419 420 421
  | 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
422
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
423

424
  | otherwise
425
  = discardWarnings $         -- Discard warnings about unused bindings etc
426 427 428 429
    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
430
    do  {
dreixel's avatar
dreixel committed
431 432
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
433
        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
434 435 436
        ; (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
437
        ; let bndrs = collectHsValBinders rn_aux_lhs
438
        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
439
        ; setEnvs envs $
440
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
441 442
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
443
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
444

445
  where
446
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
447 448 449 450
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
451
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
452
                            , ib_pragmas = sigs
453
                            , ib_extensions = exts -- Only for type-checking
454
                            , ib_derived = sa } })
455 456
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
457
           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
458
              ; let binds' = InstBindings { ib_binds = rn_binds
459 460 461 462
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
463
              ; return (inst_info { iBinds = binds' }, fvs) }
464

Austin Seipp's avatar
Austin Seipp committed
465
{-
466 467 468 469 470 471 472
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

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

473
If you compile with -Wunused-binds you do not expect the warning
474 475 476 477 478 479 480
"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...

481 482 483
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.
484

485 486 487 488 489 490 491 492 493 494 495 496 497 498
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
499 500
************************************************************************
*                                                                      *
501
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
502 503
*                                                                      *
************************************************************************
504

505
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
506
-}
507

508
makeDerivSpecs :: Bool
509
               -> [DerivInfo]
510 511
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
512 513 514 515
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
516

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

527
------------------------------------------------------------------
528 529 530 531 532 533 534 535 536 537 538 539 540
-- | Process a `deriving` clause
deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
                           , di_ctxt = err_ctxt })
  = addErrCtxt err_ctxt $
    concatMapM (deriveTyData tvs tc tys) preds
  where
    tvs = tyConTyVars rep_tc
    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
                        -- data family:
                  Just (fam_tc, pats, _) -> (fam_tc, pats)
      -- NB: deriveTyData wants the *user-specified*
      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
541

542
                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
543

544
------------------------------------------------------------------
545
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
546
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
547
--  e.g.   deriving instance Show a => Show (T a)
548
-- Rather like tcLocalInstDecl
549
deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
550 551
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
552
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
553
       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
554 555 556
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
557 558
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
559
                -- C.f. TcInstDcls.tcLocalInstDecl1
560
       ; checkTc (not (null inst_tys)) derivingNullaryErr
561

562 563
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
564 565 566 567
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
568 569

       ; case tcSplitTyConApp_maybe inst_ty of
570
           Just (tc, tc_args)
571
              | className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
572
              -> do warnUselessTypeable
573
                    return []
574

Ben Gamari's avatar
Ben Gamari committed
575
              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
576
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
577 578
                                        tvs cls cls_tys tc tc_args
                                        (Just theta)
579
                    ; return [spec] }
580 581 582

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

Ben Gamari's avatar
Ben Gamari committed
586 587 588
warnUselessTypeable :: TcM ()
warnUselessTypeable
  = do { warn <- woptM Opt_WarnDerivingTypeable
589
       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
590 591
                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                     text "has no effect: all types now auto-derive Typeable" }
Ben Gamari's avatar
Ben Gamari committed
592

593
------------------------------------------------------------------
594
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
595
                                             --   Can be a data instance, hence [Type] args
596
             -> LHsSigType Name              -- The deriving predicate
597
             -> TcM [EarlyDerivSpec]
dreixel's avatar
dreixel committed
598
-- The deriving clause of a data or newtype declaration
599
-- I.e. not standalone deriving
600 601
deriveTyData tvs tc tc_args deriv_pred
  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
602
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
603 604
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
605 606
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
607 608 609
                -- 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
610
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
611 612
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
613 614 615
        ; when (length cls_arg_kinds /= 1) $
            failWithTc (nonUnaryErr deriv_pred)
        ; let [cls_arg_kind] = cls_arg_kinds
616
        ; if className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
617
          then do warnUselessTypeable
618
                  return []
619
          else
620

621
     do {  -- Given data T a b c = ... deriving( C d ),
622
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
623
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
624 625
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
626 627
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
628 629
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)

630 631 632 633
              -- 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
634 635 636 637 638
              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)
639

Ryan Scott's avatar
Ryan Scott committed
640 641
        ; let Just kind_subst = mb_match
              ki_subst_range  = getTCvSubstRangeFVs kind_subst
642
              all_tkvs        = toposortTyVars $
niteria's avatar
niteria committed
643 644 645
                                fvVarList $ unionFV
                                  (tyCoFVsOfTypes tc_args_to_keep)
                                  (FV.mkFVs deriv_tvs)
646 647 648 649 650
              -- 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
651 652 653
                                          kind_subst unmapped_tkvs
              final_tc_args   = substTys subst tc_args_to_keep
              final_cls_tys   = substTys subst cls_tys
654 655
              tkvs            = tyCoVarsOfTypesWellScoped $
                                final_cls_tys ++ final_tc_args
656

Simon Peyton Jones's avatar
Simon Peyton Jones committed
657
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
658
                                       , pprTvBndrs (tyCoVarsOfTypesList tc_args)
659
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
660 661
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
662

663
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
664

665
        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
666
                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
667
                -- Check that
668 669
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
670 671 672 673 674
                --  (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
675
                --              newtype T a s = ... deriving( ST s )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
676
                --              newtype instance K a a = ... deriving( Monad )
677

678
        ; spec <- mkEqnHelp Nothing tkvs
679
                            cls final_cls_tys tc final_tc_args Nothing
680
        ; traceTc "derivTyData" (ppr spec)
681
        ; return [spec] } }
682

683

Austin Seipp's avatar
Austin Seipp committed
684
{-
685
Note [Unify kinds in deriving]
686 687 688 689 690 691 692 693 694
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

695 696 697 698 699 700
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
701 702
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
703 704 705 706 707 708 709 710 711

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,
712 713 714 715 716 717 718 719
 * 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:=*

720
Now we get a kind substitution.  We then need to:
721

722
  1. Remove the substituted-out kind variables from the quantified kind vars
723 724 725 726 727 728 729 730 731 732 733 734 735 736

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

740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788
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 *)).

789 790 791 792 793 794 795 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 827 828
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.

829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853
Note [Eta-reducing type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One can instantiate a type in a data family instance with a type synonym that
mentions other type variables:

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

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

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

When deriving, we need to perform eta-reduction analysis to ensure that none of
the eta-reduced type variables are mentioned elsewhere in the declaration. But
we need to be careful, because if we don't expand through the Const type
synonym, we will mistakenly believe that f is an eta-reduced type variable and
fail to derive Functor, even though the code above is correct (see Trac #11416,
where this was first noticed).

For this reason, we call exactTyCoVarsOfTypes on the eta-reduced types so that
we only consider the type variables that remain after expanding through type
synonyms.
854 855 856 857 858 859

              -- Use exactTyCoVarsOfTypes, not tyCoVarsOfTypes, so that we
              -- don't mistakenly grab a type variable mentioned in a type
              -- synonym that drops it.
              -- See Note [Eta-reducing type synonyms].
              dropped_tvs     = exactTyCoVarsOfTypes args_to_drop
Austin Seipp's avatar
Austin Seipp committed
860
-}
861

862 863
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
864 865
          -> Class -> [Type]
          -> TyCon -> [Type]
866 867
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
868 869
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
870
--      forall tvs. theta => cls (tys ++ [ty])
871 872 873
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

874
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
875 876 877 878 879 880
  = 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)
881
              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
882 883 884 885 886 887 888 889

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

892
       ; addUsedDataCons rdr_env rep_tc