TcDeriv.hs 89.8 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 46 47 48 49 50 51 52 53 54 55
import Class
import Type
import ErrUtils
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
import VarSet
56
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
57 58
import SrcLoc
import Util
59
import Outputable
60
import FastString
61
import Bag
62
import Pair
63 64

import Control.Monad
65
import Data.List
66

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

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

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

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

-- DerivSpec is purely  local to this module
85
data DerivSpec theta = DS { ds_loc     :: SrcSpan
86
                          , ds_name    :: Name           -- DFun name
87 88 89 90 91 92
                          , ds_tvs     :: [TyVar]
                          , ds_theta   :: theta
                          , ds_cls     :: Class
                          , ds_tys     :: [Type]
                          , ds_tc      :: TyCon
                          , ds_tc_args :: [Type]
93
                          , ds_overlap :: Maybe OverlapMode
94
                          , ds_newtype :: Bool }
95 96 97 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
        --       in ds_tc, ds_tc_args is the *representation* tycon
        -- For non-family tycons, both are the same

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

107
        -- ds_newtype = True  <=> Generalised Newtype Deriving (GND)
108
        --              False <=> Vanilla deriving
109

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

113
     newtype instance T [a] = MkT (Tree a) deriving( C s )
dterei's avatar
dterei committed
114
==>
115 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]]
        , ds_tc = :RTList, ds_tc_args = [a]
        , ds_newtype = True }
Austin Seipp's avatar
Austin Seipp committed
121
-}
122

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

127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
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)
144
        --
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
        -- 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 = () }

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

163
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
dterei's avatar
dterei committed
164
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
165
                   ds_cls = c, ds_tys = tys, ds_theta = rhs })
166
  = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
167
            <+> equals <+> ppr rhs)
168

169
instance Outputable theta => Outputable (DerivSpec theta) where
170
  ppr = pprDerivSpec
171 172 173 174 175 176 177

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
178

Austin Seipp's avatar
Austin Seipp committed
179
{-
dterei's avatar
dterei committed
180
Inferring missing contexts
181
~~~~~~~~~~~~~~~~~~~~~~~~~~
182 183
Consider

184 185 186 187
        data T a b = C1 (Foo a) (Bar b)
                   | C2 Int (T b a)
                   | C3 (T a a)
                   deriving (Eq)
188

dterei's avatar
dterei committed
189
[NOTE: See end of these comments for what to do with
190
        data (C a, D b) => T a b = ...
191 192
]

193 194
We want to come up with an instance declaration of the form

195 196
        instance (Ping a, Pong b, ...) => Eq (T a b) where
                x == y = ...
197 198 199 200 201 202 203 204

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:

205
        Eq (T a b) = (Ping a, Pong b, ...)
206 207 208

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

209 210 211
        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
212 213 214 215 216 217 218 219 220 221 222 223 224 225

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:

226
        Eq (T a b) = {}         -- The empty set
227 228

Next iteration:
229 230 231
        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
232

233 234 235
        After simplification:
                   = Eq a u Ping b u {} u {} u {}
                   = Eq a u Ping b
236 237 238

Next iteration:

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

243 244 245 246
        After simplification:
                   = Eq a u Ping b
                   u (Eq b u Ping a)
                   u (Eq a u Ping a)
247

248
                   = Eq a u Ping b u Eq b u Ping a
249 250 251 252 253

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

254 255 256
        - the classes constrain only tyvars
        - the list is sorted by tyvar (major key) and then class (minor key)
        - no duplicates, of course
257 258 259

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

260

261 262
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
263 264
Consider

265
        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
266 267 268

We will need an instance decl like:

269 270
        instance (Read a, RealFloat a) => Read (Complex a) where
          ...
271 272 273

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
274
in RealFloat.
275 276 277 278 279 280 281

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

282
        Read, Enum?
283

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

289 290
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
291 292 293 294 295
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

dterei's avatar
dterei committed
296
Notice the free 'a' in the deriving.  We have to fill this out to
297 298 299 300
    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
301 302


303 304
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
305 306 307
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

308 309 310 311 312
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
313
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
314
Then the Show instance is not done via Coercible; it shows
315
        Foo 3 as "Foo 3"
316
The Num instance is derived via Coercible, but the Show superclass
317 318 319 320
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
321 322
        (+) = ((+)@a)
        ...etc...
323 324 325 326
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


327 328 329 330 331 332
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.
333

Austin Seipp's avatar
Austin Seipp committed
334 335
************************************************************************
*                                                                      *
336
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
Austin Seipp's avatar
Austin Seipp committed
337 338 339
*                                                                      *
************************************************************************
-}
340

341 342
tcDeriving  :: [LTyClDecl Name]  -- All type constructors
            -> [LInstDecl Name]  -- All instance declarations
343
            -> [LDerivDecl Name] -- All stand-alone deriving declarations
344
            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
345
tcDeriving tycl_decls inst_decls deriv_decls
346 347
  = recoverM (do { g <- getGblEnv
                 ; return (g, emptyBag, emptyValBindsOut)}) $
348 349
    do  {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
350
          is_boot <- tcIsHsBootOrSig
351
        ; traceTc "tcDeriving" (ppr is_boot)
352

353
        ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
354
        ; traceTc "tcDeriving 1" (ppr early_specs)
355

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
356 357 358
        -- 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)
359
        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
360

361
        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
362
        ; insts1 <- mapM (genInst commonAuxs) given_specs
363

jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
364 365
        -- the stand-alone derived instances (@insts1@) are used when inferring
        -- the contexts for "deriving" clauses' instances (@infer_specs@)
366
        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
367
                         inferInstanceContexts infer_specs
368

369
        ; insts2 <- mapM (genInst commonAuxs) final_specs
370

371
        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
dreixel's avatar
dreixel committed
372
        ; loc <- getSrcSpanM
373
        ; let (binds, newTyCons, famInsts, extraInstances) =
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
374 375
                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))

376 377
        ; dflags <- getDynFlags

dreixel's avatar
dreixel committed
378 379
        ; (inst_info, rn_binds, rn_dus) <-
            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
380

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
385 386 387 388 389
        ; 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
390 391
        ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
392
  where
393
    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
394 395
                   -> Bag TyCon               -- ^ Empty data constructors
                   -> Bag FamInst             -- ^ Rep type family instances
396
                   -> SDoc
397
    ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
dreixel's avatar
dreixel committed
398
      =    hang (ptext (sLit "Derived instances:"))
399
              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
400
                 $$ ppr extra_binds)
dreixel's avatar
dreixel committed
401 402 403 404
        $$ hangP "Generic representation:" (
              hangP "Generated datatypes for meta-information:"
               (vcat (map ppr (bagToList repMetaTys)))
           $$ hangP "Representation types:"
405 406
                (vcat (map pprRepTy (bagToList repFamInsts))))

407
    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
408

409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
{-
genTypeableTyConReps :: DynFlags ->
                        [LTyClDecl Name] ->
                        [LInstDecl Name] ->
                        TcM (Bag (LHsBind RdrName, LSig RdrName))
genTypeableTyConReps dflags decls insts =
  do tcs1 <- mapM tyConsFromDecl decls
     tcs2 <- mapM tyConsFromInst insts
     return $ listToBag [ genTypeableTyConRep dflags loc tc
                                          | (loc,tc) <- concat (tcs1 ++ tcs2) ]
  where

  tyConFromDataCon (L l n) = do dc <- tcLookupDataCon n
                                return (do tc <- promoteDataCon_maybe dc
                                           return (l,tc))

  -- Promoted data constructors from a data declaration, or
  -- a data-family instance.
  tyConsFromDataRHS = fmap catMaybes
                    . mapM tyConFromDataCon
                    . concatMap (con_names . unLoc)
                    . dd_cons

  -- Tycons from a data-family declaration; not promotable.
  tyConFromDataFamDecl FamilyDecl { fdLName = L loc name } =
    do tc <- tcLookupTyCon name
       return (loc,tc)


  -- tycons from a type-level declaration
  tyConsFromDecl (L _ d)

    -- data or newtype declaration: promoted tycon, tycon, promoted ctrs.
    | isDataDecl d =
      do let L loc name = tcdLName d
         tc           <- tcLookupTyCon name
         promotedCtrs <- tyConsFromDataRHS (tcdDataDefn d)
         let tyCons = (loc,tc) : promotedCtrs

         return (case promotableTyCon_maybe tc of
                   Nothing -> tyCons
                   Just kc -> (loc,kc) : tyCons)

    -- data family: just the type constructor;  these are not promotable.
    | isDataFamilyDecl d =
      do res <- tyConFromDataFamDecl (tcdFam d)
         return [res]

    -- class: the type constructors of associated data families
    | isClassDecl d =
      let isData FamilyDecl { fdInfo = DataFamily } = True
          isData _ = False

      in mapM tyConFromDataFamDecl (filter isData (map unLoc (tcdATs d)))

    | otherwise = return []


  tyConsFromInst (L _ d) =
    case d of
      ClsInstD ci      -> fmap concat
                        $ mapM (tyConsFromDataRHS . dfid_defn . unLoc)
                        $ cid_datafam_insts ci
      DataFamInstD dfi -> tyConsFromDataRHS (dfid_defn dfi)
      TyFamInstD {}    -> return []
-}

476
-- Prints the representable type family instance
477 478
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
479
  = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
480 481
      equals <+> ppr rhs
  where rhs = famInstRHS fi
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
482 483 484 485 486

-- 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?
487 488

commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
jpm@cs.ox.ac.uk's avatar
jpm@cs.ox.ac.uk committed
489 490 491 492 493 494 495 496 497 498
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)

499
renameDeriv :: Bool
500
            -> [InstInfo RdrName]
501
            -> Bag (LHsBind RdrName, LSig RdrName)
502
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
dreixel's avatar
dreixel committed
503
renameDeriv is_boot inst_infos bagBinds
504 505 506 507 508
  | 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
509
                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
510

511
  | otherwise
512
  = discardWarnings $         -- Discard warnings about unused bindings etc
513
    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have
514
                              --    case x of {}
515 516
    setXOptM Opt_ScopedTypeVariables $  -- Derived decls (for newtype-deriving) can
    setXOptM Opt_KindSignatures $       -- used ScopedTypeVariables & KindSignatures
517
    do  {
dreixel's avatar
dreixel committed
518 519
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
520 521 522
        ; (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
523
        ; let bndrs = collectHsValBinders rn_aux_lhs
524 525 526
        ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
        ; setEnvs envs $
    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs) False) rn_aux_lhs
527 528
        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
        ; return (listToBag rn_inst_infos, rn_aux,
dreixel's avatar
dreixel committed
529
                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
530

531
  where
532
    rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
533 534 535 536
    rn_inst_info
      inst_info@(InstInfo { iSpec = inst
                          , iBinds = InstBindings
                            { ib_binds = binds
537
                            , ib_tyvars = tyvars
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
538
                            , ib_pragmas = sigs
539
                            , ib_extensions = exts -- Only for type-checking
540
                            , ib_derived = sa } })
541 542
        =  ASSERT( null sigs )
           bindLocalNamesFV tyvars $
543
           do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
544
              ; let binds' = InstBindings { ib_binds = rn_binds
545 546 547 548
                                          , ib_tyvars = tyvars
                                          , ib_pragmas = []
                                          , ib_extensions = exts
                                          , ib_derived = sa }
549
              ; return (inst_info { iBinds = binds' }, fvs) }
550

Austin Seipp's avatar
Austin Seipp committed
551
{-
552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
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...

567 568 569
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.
570

Austin Seipp's avatar
Austin Seipp committed
571 572
************************************************************************
*                                                                      *
573
                From HsSyn to DerivSpec
Austin Seipp's avatar
Austin Seipp committed
574 575
*                                                                      *
************************************************************************
576

577
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
Austin Seipp's avatar
Austin Seipp committed
578
-}
579

580 581 582 583 584
makeDerivSpecs :: Bool
               -> [LTyClDecl Name]
               -> [LInstDecl Name]
               -> [LDerivDecl Name]
               -> TcM [EarlyDerivSpec]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
585
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
586 587 588
  = do  { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl)     tycl_decls
        ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl)   inst_decls
        ; eqns3 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
589
        ; let eqns = eqns1 ++ eqns2 ++ eqns3
590

591
        ; if is_boot then   -- No 'deriving' at all in hs-boot files
592
              do { unless (null eqns) (add_deriv_err (head eqns))
593
                 ; return [] }
594
          else return eqns }
595
  where
596
    add_deriv_err eqn
597
       = setSrcSpan (earlyDSLoc eqn) $
598 599
         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
600

601 602
------------------------------------------------------------------
deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec]
603
deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name
604
                                 , tcdDataDefn = HsDataDefn { dd_derivs = preds } }))
605 606
  = tcAddDeclCtxt decl $
    do { tc <- tcLookupTyCon tc_name
607 608
       ; let tvs  = tyConTyVars tc
             tys  = mkTyVarTys tvs
609

610
       ; case preds of
611
          Just (L _ preds') -> concatMapM (deriveTyData tvs tc tys) preds'
612
          Nothing           -> return [] }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
613

614
deriveTyDecl _ = return []
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
615

616 617
------------------------------------------------------------------
deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec]
618 619
deriveInstDecl (L _ (TyFamInstD {})) = return []
deriveInstDecl (L _ (DataFamInstD { dfid_inst = fam_inst }))
620
  = deriveFamInst fam_inst
621
deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
622 623 624
  = concatMapM (deriveFamInst . unLoc) fam_insts

------------------------------------------------------------------
625
deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec]
626 627 628 629
deriveFamInst decl@(DataFamInstDecl
                       { dfid_tycon = L _ tc_name, dfid_pats = pats
                       , dfid_defn
                         = defn@(HsDataDefn { dd_derivs = Just (L _ preds) }) })
630
  = tcAddDataFamInstCtxt decl $
631
    do { fam_tc <- tcLookupTyCon tc_name
632 633
       ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $
             -- kcDataDefn defn: see Note [Finding the LHS patterns]
634
         \ tvs' pats' _ ->
635
           concatMapM (deriveTyData tvs' fam_tc pats') preds }
636 637

deriveFamInst _ = return []
638

Austin Seipp's avatar
Austin Seipp committed
639
{-
640 641 642 643 644 645 646 647 648 649 650 651 652 653
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 )
654

655 656 657
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
658
-}
659

660
------------------------------------------------------------------
661
deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
662
-- Standalone deriving declarations
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
663
--  e.g.   deriving instance Show a => Show (T a)
664
-- Rather like tcLocalInstDecl
665
deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
666 667
  = setSrcSpan loc                   $
    addErrCtxt (standaloneCtxt deriv_ty)  $
668
    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
669
       ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty
670 671 672
       ; traceTc "Standalone deriving;" $ vcat
              [ text "tvs:" <+> ppr tvs
              , text "theta:" <+> ppr theta
673 674
              , text "cls:" <+> ppr cls
              , text "tys:" <+> ppr inst_tys ]
675
                -- C.f. TcInstDcls.tcLocalInstDecl1
676
       ; checkTc (not (null inst_tys)) derivingNullaryErr
677

678 679
       ; let cls_tys = take (length inst_tys - 1) inst_tys
             inst_ty = last inst_tys
680 681 682 683
       ; traceTc "Standalone deriving:" $ vcat
              [ text "class:" <+> ppr cls
              , text "class types:" <+> ppr cls_tys
              , text "type:" <+> ppr inst_ty ]
684 685

       ; case tcSplitTyConApp_maybe inst_ty of
686
           Just (tc, tc_args)
687 688 689 690 691 692
              | className cls == typeableClassName
              -> do warn <- woptM Opt_WarnDerivingTypeable
                    when warn
                       $ addWarnTc
                       $ text "Standalone deriving `Typeable` has no effect."
                    return []
693 694

              | isAlgTyCon tc  -- All other classes
695 696
              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
                                        tvs cls cls_tys tc tc_args (Just theta)
697
                    ; return [spec] }
698 699 700 701 702

           _  -> -- 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")
        }
703

704 705

------------------------------------------------------------------
706
deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
Simon Peyton Jones's avatar
Simon Peyton Jones committed
707
                                             --   Can be a data instance, hence [Type] args
708
             -> LHsType Name                 -- The deriving predicate
709
             -> TcM [EarlyDerivSpec]
dreixel's avatar
dreixel committed
710
-- The deriving clause of a data or newtype declaration
711
-- I.e. not standalone deriving
712
deriveTyData tvs tc tc_args (L loc deriv_pred)
713
  = setSrcSpan loc     $        -- Use the location of the 'deriving' item
714 715 716
    do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
                <- tcExtendTyVarEnv tvs $
                   tcHsDeriv deriv_pred
717 718
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
719 720 721
                -- 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
722
                -- Typeable is special, because Typeable :: forall k. k -> Constraint
723 724
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
725
        ; if className cls == typeableClassName
726 727 728 729 730
          then do warn <- woptM Opt_WarnDerivingTypeable
                  when warn
                     $ addWarnTc
                     $ text "Deriving `Typeable` has no effect."
                  return []
731
          else
732

733
     do {  -- Given data T a b c = ... deriving( C d ),
734 735
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
          let (arg_kinds, _)  = splitKindFunTys cls_arg_kind
736 737 738 739 740 741 742
              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

743 744 745 746
              -- 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
747
              Just kind_subst = mb_match
748
              (univ_kvs, univ_tvs) = partition isKindVar $ varSetElems $
749
                                     mkVarSet deriv_tvs `unionVarSet`
750 751 752 753 754
                                     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
755

Simon Peyton Jones's avatar
Simon Peyton Jones committed
756
        ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
757 758
                                       , pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args)
                                       , ppr n_args_to_keep, ppr n_args_to_drop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
759 760
                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
                                       , ppr final_tc_args, ppr final_cls_tys ])
dterei's avatar
dterei committed
761

762
        -- Check that the result really is well-kinded
763
        ; checkTc (n_args_to_keep >= 0 && isJust mb_match)
764
                  (derivingKindErr tc cls cls_tys cls_arg_kind)
765

766 767
        ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ])

768 769 770
        ; 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))
771
                -- Check that
772 773
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
774 775 776 777 778
                --  (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
779
                --              newtype T a s = ... deriving( ST s )
780 781
                --              newtype K a a = ... deriving( Monad )

782
        ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs')
783
                            cls final_cls_tys tc final_tc_args Nothing
784
        ; return [spec] } }
785

786

Austin Seipp's avatar
Austin Seipp committed
787
{-
788
Note [Unify kinds in deriving]
789 790 791 792 793 794 795 796 797
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

798 799 800 801 802 803
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
804 805
  instance Category * (Either a) where ...
Notice the '*' argument to Category.
806 807 808 809 810 811 812 813 814

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,
815 816 817 818 819 820 821 822
 * 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:=*

823
Now we get a kind substitution.  We then need to:
824

825
  1. Remove the substituted-out kind variables from the quantified kind vars
826 827 828 829 830 831 832 833 834 835 836 837 838 839

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

844 845
mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
846 847
          -> Class -> [Type]
          -> TyCon -> [Type]
848 849
          -> DerivContext       -- Just    => context supplied (standalone deriving)
                                -- Nothing => context inferred (deriving on data decl)
850 851
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
852
--      forall tvs. theta => cls (tys ++ [ty])
853 854 855
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

856
mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
857 858 859 860 861 862 863 864
  = 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)))
865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889

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

             -- Make a Qual RdrName that will do for each DataCon
             -- so we can report it as used (Trac #7969)
             data_con_rdrs = [ mkRdrQual (is_as (is_decl imp_spec)) occ
                             | dc_name <- data_con_names
                             , let occ  = nameOccName dc_name
                                   gres = lookupGRE_Name rdr_env dc_name
                             , not (null gres)
                             , Imported (imp_spec:_) <- [gre_prov (head gres)] ]

       ; addUsedRdrNames data_con_rdrs
       ; unless (isNothing mtheta || not hidden_data_cons)
                (bale_out (derivingHiddenErr tycon))

       ; dflags <- getDynFlags
       ; if isDataTyCon rep_tc then
890
            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
891 892
                          tycon tc_args rep_tc rep_tc_args mtheta
         else
893
            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
894
                         tycon tc_args rep_tc rep_tc_args mtheta }
895
  where
896
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
897

Austin Seipp's avatar
Austin Seipp committed
898
{-
899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914
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 ())