TcDeriv.hs 93.5 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 ) 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 )
Simon Marlow's avatar
Simon Marlow committed
22
import TcEnv
23
import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn )
24 25
import TcClassDcl( tcAddDeclCtxt )      -- Small helper
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 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 Kind( isKind )
Simon Marlow's avatar
Simon Marlow committed
47 48 49 50 51 52 53 54 55 56
import ErrUtils
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
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
64 65

import Control.Monad
66
import Data.List
67

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

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

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

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

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

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
        -- ds_newtype = True  <=> Generalised Newtype Deriving (GND)
109
        --              False <=> 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 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]]
        , ds_tc = :RTList, ds_tc_args = [a]
        , ds_newtype = True }
Austin Seipp's avatar
Austin Seipp committed
122
-}
123

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

128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
data PredOrigin = PredOrigin PredType CtOrigin
type ThetaOrigin = [PredOrigin]

mkPredOrigin :: CtOrigin -> PredType -> PredOrigin
mkPredOrigin origin pred = PredOrigin pred origin

mkThetaOrigin :: CtOrigin -> ThetaType -> ThetaOrigin
mkThetaOrigin origin = map (mkPredOrigin origin)

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

forgetTheta :: EarlyDerivSpec -> DerivSpec ()
forgetTheta (InferTheta spec) = spec { ds_theta = () }
forgetTheta (GivenTheta spec) = spec { ds_theta = () }

earlyDSTyCon :: EarlyDerivSpec -> TyCon
earlyDSTyCon (InferTheta spec) = ds_tc spec
earlyDSTyCon (GivenTheta spec) = ds_tc spec

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

161 162 163 164
earlyDSClass :: EarlyDerivSpec -> Class
earlyDSClass (InferTheta spec) = ds_cls spec
earlyDSClass (GivenTheta spec) = ds_cls spec

165 166 167 168 169 170
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)
171

172
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
dterei's avatar
dterei committed
173
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
174
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
175
  = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
176
            <+> equals <+> ppr rhs)
177

178
instance Outputable theta => Outputable (DerivSpec theta) where
179
  ppr = pprDerivSpec
180 181 182 183 184 185 186

instance Outputable EarlyDerivSpec where
  ppr (InferTheta spec) = ppr spec <+> ptext (sLit "(Infer)")
  ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)")

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

Austin Seipp's avatar
Austin Seipp committed
188
{-
dterei's avatar
dterei committed
189
Inferring missing contexts
190
~~~~~~~~~~~~~~~~~~~~~~~~~~
191 192
Consider

193 194 195 196
        data T a b = C1 (Foo a) (Bar b)
                   | C2 Int (T b a)
                   | C3 (T a a)
                   deriving (Eq)
197

dterei's avatar
dterei committed
198
[NOTE: See end of these comments for what to do with
199
        data (C a, D b) => T a b = ...
200 201
]

202 203
We want to come up with an instance declaration of the form

204 205
        instance (Ping a, Pong b, ...) => Eq (T a b) where
                x == y = ...
206 207 208 209 210 211 212 213

It is pretty easy, albeit tedious, to fill in the code "...".  The
trick is to figure out what the context for the instance decl is,
namely @Ping@, @Pong@ and friends.

Let's call the context reqd for the T instance of class C at types
(a,b, ...)  C (T a b).  Thus:

214
        Eq (T a b) = (Ping a, Pong b, ...)
215 216 217

Now we can get a (recursive) equation from the @data@ decl:

218 219 220
        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                   u Eq (T b a) u Eq Int        -- From C2
                   u Eq (T a a)                 -- From C3
221 222 223 224 225 226 227 228 229 230 231 232 233 234

Foo and Bar may have explicit instances for @Eq@, in which case we can
just substitute for them.  Alternatively, either or both may have
their @Eq@ instances given by @deriving@ clauses, in which case they
form part of the system of equations.

Now all we need do is simplify and solve the equations, iterating to
find the least fixpoint.  Notice that the order of the arguments can
switch around, as here in the recursive calls to T.

Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.

We start with:

235
        Eq (T a b) = {}         -- The empty set
236 237

Next iteration:
238 239 240
        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                   u Eq (T b a) u Eq Int        -- From C2
                   u Eq (T a a)                 -- From C3
241

242 243 244
        After simplification:
                   = Eq a u Ping b u {} u {} u {}
                   = Eq a u Ping b
245 246 247

Next iteration:

248 249 250
        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                   u Eq (T b a) u Eq Int        -- From C2
                   u Eq (T a a)                 -- From C3
251

252 253 254 255
        After simplification:
                   = Eq a u Ping b
                   u (Eq b u Ping a)
                   u (Eq a u Ping a)
256

257
                   = Eq a u Ping b u Eq b u Ping a
258 259 260 261 262

The next iteration gives the same result, so this is the fixpoint.  We
need to make a canonical form of the RHS to ensure convergence.  We do
this by simplifying the RHS to a form in which

263 264 265
        - the classes constrain only tyvars
        - the list is sorted by tyvar (major key) and then class (minor key)
        - no duplicates, of course
266 267 268

So, here are the synonyms for the ``equation'' structures:

269

270 271
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
272 273
Consider

274
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
275 276 277

We will need an instance decl like:

278 279
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
280 281 282

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

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

291
        Read, Enum?
292

293 294 295 296 297
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".

298 299
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
300 301 302 303 304
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
305
Notice the free 'a' in the deriving.  We have to fill this out to
306 307 308 309
    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
310 311


312 313
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
314 315 316
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

317 318 319 320 321
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
322
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
323
Then the Show instance is not done via Coercible; it shows
324
        Foo 3 as "Foo 3"
325
The Num instance is derived via Coercible, but the Show superclass
326 327 328 329
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
330 331
        (+) = ((+)@a)
        ...etc...
332 333 334 335
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


336 337 338 339 340 341
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.
342

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

350 351
tcDeriving  :: [LTyClDecl Name]  -- All type constructors
            -> [LInstDecl Name]  -- All instance declarations
352
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
353
            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
354
tcDeriving tycl_decls inst_decls 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 tycl_decls inst_decls deriv_decls
363
        ; traceTc "tcDeriving 1" (ppr early_specs)
364

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
365 366 367
        -- for each type, determine the auxliary declarations that are common
        -- to multiple derivations involving that type (e.g. Generic and
        -- Generic1 should use the same TcGenGenerics.MetaTyCons)
368
        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
369

370
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
371
        ; insts1 <- mapM (genInst commonAuxs) given_specs
372

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
373 374
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
375
        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
376
                         inferInstanceContexts infer_specs
377

378
        ; insts2 <- mapM (genInst commonAuxs) final_specs
379

380
        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
381
        ; loc <- getSrcSpanM
382
        ; let (binds, newTyCons, famInsts, extraInstances) =
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
383 384
                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))

dreixel's avatar
dreixel committed
385 386
        ; (inst_info, rn_binds, rn_dus) <-
            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
387

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
388 389
        ; dflags <- getDynFlags
        ; unless (isEmptyBag inst_info) $
390 391
             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
                        (ddump_deriving inst_info rn_binds newTyCons famInsts))
dreixel's avatar
dreixel committed
392

Simon Peyton Jones's avatar
Simon Peyton Jones committed
393 394 395 396 397
        ; let all_tycons = map ATyCon (bagToList newTyCons)
        ; gbl_env <- tcExtendGlobalEnv all_tycons $
                     tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
                     tcExtendLocalFamInstEnv (bagToList famInsts) $
                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
398 399
        ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
400
  where
401
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
402 403
                   -> Bag TyCon               -- ^ Empty data constructors
                   -> Bag FamInst             -- ^ Rep type family instances
404
                   -> SDoc
405
    ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
dreixel's avatar
dreixel committed
406
      =    hang (ptext (sLit "Derived instances:"))
407
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
408
                 $$ ppr extra_binds)
dreixel's avatar
dreixel committed
409 410 411 412
        $$ hangP "Generic representation:" (
              hangP "Generated datatypes for meta-information:"
               (vcat (map ppr (bagToList repMetaTys)))
           $$ hangP "Representation types:"
413 414
                (vcat (map pprRepTy (bagToList repFamInsts))))

415
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
416

417
-- Prints the representable type family instance
418 419
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
420
  = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
421 422
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
423 424 425 426 427

-- As of 24 April 2012, this only shares MetaTyCons between derivations of
-- Generic and Generic1; thus the types and logic are quite simple.
type CommonAuxiliary = MetaTyCons
type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
428 429

commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
430 431 432 433 434 435 436 437 438 439
commonAuxiliaries = foldM snoc ([], emptyBag) where
  snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
      extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
    | otherwise = return acc
   where extendComAux m -- don't run m if its already in the accumulator
           | any ((rep_tycon ==) . fst) cas = return acc
           | otherwise = do (ca, new_stuff) <- m
                            return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)

440
renameDeriv :: Bool
441
            -> [InstInfo RdrName]
442
            -> Bag (LHsBind RdrName, LSig RdrName)
443
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
444
renameDeriv is_boot inst_infos bagBinds
445 446 447 448 449
  | 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
450
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
451

452
  | otherwise
453
  = discardWarnings $         -- Discard warnings about unused bindings etc
454
    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have
455
                              --    case x of {}
456 457
    setXOptM Opt_ScopedTypeVariables $  -- Derived decls (for newtype-deriving) can
    setXOptM Opt_KindSignatures $       -- used ScopedTypeVariables & KindSignatures
458
    do  {
dreixel's avatar
dreixel committed
459 460
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
461 462 463
        ; (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
464
        ; let bndrs = collectHsValBinders rn_aux_lhs
465 466 467
        ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
        ; setEnvs envs $
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs) False) rn_aux_lhs
468 469
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
470
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
471

472
  where
473
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
474 475 476 477
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
478
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
479
                            , ib_pragmas = sigs
480
                            , ib_extensions = exts -- Only for type-checking
481
                            , ib_derived = sa } })
482 483
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
484
           do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
485
              ; let binds' = InstBindings { ib_binds = rn_binds
486 487 488 489
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
490
              ; return (inst_info { iBinds = binds' }, fvs) }
491

Austin Seipp's avatar
Austin Seipp committed
492
{-
493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

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

If you compile with -fwarn-unused-binds you do not expect the warning
"Defined but not used: data consructor MkP". Yet the newtype deriving
code does not explicitly mention MkP, but it should behave as if you
had written
  instance Monad P where
     return x = MkP (return x)
     ...etc...

508 509 510
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.
511

Austin Seipp's avatar
Austin Seipp committed
512 513
************************************************************************
*                                                                      *
514
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
515 516
*                                                                      *
************************************************************************
517

518
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
519
-}
520

521 522 523 524 525
makeDerivSpecs :: Bool
               -> [LTyClDecl Name]
               -> [LInstDecl Name]
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
526
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
527 528 529
  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl)     tycl_decls
        ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl)   inst_decls
        ; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
530 531 532

        -- If AutoDeriveTypeable is set, we automatically add Typeable instances
        -- for every data type and type class declared in the module
533 534
        ; auto_typeable <- xoptM Opt_AutoDeriveTypeable
        ; eqns4 <- deriveAutoTypeable auto_typeable (eqns1 ++ eqns3) tycl_decls
535 536

        ; let eqns = eqns1 ++ eqns2 ++ eqns3 ++ eqns4
537

538
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
539
              do { unless (null eqns) (add_deriv_err (head eqns))
540
                 ; return [] }
541
          else return eqns }
542
  where
543
    add_deriv_err eqn
544
       = setSrcSpan (earlyDSLoc eqn) $
545 546
         addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
                    2 (ptext (sLit "Use an instance declaration instead")))
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
547

548 549 550 551 552 553 554 555 556 557 558
deriveAutoTypeable :: Bool -> [EarlyDerivSpec] -> [LTyClDecl Name] -> TcM [EarlyDerivSpec]
-- Runs over *all* TyCl declarations, including classes and data families
-- i.e. not just data type decls
deriveAutoTypeable auto_typeable done_specs tycl_decls
  | not auto_typeable = return []
  | otherwise         = do { cls <- tcLookupClass typeableClassName
                           ; concatMapM (do_one cls) tycl_decls }
  where
    done_tcs = mkNameSet [ tyConName (earlyDSTyCon spec)
                         | spec <- done_specs
                         , className (earlyDSClass spec) == typeableClassName ]
559
        -- Check if an automatically generated DS for deriving Typeable should be
Gabor Greif's avatar
Gabor Greif committed
560
        -- omitted because the user had manually requested an instance
561 562

    do_one cls (L _ decl)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
563 564 565
      | isClassDecl decl  -- Traverse into class declarations to check if they have ATs (#9999)
      = concatMapM (do_one cls) (map (fmap FamDecl) (tcdATs decl))
      | otherwise
566
      = do { tc <- tcLookupTyCon (tcdName decl)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
567
           ; if (isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
568
                                       || tyConName tc `elemNameSet` done_tcs)
569
                     -- Do not derive Typeable for type synonyms or type families
Simon Peyton Jones's avatar
Simon Peyton Jones committed
570 571
             then return []
             else mkPolyKindedTypeableEqn cls tc }
572

573 574
------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
575
deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name
576
                                 , tcdDataDefn = HsDataDefn { dd_derivs = preds } }))
577 578
  = tcAddDeclCtxt decl $
    do { tc <- tcLookupTyCon tc_name
579 580
       ; let tvs  = tyConTyVars tc
             tys  = mkTyVarTys tvs
581

582
       ; case preds of
583 584
          Just (L _ preds') -> concatMapM (deriveTyData False tvs tc tys) preds'
          Nothing           -> return [] }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
585

586
deriveTyDecl _ = return []
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
587

588 589
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
590 591
deriveInstDecl (L _ (TyFamInstD {})) = return []
deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
592
  = deriveFamInst fam_inst
593
deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
594 595 596
  = concatMapM (deriveFamInst . unLoc) fam_insts

------------------------------------------------------------------
597
deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
598 599 600 601
deriveFamInst decl@(DataFamInstDecl
                       { dfid_tycon = L _ tc_name, dfid_pats = pats
                       , dfid_defn
                         = defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) })
602
  = tcAddDataFamInstCtxt decl $
603
    do { fam_tc <- tcLookupTyCon tc_name
604 605
       ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
             -- kcDataDefn defn: see Note [Finding the LHS patterns]
606
         \ tvs' pats' _ ->
607
           concatMapM (deriveTyData True tvs' fam_tc pats') preds }
608 609

deriveFamInst _ = return []
610

Austin Seipp's avatar
Austin Seipp committed
611
{-
612 613 614 615 616 617 618 619 620 621 622 623 624 625
Note [Finding the LHS patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When kind polymorphism is in play, we need to be careful.  Here is
Trac #9359:
  data Cmp a where
    Sup :: Cmp a
    V   :: a -> Cmp a

  data family   CmpInterval (a :: Cmp k) (b :: Cmp k) :: *
  data instance CmpInterval (V c) Sup = Starting c deriving( Show )

So CmpInterval is kind-polymorphic, but the data instance is not
   CmpInterval :: forall k. Cmp k -> Cmp k -> *
   data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show )
626

627 628 629
Hence, when deriving the type patterns in deriveFamInst, we must kind
check the RHS (the data constructor 'Starting c') as well as the LHS,
so that we correctly see the instantiation to *.
Austin Seipp's avatar
Austin Seipp committed
630
-}
631

632
------------------------------------------------------------------
633
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
634
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
635
--  e.g.   deriving instance Show a => Show (T a)
636
-- Rather like tcLocalInstDecl
637
deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
638 639
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
640
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
641 642
       ; (tvs, theta, cls, inst_tys) <- setXOptM Opt_DataKinds $ -- for polykinded typeable
                                        tcHsInstHead TcType.InstDeclCtxt deriv_ty
643 644 645
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
646 647
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
648
                -- C.f. TcInstDcls.tcLocalInstDecl1
649
       ; checkTc (not (null inst_tys)) derivingNullaryErr
650

651 652
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
653 654 655 656
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
657 658

       ; case tcSplitTyConApp_maybe inst_ty of
659 660 661 662 663 664 665
           Just (tc, tc_args)
              | className cls == typeableClassName  -- Works for algebraic TyCons
                                                    -- _and_ data families
              -> do { check_standalone_typeable theta tc tc_args
                    ; mkPolyKindedTypeableEqn cls tc }

              | isAlgTyCon tc  -- All other classes
666 667
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
                                        tvs cls cls_tys tc tc_args (Just theta)
668
                    ; return [spec] }
669 670 671 672 673 674

           _  -> -- Complain about functions, primitive types, etc,
                 -- except for the Typeable class
                 failWithTc $ derivingThingErr False cls cls_tys inst_ty $
                 ptext (sLit "The last argument of the instance must be a data or newtype application")
        }
675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712
  where
    check_standalone_typeable theta tc tc_args
             -- We expect to see
             --       deriving Typeable <kind> T
             -- for some tycon T.  But if S is kind-polymorphic,
             -- say (S :: forall k. k -> *), we might see
             --       deriving Typable <kind> (S k)
             --
             -- But we should NOT see
             --       deriving Typeable <kind> (T Int)
             -- or    deriving Typeable <kind> (S *)   where S is kind-polymorphic
             --
             -- So all the tc_args should be distinct kind variables
      | null theta
      , allDistinctTyVars tc_args
      , all is_kind_var tc_args
      = return ()

      | otherwise
      = do { polykinds <- xoptM Opt_PolyKinds
           ; failWith (mk_msg polykinds theta tc tc_args) }

    is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
                           Just v  -> isKindVar v
                           Nothing -> False

    mk_msg polykinds theta tc tc_args
      | not polykinds
      , all isKind tc_args   -- Non-empty, all kinds, at least one not a kind variable
      , null theta
      = hang (ptext (sLit "To make a Typeable instance of poly-kinded")
               <+> quotes (ppr tc) <> comma)
           2 (ptext (sLit "use XPolyKinds"))

      | otherwise
      = hang (ptext (sLit "Derived Typeable instance must be of form"))
           2 (ptext (sLit "deriving instance Typeable") <+> ppr tc)

713 714

------------------------------------------------------------------
715 716 717
deriveTyData :: Bool                         -- False <=> data/newtype
                                             -- True  <=> data/newtype *instance*
             -> [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
718
                                             --   Can be a data instance, hence [Type] args
719
             -> LHsType Name                 -- The deriving predicate
720
             -> TcM [EarlyDerivSpec]
dreixel's avatar
dreixel committed
721
-- The deriving clause of a data or newtype declaration
722 723
-- I.e. not standalone deriving
deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
724
  = setSrcSpan loc     $        -- Use the location of the 'deriving' item
725 726 727
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
728 729
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
730 731 732
                -- 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
733
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
734 735
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
736
        ; if className cls == typeableClassName
737 738
          then derivePolyKindedTypeable is_instance cls cls_tys tvs tc tc_args
          else
739

740
     do {  -- Given data T a b c = ... deriving( C d ),
741 742
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
          let (arg_kinds, _)  = splitKindFunTys cls_arg_kind
743 744 745 746 747 748 749
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
              args_to_drop    = drop n_args_to_keep tc_args
              tc_args_to_keep = take n_args_to_keep tc_args
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
              dropped_tvs     = tyVarsOfTypes args_to_drop

750 751 752 753
              -- 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
754
              Just kind_subst = mb_match
755
              (univ_kvs, univ_tvs) = partition isKindVar $ varSetElems $
756
                                     mkVarSet deriv_tvs `unionVarSet`
757 758 759 760 761
                                     tyVarsOfTypes tc_args_to_keep
              univ_kvs'           = filter (`notElemTvSubst` kind_subst) univ_kvs
              (subst', univ_tvs') = mapAccumL substTyVarBndr kind_subst univ_tvs
              final_tc_args       = substTys subst' tc_args_to_keep
              final_cls_tys       = substTys subst' cls_tys
762

Simon Peyton Jones's avatar
Simon Peyton Jones committed
763
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
764 765
                                       , pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args)
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
766 767
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
768

769
        -- Check that the result really is well-kinded
770
        ; checkTc (n_args_to_keep >= 0 && isJust mb_match)
771
                  (derivingKindErr tc cls cls_tys cls_arg_kind)
772

773 774
        ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ])

775 776 777
        ; checkTc (allDistinctTyVars args_to_drop &&              -- (a) and (b)
                   not (any (`elemVarSet` dropped_tvs) univ_tvs)) -- (c)
                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
778
                -- Check that
779 780
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
781 782 783 784 785
                --  (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
786
                --              newtype T a s = ... deriving( ST s )
787 788
                --              newtype K a a = ... deriving( Monad )

789
        ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs')
790
                            cls final_cls_tys tc final_tc_args Nothing
791
        ; return [spec] } }
792

793
derivePolyKindedTypeable :: Bool -> Class -> [Type]
794
                         -> [TyVar] -> TyCon -> [Type]
795 796 797 798 799 800 801 802 803 804 805 806 807
                         -> TcM [EarlyDerivSpec]
-- The deriving( Typeable ) clause of a data/newtype decl
-- I.e. not standalone deriving
derivePolyKindedTypeable is_instance cls cls_tys _tvs tc tc_args
  | is_instance
  = failWith (sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;")
                  , ptext (sLit "derive Typeable for")
                    <+> quotes (pprSourceTyCon tc)
                    <+> ptext (sLit "alone") ])

  | otherwise
  = ASSERT( allDistinctTyVars tc_args )  -- Came from a data/newtype decl
    do { checkTc (isSingleton cls_tys) $   -- Typeable k
808 809 810
         derivingThingErr False cls cls_tys (mkTyConApp tc tc_args)
                          (classArgsErr cls cls_tys)

811
       ; mkPolyKindedTypeableEqn cls tc }
812

Austin Seipp's avatar
Austin Seipp committed
813
{-
814
Note [Unify kinds in deriving]
815 816 817 818 819 820 821 822 823
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

824 825 826 827 828 829
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
830 831
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
832 833 834 835 836 837 838 839 840

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,
841 842 843 844 845 846 847 848
 * 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:=*

849
Now we get a kind substitution.  We then need to:
850

851
  1. Remove the substituted-out kind variables from the quantified kind vars
852 853 854 855 856 857 858 859 860 861 862 863 864 865

  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:*->*))
866
and similarly for C.  Notice the modified kind of x, both at binding
867
and occurrence sites.
Austin Seipp's avatar
Austin Seipp committed
868
-}
869

870 871
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
872 873
          -> Class -> [Type]
          -> TyCon -> [Type]
874 875
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
876 877
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
878
--      forall tvs. theta => cls (tys ++ [ty])
879 880 881
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

882
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
883 884 885 886 887 888 889 890
  = 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)