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

5 6

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

9 10
{-# LANGUAGE CPP #-}

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

13
#include "HsVersions.h"
14

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

18
import TcRnMonad
19
import FamInst
20 21
import TcErrors( reportAllUnsolved )
import TcValidity( validDerivPred )
22
import TcClassDcl( tcATDefault, tcMkDeclCtxt )
Simon Marlow's avatar
Simon Marlow committed
23
import TcEnv
24
import TcGenDeriv                       -- Deriv stuff
25
import TcGenGenerics
Simon Marlow's avatar
Simon Marlow committed
26 27
import InstEnv
import Inst
28
import FamInstEnv
Simon Marlow's avatar
Simon Marlow committed
29
import TcHsType
30
import TcMType
Simon Marlow's avatar
Simon Marlow committed
31
import TcSimplify
32
import TcUnify( buildImplicationFor )
33
import LoadIface( loadInterfaceForName )
34
import Module( getModule )
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 RnSource   ( addTcgDUs )
Simon Marlow's avatar
Simon Marlow committed
40
import HscTypes
41
import Avail
Simon Marlow's avatar
Simon Marlow committed
42

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

import Control.Monad
69
import Data.List
70

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

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

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

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

-- DerivSpec is purely  local to this module
89
data DerivSpec theta = DS { ds_loc     :: SrcSpan
90
                          , ds_name    :: Name           -- DFun name
91 92 93 94 95
                          , ds_tvs     :: [TyVar]
                          , ds_theta   :: theta
                          , ds_cls     :: Class
                          , ds_tys     :: [Type]
                          , ds_tc      :: TyCon
96
                          , ds_overlap :: Maybe OverlapMode
97
                          , ds_newtype :: Maybe Type }  -- The newtype rep type
98 99 100 101 102 103
        -- 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
104
        --       in ds_tc is the *representation* type
105 106
        -- For non-family tycons, both are the same

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

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

Austin Seipp's avatar
Austin Seipp committed
113
{-
114
Example:
115

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

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

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

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 138 139 140 141 142 143

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

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

162
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
dterei's avatar
dterei committed
163
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
164
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
165 166 167 168 169 170 171
  = 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 ])
172

173
instance Outputable theta => Outputable (DerivSpec theta) where
174
  ppr = pprDerivSpec
175 176

instance Outputable EarlyDerivSpec where
177 178
  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
179 180

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

183 184 185
{- Note [Inferring the instance context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are two sorts of 'deriving':
186

187 188 189 190 191
  * 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 ...
192

193 194 195 196
  * 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
197

198 199 200 201 202
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
203

204 205 206 207
  * (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.
208

209 210
  * (T s1 .. sm) :: * -> *    (the functor-like case)
    Then we behave like Functor.
211

212 213 214
In both cases we produce a bunch of un-simplified constraints
and them simplify them in simplifyInstanceContexts; see
Note [Simplifying the instance context].
215

216

217 218
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
219 220
Consider

221
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
222 223 224

We will need an instance decl like:

225 226
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
227 228 229

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
230
in RealFloat.
231 232 233 234 235 236 237

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

238
        Read, Enum?
239

240 241 242 243 244
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".

245 246
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
247 248 249 250 251
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
252
Notice the free 'a' in the deriving.  We have to fill this out to
253 254 255 256
    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
257 258


259 260
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
261 262 263
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

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


283 284 285 286 287 288
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.
289

290 291 292 293 294 295
-}

-- | 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
296
                           , di_preds  :: [LHsSigType Name]
297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316
                           , di_ctxt   :: SDoc -- ^ error context
                           }

-- | Extract `deriving` clauses of proper data type (skips data families)
mkDerivInfos :: [TyClGroup Name] -> TcM [DerivInfo]
mkDerivInfos tycls = concatMapM mk_derivs tycls
  where
    mk_derivs (TyClGroup { group_tyclds = decls })
      = concatMapM (mk_deriv . unLoc) decls

    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
317 318
************************************************************************
*                                                                      *
319
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
320 321 322
*                                                                      *
************************************************************************
-}
323

324
tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
325
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
326
            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
327
tcDeriving deriv_infos deriv_decls
328 329
  = recoverM (do { g <- getGblEnv
                 ; return (g, emptyBag, emptyValBindsOut)}) $
330 331
    do  {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
332
          is_boot <- tcIsHsBootOrSig
333
        ; traceTc "tcDeriving" (ppr is_boot)
334

335
        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
336
        ; traceTc "tcDeriving 1" (ppr early_specs)
337

338
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
339
        ; insts1 <- mapM genInst given_specs
340

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
341 342
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
343
        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
344
                         simplifyInstanceContexts infer_specs
345

346
        ; insts2 <- mapM genInst final_specs
347

348
        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
349
        ; loc <- getSrcSpanM
350 351
        ; let (binds, famInsts, extraInstances) =
                genAuxBinds loc (unionManyBags deriv_stuff)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
352

353 354
        ; dflags <- getDynFlags

dreixel's avatar
dreixel committed
355 356
        ; (inst_info, rn_binds, rn_dus) <-
            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
357

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
358
        ; unless (isEmptyBag inst_info) $
359
             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
360
                        (ddump_deriving inst_info rn_binds famInsts))
dreixel's avatar
dreixel committed
361

362
        ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
363
                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
364 365
        ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
366
  where
367
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
368
                   -> Bag FamInst             -- ^ Rep type family instances
369
                   -> SDoc
370
    ddump_deriving inst_infos extra_binds repFamInsts
371
      =    hang (text "Derived instances:")
372
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
373
                 $$ ppr extra_binds)
374 375
        $$ hangP "GHC.Generics representation types:"
             (vcat (map pprRepTy (bagToList repFamInsts)))
376

377
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
378

379
-- Prints the representable type family instance
380 381
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
382
  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
383 384
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
385

386
renameDeriv :: Bool
387
            -> [InstInfo RdrName]
388
            -> Bag (LHsBind RdrName, LSig RdrName)
389
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
390
renameDeriv is_boot inst_infos bagBinds
391 392 393 394 395
  | 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
396
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
397

398
  | otherwise
399
  = discardWarnings $         -- Discard warnings about unused bindings etc
400 401 402 403
    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
404
    do  {
dreixel's avatar
dreixel committed
405 406
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
407
        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
408 409 410
        ; (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
411
        ; let bndrs = collectHsValBinders rn_aux_lhs
412
        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
413
        ; setEnvs envs $
414
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
415 416
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
417
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
418

419
  where
420
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
421 422 423 424
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
425
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
426
                            , ib_pragmas = sigs
427
                            , ib_extensions = exts -- Only for type-checking
428
                            , ib_derived = sa } })
429 430
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
431
           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
432
              ; let binds' = InstBindings { ib_binds = rn_binds
433 434 435 436
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
437
              ; return (inst_info { iBinds = binds' }, fvs) }
438

Austin Seipp's avatar
Austin Seipp committed
439
{-
440 441 442 443 444 445 446
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

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

447
If you compile with -Wunused-binds you do not expect the warning
448 449 450 451 452 453 454
"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...

455 456 457
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.
458

459 460 461 462 463 464 465 466 467 468 469 470 471 472
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
473 474
************************************************************************
*                                                                      *
475
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
476 477
*                                                                      *
************************************************************************
478

479
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
480
-}
481

482
makeDerivSpecs :: Bool
483
               -> [DerivInfo]
484 485
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
486 487 488 489
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
490

491
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
492
              do { unless (null eqns) (add_deriv_err (head eqns))
493
                 ; return [] }
494
          else return eqns }
495
  where
496
    add_deriv_err eqn
497
       = setSrcSpan (earlyDSLoc eqn) $
498 499
         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
500

501
------------------------------------------------------------------
502 503 504 505 506 507 508 509 510 511 512 513 514
-- | 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]
515

516
                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
517

518
------------------------------------------------------------------
519
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
520
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
521
--  e.g.   deriving instance Show a => Show (T a)
522
-- Rather like tcLocalInstDecl
523
deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
524 525
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
526
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
527
       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
528 529 530
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
531 532
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
533
                -- C.f. TcInstDcls.tcLocalInstDecl1
534
       ; checkTc (not (null inst_tys)) derivingNullaryErr
535

536 537
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
538 539 540 541
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
542 543

       ; case tcSplitTyConApp_maybe inst_ty of
544
           Just (tc, tc_args)
545
              | className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
546
              -> do warnUselessTypeable
547
                    return []
548

Ben Gamari's avatar
Ben Gamari committed
549
              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
550
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
551 552
                                        tvs cls cls_tys tc tc_args
                                        (Just theta)
553
                    ; return [spec] }
554 555 556

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

Ben Gamari's avatar
Ben Gamari committed
560 561 562 563
warnUselessTypeable :: TcM ()
warnUselessTypeable
  = do { warn <- woptM Opt_WarnDerivingTypeable
       ; when warn $ addWarnTc
564 565
                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
                     text "has no effect: all types now auto-derive Typeable" }
Ben Gamari's avatar
Ben Gamari committed
566

567
------------------------------------------------------------------
568
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
569
                                             --   Can be a data instance, hence [Type] args
570
             -> LHsSigType Name              -- The deriving predicate
571
             -> TcM [EarlyDerivSpec]
dreixel's avatar
dreixel committed
572
-- The deriving clause of a data or newtype declaration
573
-- I.e. not standalone deriving
574 575
deriveTyData tvs tc tc_args deriv_pred
  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
576 577 578
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
579 580
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
581 582 583
                -- 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
584
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
585 586
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
587
        ; if className cls == typeableClassName
Ben Gamari's avatar
Ben Gamari committed
588
          then do warnUselessTypeable
589
                  return []
590
          else
591

592
     do {  -- Given data T a b c = ... deriving( C d ),
593
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
594
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
595 596
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
597 598
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
599
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
600 601 602 603 604
              -- 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
605

606 607 608 609
              -- 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
610
              Just kind_subst = mb_match
611 612 613 614 615 616 617 618 619

              all_tkvs        = varSetElemsWellScoped $
                                mkVarSet deriv_tvs `unionVarSet`
                                tyCoVarsOfTypes tc_args_to_keep
              unmapped_tkvs   = filter (`notElemTCvSubst` kind_subst) all_tkvs
              (subst, tkvs)   = mapAccumL substTyVarBndr
                                          kind_subst unmapped_tkvs
              final_tc_args   = substTys subst tc_args_to_keep
              final_cls_tys   = substTys subst cls_tys
620

Simon Peyton Jones's avatar
Simon Peyton Jones committed
621
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
622
                                       , pprTvBndrs (tyCoVarsOfTypesList tc_args)
623
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
624 625
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
626

627
        -- Check that the result really is well-kinded
628
        ; checkTc (n_args_to_keep >= 0 && isJust mb_match)
629
                  (derivingKindErr tc cls cls_tys cls_arg_kind)
630

631
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
632

633
        ; checkTc (allDistinctTyVars args_to_drop &&              -- (a) and (b)
634
                   not (any (`elemVarSet` dropped_tvs) tkvs))     -- (c)
635
                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
636
                -- Check that
637 638
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
639 640 641 642 643
                --  (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
644
                --              newtype T a s = ... deriving( ST s )
645 646
                --              newtype K a a = ... deriving( Monad )

647
        ; spec <- mkEqnHelp Nothing tkvs
648
                            cls final_cls_tys tc final_tc_args Nothing
649
        ; traceTc "derivTyData" (ppr spec)
650
        ; return [spec] } }
651

652

Austin Seipp's avatar
Austin Seipp committed
653
{-
654
Note [Unify kinds in deriving]
655 656 657 658 659 660 661 662 663
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

664 665 666 667 668 669
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
670 671
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
672 673 674 675 676 677 678 679 680

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,
681 682 683 684 685 686 687 688
 * 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:=*

689
Now we get a kind substitution.  We then need to:
690

691
  1. Remove the substituted-out kind variables from the quantified kind vars
692 693 694 695 696 697 698 699 700 701 702 703 704 705

  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:*->*))
706
and similarly for C.  Notice the modified kind of x, both at binding
707
and occurrence sites.
708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733

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.
Austin Seipp's avatar
Austin Seipp committed
734
-}
735

736 737
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
738 739
          -> Class -> [Type]
          -> TyCon -> [Type]
740 741
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
742 743
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
744
--      forall tvs. theta => cls (tys ++ [ty])
745 746 747
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

748
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
749 750 751 752 753 754
  = 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)
755
              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
756 757 758 759 760 761 762 763 764 765

       -- 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)
             not_in_scope dc  = null (lookupGRE_Name rdr_env dc)

766
       ; addUsedDataCons rdr_env rep_tc
767 768 769 770 771
       ; unless (isNothing mtheta || not hidden_data_cons)
                (bale_out (derivingHiddenErr tycon))

       ; dflags <- getDynFlags
       ; if isDataTyCon rep_tc then
772
            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
773 774
                          tycon tc_args rep_tc rep_tc_args mtheta
         else
775
            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
776
                         tycon tc_args rep_tc rep_tc_args mtheta }
777
  where
778
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
779

Austin Seipp's avatar
Austin Seipp committed
780
{-
781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796
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 ())
797
when there is no data instance F () in scope.
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 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 []
829
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))