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

5 6

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

9 10
{-# LANGUAGE CPP #-}

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

13
#include "HsVersions.h"
14

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

18
import TcRnMonad
19
import FamInst
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 LoadIface( loadInterfaceForName )
33
import Module( getModule )
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 )
Simon Marlow's avatar
Simon Marlow committed
39
import HscTypes
40
import Avail
Simon Marlow's avatar
Simon Marlow committed
41

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

import Control.Monad
68
import Data.List
69

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

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

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

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

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

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

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

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

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

     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
121
        , ds_tc = :RTList, ds_newtype = Just (Tree a) }
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
data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
129 130
type ThetaOrigin = [PredOrigin]

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

134 135
mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
136 137 138 139 140 141 142

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

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

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

172
instance Outputable theta => Outputable (DerivSpec theta) where
173
  ppr = pprDerivSpec
174 175 176 177 178 179

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

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

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

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

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

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

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

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

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

215

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

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

We will need an instance decl like:

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

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

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

237
        Read, Enum?
238

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

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

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


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

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


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

289 290 291 292 293 294
-}

-- | 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
295
                           , di_preds  :: [LHsSigType Name]
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
                           , 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
316 317
************************************************************************
*                                                                      *
318
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
319 320 321
*                                                                      *
************************************************************************
-}
322

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

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

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

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

345
        ; insts2 <- mapM genInst final_specs
346

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

352 353
        ; dflags <- getDynFlags

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

591
     do {  -- Given data T a b c = ... deriving( C d ),
592
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
593
          let (arg_kinds, _)  = splitFunTys cls_arg_kind
594 595
              n_args_to_drop  = length arg_kinds
              n_args_to_keep  = tyConArity tc - n_args_to_drop
596 597
              (tc_args_to_keep, args_to_drop)
                              = splitAt n_args_to_keep tc_args
598
              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
599
              dropped_tvs     = tyCoVarsOfTypes args_to_drop
600

601 602 603 604
              -- 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
605
              Just kind_subst = mb_match
606 607 608 609 610 611 612 613 614

              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
615

Simon Peyton Jones's avatar
Simon Peyton Jones committed
616
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
617
                                       , pprTvBndrs (tyCoVarsOfTypesList tc_args)
618
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
619 620
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
621

622
        -- Check that the result really is well-kinded
623
        ; checkTc (n_args_to_keep >= 0 && isJust mb_match)
624
                  (derivingKindErr tc cls cls_tys cls_arg_kind)
625

626
        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
627

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

642
        ; spec <- mkEqnHelp Nothing tkvs
643
                            cls final_cls_tys tc final_tc_args Nothing
644
        ; traceTc "derivTyData" (ppr spec)
645
        ; return [spec] } }
646

647

Austin Seipp's avatar
Austin Seipp committed
648
{-
649
Note [Unify kinds in deriving]
650 651 652 653 654 655 656 657 658
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

659 660 661 662 663 664
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
665 666
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
667 668 669 670 671 672 673 674 675

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,
676 677 678 679 680 681 682 683
 * 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:=*

684
Now we get a kind substitution.  We then need to:
685

686
  1. Remove the substituted-out kind variables from the quantified kind vars
687 688 689 690 691 692 693 694 695 696 697 698 699 700

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

705 706
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
707 708
          -> Class -> [Type]
          -> TyCon -> [Type]
709 710
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
711 712
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
713
--      forall tvs. theta => cls (tys ++ [ty])
714 715 716
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

717
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
718 719 720 721 722 723 724
  = 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)
              (bale_out (ptext (sLit "No family instance for") <+> quotes (pprTypeApp tycon tc_args)))
725 726 727 728 729 730 731 732 733 734

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

735
       ; addUsedDataCons rdr_env rep_tc
736 737 738 739 740
       ; unless (isNothing mtheta || not hidden_data_cons)
                (bale_out (derivingHiddenErr tycon))

       ; dflags <- getDynFlags
       ; if isDataTyCon rep_tc then
741
            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
742 743
                          tycon tc_args rep_tc rep_tc_args mtheta
         else
744
            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
745
                         tycon tc_args rep_tc rep_tc_args mtheta }
746
  where
747
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
748

Austin Seipp's avatar
Austin Seipp committed
749
{-
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765
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 ())
766
when there is no data instance F () in scope.
767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797

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 []
798
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
799 800 801 802 803 804 805

Note the need for the eta-reduced rule axioms.  After all, we can
write it out
    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
      return x = MkT [x]
      ... etc ...

806
See Note [Eta reduction for data families] in FamInstEnv
807

808 809
%************************************************************************
%*                                                                      *
810
                Deriving data types
Austin Seipp's avatar
Austin Seipp committed
811 812 813
*                                                                      *
************************************************************************
-}
814

815
mkDataTypeEqn :: DynFlags