WIP on Doing a combined Step 1 and 3 for Trees That Grow
[ghc.git] / compiler / typecheck / TcDeriv.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Handles @deriving@ clauses on @data@ declarations.
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
13
14 #include "HsVersions.h"
15
16 import GhcPrelude
17
18 import HsSyn
19 import DynFlags
20
21 import TcRnMonad
22 import FamInst
23 import TcDerivInfer
24 import TcDerivUtils
25 import TcValidity( allDistinctTyVars )
26 import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
27 import TcEnv
28 import TcGenDeriv -- Deriv stuff
29 import InstEnv
30 import Inst
31 import FamInstEnv
32 import TcHsType
33
34 import RnNames( extendGlobalRdrEnvRn )
35 import RnBinds
36 import RnEnv
37 import RnUtils ( bindLocalNamesFV )
38 import RnSource ( addTcgDUs )
39 import Avail
40
41 import Unify( tcUnifyTy )
42 import BasicTypes ( DerivStrategy(..) )
43 import Class
44 import Type
45 import ErrUtils
46 import DataCon
47 import Maybes
48 import RdrName
49 import Name
50 import NameSet
51 import TyCon
52 import TcType
53 import Var
54 import VarEnv
55 import VarSet
56 import PrelNames
57 import SrcLoc
58 import Util
59 import Outputable
60 import FastString
61 import Bag
62 import Pair
63 import FV (fvVarList, unionFV, mkFVs)
64 import qualified GHC.LanguageExtensions as LangExt
65
66 import Control.Monad
67 import Control.Monad.Trans.Class
68 import Control.Monad.Trans.Reader
69 import Data.List
70
71 {-
72 ************************************************************************
73 * *
74 Overview
75 * *
76 ************************************************************************
77
78 Overall plan
79 ~~~~~~~~~~~~
80 1. Convert the decls (i.e. data/newtype deriving clauses,
81 plus standalone deriving) to [EarlyDerivSpec]
82
83 2. Infer the missing contexts for the InferTheta's
84
85 3. Add the derived bindings, generating InstInfos
86 -}
87
88 data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
89 | GivenTheta (DerivSpec ThetaType)
90 -- InferTheta ds => the context for the instance should be inferred
91 -- In this case ds_theta is the list of all the sets of
92 -- constraints needed, such as (Eq [a], Eq a), together with a
93 -- suitable CtLoc to get good error messages.
94 -- The inference process is to reduce this to a
95 -- simpler form (e.g. Eq a)
96 --
97 -- GivenTheta ds => the exact context for the instance is supplied
98 -- by the programmer; it is ds_theta
99 -- See Note [Inferring the instance context] in TcDerivInfer
100
101 earlyDSLoc :: EarlyDerivSpec -> SrcSpan
102 earlyDSLoc (InferTheta spec) = ds_loc spec
103 earlyDSLoc (GivenTheta spec) = ds_loc spec
104
105 splitEarlyDerivSpec :: [EarlyDerivSpec]
106 -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
107 splitEarlyDerivSpec [] = ([],[])
108 splitEarlyDerivSpec (InferTheta spec : specs) =
109 case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
110 splitEarlyDerivSpec (GivenTheta spec : specs) =
111 case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
112
113 instance Outputable EarlyDerivSpec where
114 ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
115 ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
116
117 {-
118 Note [Data decl contexts]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~
120 Consider
121
122 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
123
124 We will need an instance decl like:
125
126 instance (Read a, RealFloat a) => Read (Complex a) where
127 ...
128
129 The RealFloat in the context is because the read method for Complex is bound
130 to construct a Complex, and doing that requires that the argument type is
131 in RealFloat.
132
133 But this ain't true for Show, Eq, Ord, etc, since they don't construct
134 a Complex; they only take them apart.
135
136 Our approach: identify the offending classes, and add the data type
137 context to the instance decl. The "offending classes" are
138
139 Read, Enum?
140
141 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
142 pattern matching against a constructor from a data type with a context
143 gives rise to the constraints for that context -- or at least the thinned
144 version. So now all classes are "offending".
145
146 Note [Newtype deriving]
147 ~~~~~~~~~~~~~~~~~~~~~~~
148 Consider this:
149 class C a b
150 instance C [a] Char
151 newtype T = T Char deriving( C [a] )
152
153 Notice the free 'a' in the deriving. We have to fill this out to
154 newtype T = T Char deriving( forall a. C [a] )
155
156 And then translate it to:
157 instance C [a] Char => C [a] T where ...
158
159
160 Note [Newtype deriving superclasses]
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
162 (See also Trac #1220 for an interesting exchange on newtype
163 deriving and superclasses.)
164
165 The 'tys' here come from the partial application in the deriving
166 clause. The last arg is the new instance type.
167
168 We must pass the superclasses; the newtype might be an instance
169 of them in a different way than the representation type
170 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
171 Then the Show instance is not done via Coercible; it shows
172 Foo 3 as "Foo 3"
173 The Num instance is derived via Coercible, but the Show superclass
174 dictionary must the Show instance for Foo, *not* the Show dictionary
175 gotten from the Num dictionary. So we must build a whole new dictionary
176 not just use the Num one. The instance we want is something like:
177 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
178 (+) = ((+)@a)
179 ...etc...
180 There may be a coercion needed which we get from the tycon for the newtype
181 when the dict is constructed in TcInstDcls.tcInstDecl2
182
183
184 Note [Unused constructors and deriving clauses]
185 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
186 See Trac #3221. Consider
187 data T = T1 | T2 deriving( Show )
188 Are T1 and T2 unused? Well, no: the deriving clause expands to mention
189 both of them. So we gather defs/uses from deriving just like anything else.
190
191 -}
192
193 -- | Stuff needed to process a datatype's `deriving` clauses
194 data DerivInfo = DerivInfo { di_rep_tc :: TyCon
195 -- ^ The data tycon for normal datatypes,
196 -- or the *representation* tycon for data families
197 , di_clauses :: [LHsDerivingClause GhcRn]
198 , di_ctxt :: SDoc -- ^ error context
199 }
200
201 -- | Extract `deriving` clauses of proper data type (skips data families)
202 mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
203 mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
204 where
205
206 mk_deriv decl@(DataDecl { tcdLName = L _ data_name
207 , tcdDataDefn =
208 HsDataDefn { dd_derivs = L _ clauses } })
209 = do { tycon <- tcLookupTyCon data_name
210 ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses
211 , di_ctxt = tcMkDeclCtxt decl }] }
212 mk_deriv _ = return []
213
214 {-
215
216 ************************************************************************
217 * *
218 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
219 * *
220 ************************************************************************
221 -}
222
223 tcDeriving :: [DerivInfo] -- All `deriving` clauses
224 -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
225 -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
226 tcDeriving deriv_infos deriv_decls
227 = recoverM (do { g <- getGblEnv
228 ; return (g, emptyBag, emptyValBindsOut)}) $
229 do { -- Fish the "deriving"-related information out of the TcEnv
230 -- And make the necessary "equations".
231 is_boot <- tcIsHsBootOrSig
232 ; traceTc "tcDeriving" (ppr is_boot)
233
234 ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
235 ; traceTc "tcDeriving 1" (ppr early_specs)
236
237 ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
238 ; insts1 <- mapM genInst given_specs
239 ; insts2 <- mapM genInst infer_specs
240
241 ; dflags <- getDynFlags
242
243 ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
244 ; loc <- getSrcSpanM
245 ; let (binds, famInsts) = genAuxBinds dflags loc
246 (unionManyBags deriv_stuff)
247
248 ; let mk_inst_infos1 = map fstOf3 insts1
249 ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs
250
251 -- We must put all the derived type family instances (from both
252 -- infer_specs and given_specs) in the local instance environment
253 -- before proceeding, or else simplifyInstanceContexts might
254 -- get stuck if it has to reason about any of those family instances.
255 -- See Note [Staging of tcDeriving]
256 ; tcExtendLocalFamInstEnv (bagToList famInsts) $
257 -- NB: only call tcExtendLocalFamInstEnv once, as it performs
258 -- validity checking for all of the family instances you give it.
259 -- If the family instances have errors, calling it twice will result
260 -- in duplicate error messages!
261
262 do {
263 -- the stand-alone derived instances (@inst_infos1@) are used when
264 -- inferring the contexts for "deriving" clauses' instances
265 -- (@infer_specs@)
266 ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $
267 simplifyInstanceContexts infer_specs
268
269 ; let mk_inst_infos2 = map fstOf3 insts2
270 ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs
271 ; let inst_infos = inst_infos1 ++ inst_infos2
272
273 ; (inst_info, rn_binds, rn_dus) <-
274 renameDeriv is_boot inst_infos binds
275
276 ; unless (isEmptyBag inst_info) $
277 liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
278 (ddump_deriving inst_info rn_binds famInsts))
279
280 ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
281 getGblEnv
282 ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
283 ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
284 where
285 ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
286 -> Bag FamInst -- ^ Rep type family instances
287 -> SDoc
288 ddump_deriving inst_infos extra_binds repFamInsts
289 = hang (text "Derived class instances:")
290 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
291 $$ ppr extra_binds)
292 $$ hangP "Derived type family instances:"
293 (vcat (map pprRepTy (bagToList repFamInsts)))
294
295 hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
296
297 -- Apply the suspended computations given by genInst calls.
298 -- See Note [Staging of tcDeriving]
299 apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
300 -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
301 apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))
302
303 -- Prints the representable type family instance
304 pprRepTy :: FamInst -> SDoc
305 pprRepTy fi@(FamInst { fi_tys = lhs })
306 = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
307 equals <+> ppr rhs
308 where rhs = famInstRHS fi
309
310 renameDeriv :: Bool
311 -> [InstInfo GhcPs]
312 -> Bag (LHsBind GhcPs, LSig GhcPs)
313 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
314 renameDeriv is_boot inst_infos bagBinds
315 | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
316 -- The inst-info bindings will all be empty, but it's easier to
317 -- just use rn_inst_info to change the type appropriately
318 = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
319 ; return ( listToBag rn_inst_infos
320 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
321
322 | otherwise
323 = discardWarnings $
324 -- Discard warnings about unused bindings etc
325 setXOptM LangExt.EmptyCase $
326 -- Derived decls (for empty types) can have
327 -- case x of {}
328 setXOptM LangExt.ScopedTypeVariables $
329 setXOptM LangExt.KindSignatures $
330 -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
331 -- KindSignatures
332 unsetXOptM LangExt.RebindableSyntax $
333 -- See Note [Avoid RebindableSyntax when deriving]
334 do {
335 -- Bring the extra deriving stuff into scope
336 -- before renaming the instances themselves
337 ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
338 ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
339 ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)
340 ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
341 ; let bndrs = collectHsValBinders rn_aux_lhs
342 ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
343 ; setEnvs envs $
344 do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
345 ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
346 ; return (listToBag rn_inst_infos, rn_aux,
347 dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
348
349 where
350 rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
351 rn_inst_info
352 inst_info@(InstInfo { iSpec = inst
353 , iBinds = InstBindings
354 { ib_binds = binds
355 , ib_tyvars = tyvars
356 , ib_pragmas = sigs
357 , ib_extensions = exts -- Only for type-checking
358 , ib_derived = sa } })
359 = ASSERT( null sigs )
360 bindLocalNamesFV tyvars $
361 do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
362 ; let binds' = InstBindings { ib_binds = rn_binds
363 , ib_tyvars = tyvars
364 , ib_pragmas = []
365 , ib_extensions = exts
366 , ib_derived = sa }
367 ; return (inst_info { iBinds = binds' }, fvs) }
368
369 {-
370 Note [Newtype deriving and unused constructors]
371 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
372 Consider this (see Trac #1954):
373
374 module Bug(P) where
375 newtype P a = MkP (IO a) deriving Monad
376
377 If you compile with -Wunused-binds you do not expect the warning
378 "Defined but not used: data constructor MkP". Yet the newtype deriving
379 code does not explicitly mention MkP, but it should behave as if you
380 had written
381 instance Monad P where
382 return x = MkP (return x)
383 ...etc...
384
385 So we want to signal a user of the data constructor 'MkP'.
386 This is the reason behind the [Name] part of the return type
387 of genInst.
388
389 Note [Staging of tcDeriving]
390 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
391 Here's a tricky corner case for deriving (adapted from Trac #2721):
392
393 class C a where
394 type T a
395 foo :: a -> T a
396
397 instance C Int where
398 type T Int = Int
399 foo = id
400
401 newtype N = N Int deriving C
402
403 This will produce an instance something like this:
404
405 instance C N where
406 type T N = T Int
407 foo = coerce (foo :: Int -> T Int) :: N -> T N
408
409 We must be careful in order to typecheck this code. When determining the
410 context for the instance (in simplifyInstanceContexts), we need to determine
411 that T N and T Int have the same representation, but to do that, the T N
412 instance must be in the local family instance environment. Otherwise, GHC
413 would be unable to conclude that T Int is representationally equivalent to
414 T Int, and simplifyInstanceContexts would get stuck.
415
416 Previously, tcDeriving would defer adding any derived type family instances to
417 the instance environment until the very end, which meant that
418 simplifyInstanceContexts would get called without all the type family instances
419 it needed in the environment in order to properly simplify instance like
420 the C N instance above.
421
422 To avoid this scenario, we carefully structure the order of events in
423 tcDeriving. We first call genInst on the standalone derived instance specs and
424 the instance specs obtained from deriving clauses. Note that the return type of
425 genInst is a triple:
426
427 TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)
428
429 The type family instances are in the BagDerivStuff. The first field of the
430 triple is a suspended computation which, given an instance context, produces
431 the rest of the instance. The fact that it is suspended is important, because
432 right now, we don't have ThetaTypes for the instances that use deriving clauses
433 (only the standalone-derived ones).
434
435 Now we can can collect the type family instances and extend the local instance
436 environment. At this point, it is safe to run simplifyInstanceContexts on the
437 deriving-clause instance specs, which gives us the ThetaTypes for the
438 deriving-clause instances. Now we can feed all the ThetaTypes to the
439 suspended computations and obtain our InstInfos, at which point
440 tcDeriving is done.
441
442 An alternative design would be to split up genInst so that the
443 family instances are generated separately from the InstInfos. But this would
444 require carving up a lot of the GHC deriving internals to accommodate the
445 change. On the other hand, we can keep all of the InstInfo and type family
446 instance logic together in genInst simply by converting genInst to
447 continuation-returning style, so we opt for that route.
448
449 Note [Why we don't pass rep_tc into deriveTyData]
450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
451 Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
452 the rep_tc by means of a lookup. And yet we have the rep_tc right here!
453 Why look it up again? Answer: it's just easier this way.
454 We drop some number of arguments from the end of the datatype definition
455 in deriveTyData. The arguments are dropped from the fam_tc.
456 This action may drop a *different* number of arguments
457 passed to the rep_tc, depending on how many free variables, etc., the
458 dropped patterns have.
459
460 Also, this technique carries over the kind substitution from deriveTyData
461 nicely.
462
463 Note [Avoid RebindableSyntax when deriving]
464 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
465 The RebindableSyntax extension interacts awkwardly with the derivation of
466 any stock class whose methods require the use of string literals. The Show
467 class is a simple example (see Trac #12688):
468
469 {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
470 newtype Text = Text String
471 fromString :: String -> Text
472 fromString = Text
473
474 data Foo = Foo deriving Show
475
476 This will generate code to the effect of:
477
478 instance Show Foo where
479 showsPrec _ Foo = showString "Foo"
480
481 But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
482 string literal is now of type Text, not String, which showString doesn't
483 accept! This causes the generated Show instance to fail to typecheck.
484
485 To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
486 in derived code.
487
488 ************************************************************************
489 * *
490 From HsSyn to DerivSpec
491 * *
492 ************************************************************************
493
494 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
495 -}
496
497 makeDerivSpecs :: Bool
498 -> [DerivInfo]
499 -> [LDerivDecl GhcRn]
500 -> TcM [EarlyDerivSpec]
501 makeDerivSpecs is_boot deriv_infos deriv_decls
502 = do { -- We carefully set up uses of recoverM to minimize error message
503 -- cascades. See Note [Flattening deriving clauses].
504 ; eqns1 <- sequenceA
505 [ recoverM (pure Nothing)
506 (deriveClause rep_tc (fmap unLoc dcs)
507 pred err_ctxt)
508 | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
509 , di_ctxt = err_ctxt } <- deriv_infos
510 , L _ (HsDerivingClause { deriv_clause_strategy = dcs
511 , deriv_clause_tys = L _ preds })
512 <- clauses
513 , pred <- preds
514 ]
515 ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
516 ; let eqns = catMaybes (eqns1 ++ eqns2)
517
518 ; if is_boot then -- No 'deriving' at all in hs-boot files
519 do { unless (null eqns) (add_deriv_err (head eqns))
520 ; return [] }
521 else return eqns }
522 where
523 add_deriv_err eqn
524 = setSrcSpan (earlyDSLoc eqn) $
525 addErr (hang (text "Deriving not permitted in hs-boot file")
526 2 (text "Use an instance declaration instead"))
527
528 {-
529 Note [Flattening deriving clauses]
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
531 Consider what happens if you run this program (from Trac #10684) without
532 DeriveGeneric enabled:
533
534 data A = A deriving (Show, Generic)
535 data B = B A deriving (Show)
536
537 Naturally, you'd expect GHC to give an error to the effect of:
538
539 Can't make a derived instance of `Generic A':
540 You need -XDeriveGeneric to derive an instance for this class
541
542 And *only* that error, since the other two derived Show instances appear to be
543 independent of this derived Generic instance. Yet GHC also used to give this
544 additional error on the program above:
545
546 No instance for (Show A)
547 arising from the 'deriving' clause of a data type declaration
548 When deriving the instance for (Show B)
549
550 This was happening because when GHC encountered any error within a single
551 data type's set of deriving clauses, it would call recoverM and move on
552 to the next data type's deriving clauses. One unfortunate consequence of
553 this design is that if A's derived Generic instance failed, so its derived
554 Show instance would be skipped entirely, leading to the "No instance for
555 (Show A)" error cascade.
556
557 The solution to this problem is to "flatten" the set of classes that are
558 derived for a particular data type via deriving clauses. That is, if
559 you have:
560
561 newtype C = C D
562 deriving (E, F, G)
563 deriving anyclass (H, I, J)
564 deriving newtype (K, L, M)
565
566 Then instead of processing instances E through M under the scope of a single
567 recoverM, we flatten these deriving clauses into the list:
568
569 [ E (Nothing)
570 , F (Nothing)
571 , G (Nothing)
572 , H (Just anyclass)
573 , I (Just anyclass)
574 , J (Just anyclass)
575 , K (Just newtype)
576 , L (Just newtype)
577 , M (Just newtype) ]
578
579 And then process each class individually, under its own recoverM scope. That
580 way, failure to derive one class doesn't cancel out other classes in the
581 same set of clause-derived classes.
582 -}
583
584 ------------------------------------------------------------------
585 -- | Process a single class in a `deriving` clause.
586 deriveClause :: TyCon -> Maybe DerivStrategy -> LHsSigType GhcRn -> SDoc
587 -> TcM (Maybe EarlyDerivSpec)
588 deriveClause rep_tc mb_strat pred err_ctxt
589 = addErrCtxt err_ctxt $
590 deriveTyData tvs tc tys mb_strat pred
591 where
592 tvs = tyConTyVars rep_tc
593 (tc, tys) = case tyConFamInstSig_maybe rep_tc of
594 -- data family:
595 Just (fam_tc, pats, _) -> (fam_tc, pats)
596 -- NB: deriveTyData wants the *user-specified*
597 -- name. See Note [Why we don't pass rep_tc into deriveTyData]
598
599 _ -> (rep_tc, mkTyVarTys tvs) -- datatype
600
601 ------------------------------------------------------------------
602 deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
603 -- Process a single standalone deriving declaration
604 -- e.g. deriving instance Show a => Show (T a)
605 -- Rather like tcLocalInstDecl
606 --
607 -- This returns a Maybe because the user might try to derive Typeable, which is
608 -- a no-op nowadays.
609 deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
610 = setSrcSpan loc $
611 addErrCtxt (standaloneCtxt deriv_ty) $
612 do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
613 ; let deriv_strat = fmap unLoc deriv_strat'
614 ; traceTc "Deriving strategy (standalone deriving)" $
615 vcat [ppr deriv_strat, ppr deriv_ty]
616 ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
617 ; traceTc "Standalone deriving;" $ vcat
618 [ text "tvs:" <+> ppr tvs
619 , text "theta:" <+> ppr theta
620 , text "cls:" <+> ppr cls
621 , text "tys:" <+> ppr inst_tys ]
622 -- C.f. TcInstDcls.tcLocalInstDecl1
623 ; checkTc (not (null inst_tys)) derivingNullaryErr
624
625 ; let cls_tys = take (length inst_tys - 1) inst_tys
626 inst_ty = last inst_tys
627 ; traceTc "Standalone deriving:" $ vcat
628 [ text "class:" <+> ppr cls
629 , text "class types:" <+> ppr cls_tys
630 , text "type:" <+> ppr inst_ty ]
631
632 ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
633 inst_ty deriv_strat msg)
634
635 ; case tcSplitTyConApp_maybe inst_ty of
636 Just (tc, tc_args)
637 | className cls == typeableClassName
638 -> do warnUselessTypeable
639 return Nothing
640
641 | isUnboxedTupleTyCon tc
642 -> bale_out $ unboxedTyConErr "tuple"
643
644 | isUnboxedSumTyCon tc
645 -> bale_out $ unboxedTyConErr "sum"
646
647 | isAlgTyCon tc || isDataFamilyTyCon tc -- All other classes
648 -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
649 tvs cls cls_tys tc tc_args
650 (Just theta) deriv_strat
651 ; return $ Just spec }
652
653 _ -> -- Complain about functions, primitive types, etc,
654 bale_out $
655 text "The last argument of the instance must be a data or newtype application"
656 }
657
658 warnUselessTypeable :: TcM ()
659 warnUselessTypeable
660 = do { warn <- woptM Opt_WarnDerivingTypeable
661 ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
662 $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
663 text "has no effect: all types now auto-derive Typeable" }
664
665 ------------------------------------------------------------------
666 deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
667 -- Can be a data instance, hence [Type] args
668 -> Maybe DerivStrategy -- The optional deriving strategy
669 -> LHsSigType GhcRn -- The deriving predicate
670 -> TcM (Maybe EarlyDerivSpec)
671 -- The deriving clause of a data or newtype declaration
672 -- I.e. not standalone deriving
673 --
674 -- This returns a Maybe because the user might try to derive Typeable, which is
675 -- a no-op nowadays.
676 deriveTyData tvs tc tc_args deriv_strat deriv_pred
677 = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item
678 do { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
679 <- tcExtendTyVarEnv tvs $
680 tcHsDeriv deriv_pred
681 -- Deriving preds may (now) mention
682 -- the type variables for the type constructor, hence tcExtendTyVarenv
683 -- The "deriv_pred" is a LHsType to take account of the fact that for
684 -- newtype deriving we allow deriving (forall a. C [a]).
685
686 -- Typeable is special, because Typeable :: forall k. k -> Constraint
687 -- so the argument kind 'k' is not decomposable by splitKindFunTys
688 -- as is the case for all other derivable type classes
689 ; when (cls_arg_kinds `lengthIsNot` 1) $
690 failWithTc (nonUnaryErr deriv_pred)
691 ; let [cls_arg_kind] = cls_arg_kinds
692 ; if className cls == typeableClassName
693 then do warnUselessTypeable
694 return Nothing
695 else
696
697 do { -- Given data T a b c = ... deriving( C d ),
698 -- we want to drop type variables from T so that (C d (T a)) is well-kinded
699 let (arg_kinds, _) = splitFunTys cls_arg_kind
700 n_args_to_drop = length arg_kinds
701 n_args_to_keep = tyConArity tc - n_args_to_drop
702 (tc_args_to_keep, args_to_drop)
703 = splitAt n_args_to_keep tc_args
704 inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep)
705
706 -- Match up the kinds, and apply the resulting kind substitution
707 -- to the types. See Note [Unify kinds in deriving]
708 -- We are assuming the tycon tyvars and the class tyvars are distinct
709 mb_match = tcUnifyTy inst_ty_kind cls_arg_kind
710 enough_args = n_args_to_keep >= 0
711
712 -- Check that the result really is well-kinded
713 ; checkTc (enough_args && isJust mb_match)
714 (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)
715
716 ; let Just kind_subst = mb_match
717 ki_subst_range = getTCvSubstRangeFVs kind_subst
718 all_tkvs = toposortTyVars $
719 fvVarList $ unionFV
720 (tyCoFVsOfTypes tc_args_to_keep)
721 (FV.mkFVs deriv_tvs)
722 -- See Note [Unification of two kind variables in deriving]
723 unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
724 && not (v `elemVarSet` ki_subst_range))
725 all_tkvs
726 (subst, _) = mapAccumL substTyVarBndr
727 kind_subst unmapped_tkvs
728 final_tc_args = substTys subst tc_args_to_keep
729 final_cls_tys = substTys subst cls_tys
730 tkvs = tyCoVarsOfTypesWellScoped $
731 final_cls_tys ++ final_tc_args
732
733 ; traceTc "Deriving strategy (deriving clause)" $
734 vcat [ppr deriv_strat, ppr deriv_pred]
735
736 ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args
737 , ppr deriv_pred
738 , pprTyVars (tyCoVarsOfTypesList tc_args)
739 , ppr n_args_to_keep, ppr n_args_to_drop
740 , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
741 , ppr final_tc_args, ppr final_cls_tys ])
742
743 ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
744
745 ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop) -- (a, b, c)
746 (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
747 -- Check that
748 -- (a) The args to drop are all type variables; eg reject:
749 -- data instance T a Int = .... deriving( Monad )
750 -- (b) The args to drop are all *distinct* type variables; eg reject:
751 -- class C (a :: * -> * -> *) where ...
752 -- data instance T a a = ... deriving( C )
753 -- (c) The type class args, or remaining tycon args,
754 -- do not mention any of the dropped type variables
755 -- newtype T a s = ... deriving( ST s )
756 -- newtype instance K a a = ... deriving( Monad )
757 --
758 -- It is vital that the implementation of allDistinctTyVars
759 -- expand any type synonyms.
760 -- See Note [Eta-reducing type synonyms]
761
762 ; spec <- mkEqnHelp Nothing tkvs
763 cls final_cls_tys tc final_tc_args
764 Nothing deriv_strat
765 ; traceTc "derivTyData" (ppr spec)
766 ; return $ Just spec } }
767
768
769 {-
770 Note [Unify kinds in deriving]
771 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772 Consider (Trac #8534)
773 data T a b = MkT a deriving( Functor )
774 -- where Functor :: (*->*) -> Constraint
775
776 So T :: forall k. * -> k -> *. We want to get
777 instance Functor (T * (a:*)) where ...
778 Notice the '*' argument to T.
779
780 Moreover, as well as instantiating T's kind arguments, we may need to instantiate
781 C's kind args. Consider (Trac #8865):
782 newtype T a b = MkT (Either a b) deriving( Category )
783 where
784 Category :: forall k. (k -> k -> *) -> Constraint
785 We need to generate the instance
786 instance Category * (Either a) where ...
787 Notice the '*' argument to Category.
788
789 So we need to
790 * drop arguments from (T a b) to match the number of
791 arrows in the (last argument of the) class;
792 * and then *unify* kind of the remaining type against the
793 expected kind, to figure out how to instantiate C's and T's
794 kind arguments.
795
796 In the two examples,
797 * we unify kind-of( T k (a:k) ) ~ kind-of( Functor )
798 i.e. (k -> *) ~ (* -> *) to find k:=*.
799 yielding k:=*
800
801 * we unify kind-of( Either ) ~ kind-of( Category )
802 i.e. (* -> * -> *) ~ (k -> k -> k)
803 yielding k:=*
804
805 Now we get a kind substitution. We then need to:
806
807 1. Remove the substituted-out kind variables from the quantified kind vars
808
809 2. Apply the substitution to the kinds of quantified *type* vars
810 (and extend the substitution to reflect this change)
811
812 3. Apply that extended substitution to the non-dropped args (types and
813 kinds) of the type and class
814
815 Forgetting step (2) caused Trac #8893:
816 data V a = V [a] deriving Functor
817 data P (x::k->*) (a:k) = P (x a) deriving Functor
818 data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor
819
820 When deriving Functor for P, we unify k to *, but we then want
821 an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
822 and similarly for C. Notice the modified kind of x, both at binding
823 and occurrence sites.
824
825 This can lead to some surprising results when *visible* kind binder is
826 unified (in contrast to the above examples, in which only non-visible kind
827 binders were considered). Consider this example from Trac #11732:
828
829 data T k (a :: k) = MkT deriving Functor
830
831 Since unification yields k:=*, this results in a generated instance of:
832
833 instance Functor (T *) where ...
834
835 which looks odd at first glance, since one might expect the instance head
836 to be of the form Functor (T k). Indeed, one could envision an alternative
837 generated instance of:
838
839 instance (k ~ *) => Functor (T k) where
840
841 But this does not typecheck as the result of a -XTypeInType design decision:
842 kind equalities are not allowed to be bound in types, only terms. But in
843 essence, the two instance declarations are entirely equivalent, since even
844 though (T k) matches any kind k, the only possibly value for k is *, since
845 anything else is ill-typed. As a result, we can just as comfortably use (T *).
846
847 Another way of thinking about is: deriving clauses often infer constraints.
848 For example:
849
850 data S a = S a deriving Eq
851
852 infers an (Eq a) constraint in the derived instance. By analogy, when we
853 are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
854 The only distinction is that GHC instantiates equality constraints directly
855 during the deriving process.
856
857 Another quirk of this design choice manifests when typeclasses have visible
858 kind parameters. Consider this code (also from Trac #11732):
859
860 class Cat k (cat :: k -> k -> *) where
861 catId :: cat a a
862 catComp :: cat b c -> cat a b -> cat a c
863
864 instance Cat * (->) where
865 catId = id
866 catComp = (.)
867
868 newtype Fun a b = Fun (a -> b) deriving (Cat k)
869
870 Even though we requested a derived instance of the form (Cat k Fun), the
871 kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
872 the user wrote deriving (Cat *)).
873
874 Note [Unification of two kind variables in deriving]
875 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
876 As a special case of the Note above, it is possible to derive an instance of
877 a poly-kinded typeclass for a poly-kinded datatype. For example:
878
879 class Category (cat :: k -> k -> *) where
880 newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category
881
882 This case is suprisingly tricky. To see why, let's write out what instance GHC
883 will attempt to derive (using -fprint-explicit-kinds syntax):
884
885 instance Category k1 (T k2 c) where ...
886
887 GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
888 that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
889 the type variable binder for c, since its kind is (k2 -> k2 -> *).
890
891 We used to accomplish this by doing the following:
892
893 unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
894 (subst, _) = mapAccumL substTyVarBndr kind_subst unmapped_tkvs
895
896 Where all_tkvs contains all kind variables in the class and instance types (in
897 this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
898 this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
899 to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
900 This is bad, because applying that substitution yields the following instance:
901
902 instance Category k_new (T k1 c) where ...
903
904 In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
905 in an ill-kinded instance (this caused Trac #11837).
906
907 To prevent this, we need to filter out any variable from all_tkvs which either
908
909 1. Appears in the domain of kind_subst. notElemTCvSubst checks this.
910 2. Appears in the range of kind_subst. To do this, we compute the free
911 variable set of the range of kind_subst with getTCvSubstRangeFVs, and check
912 if a kind variable appears in that set.
913
914 Note [Eta-reducing type synonyms]
915 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
916 One can instantiate a type in a data family instance with a type synonym that
917 mentions other type variables:
918
919 type Const a b = a
920 data family Fam (f :: * -> *) (a :: *)
921 newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
922
923 With -XTypeInType, it is also possible to define kind synonyms, and they can
924 mention other types in a datatype declaration. For example,
925
926 type Const a b = a
927 newtype T f (a :: Const * f) = T (f a) deriving Functor
928
929 When deriving, we need to perform eta-reduction analysis to ensure that none of
930 the eta-reduced type variables are mentioned elsewhere in the declaration. But
931 we need to be careful, because if we don't expand through the Const type
932 synonym, we will mistakenly believe that f is an eta-reduced type variable and
933 fail to derive Functor, even though the code above is correct (see Trac #11416,
934 where this was first noticed). For this reason, we expand the type synonyms in
935 the eta-reduced types before doing any analysis.
936 -}
937
938 mkEqnHelp :: Maybe OverlapMode
939 -> [TyVar]
940 -> Class -> [Type]
941 -> TyCon -> [Type]
942 -> DerivContext -- Just => context supplied (standalone deriving)
943 -- Nothing => context inferred (deriving on data decl)
944 -> Maybe DerivStrategy
945 -> TcRn EarlyDerivSpec
946 -- Make the EarlyDerivSpec for an instance
947 -- forall tvs. theta => cls (tys ++ [ty])
948 -- where the 'theta' is optional (that's the Maybe part)
949 -- Assumes that this declaration is well-kinded
950
951 mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
952 = do { -- Find the instance of a data family
953 -- Note [Looking up family instances for deriving]
954 fam_envs <- tcGetFamInstEnvs
955 ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
956 -- If it's still a data family, the lookup failed; i.e no instance exists
957 ; when (isDataFamilyTyCon rep_tc)
958 (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
959 ; is_boot <- tcIsHsBootOrSig
960 ; when is_boot $
961 bale_out (text "Cannot derive instances in hs-boot files"
962 $+$ text "Write an instance declaration instead")
963
964 ; let deriv_env = DerivEnv
965 { denv_overlap_mode = overlap_mode
966 , denv_tvs = tvs
967 , denv_cls = cls
968 , denv_cls_tys = cls_tys
969 , denv_tc = tycon
970 , denv_tc_args = tc_args
971 , denv_rep_tc = rep_tc
972 , denv_rep_tc_args = rep_tc_args
973 , denv_mtheta = mtheta
974 , denv_strat = deriv_strat }
975 ; flip runReaderT deriv_env $
976 if isDataTyCon rep_tc then mkDataTypeEqn else mkNewTypeEqn }
977 where
978 bale_out msg = failWithTc (derivingThingErr False cls cls_tys
979 (mkTyConApp tycon tc_args) deriv_strat msg)
980
981 {-
982 Note [Looking up family instances for deriving]
983 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
984 tcLookupFamInstExact is an auxiliary lookup wrapper which requires
985 that looked-up family instances exist. If called with a vanilla
986 tycon, the old type application is simply returned.
987
988 If we have
989 data instance F () = ... deriving Eq
990 data instance F () = ... deriving Eq
991 then tcLookupFamInstExact will be confused by the two matches;
992 but that can't happen because tcInstDecls1 doesn't call tcDeriving
993 if there are any overlaps.
994
995 There are two other things that might go wrong with the lookup.
996 First, we might see a standalone deriving clause
997 deriving Eq (F ())
998 when there is no data instance F () in scope.
999
1000 Note that it's OK to have
1001 data instance F [a] = ...
1002 deriving Eq (F [(a,b)])
1003 where the match is not exact; the same holds for ordinary data types
1004 with standalone deriving declarations.
1005
1006 Note [Deriving, type families, and partial applications]
1007 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1008 When there are no type families, it's quite easy:
1009
1010 newtype S a = MkS [a]
1011 -- :CoS :: S ~ [] -- Eta-reduced
1012
1013 instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
1014 instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
1015
1016 When type familes are involved it's trickier:
1017
1018 data family T a b
1019 newtype instance T Int a = MkT [a] deriving( Eq, Monad )
1020 -- :RT is the representation type for (T Int a)
1021 -- :Co:RT :: :RT ~ [] -- Eta-reduced!
1022 -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced!
1023
1024 instance Eq [a] => Eq (T Int a) -- easy by coercion
1025 -- d1 :: Eq [a]
1026 -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
1027
1028 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
1029 -- d1 :: Monad []
1030 -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
1031
1032 Note the need for the eta-reduced rule axioms. After all, we can
1033 write it out
1034 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
1035 return x = MkT [x]
1036 ... etc ...
1037
1038 See Note [Eta reduction for data families] in FamInstEnv
1039
1040 %************************************************************************
1041 %* *
1042 Deriving data types
1043 * *
1044 ************************************************************************
1045 -}
1046
1047 mkDataTypeEqn :: DerivM EarlyDerivSpec
1048 mkDataTypeEqn
1049 = do mb_strat <- asks denv_strat
1050 let bale_out msg = do err <- derivingThingErrM False msg
1051 lift $ failWithTc err
1052 case mb_strat of
1053 Just StockStrategy -> mk_eqn_stock mk_data_eqn bale_out
1054 Just AnyclassStrategy -> mk_eqn_anyclass mk_data_eqn bale_out
1055 -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
1056 Just NewtypeStrategy -> bale_out gndNonNewtypeErr
1057 -- Lacking a user-requested deriving strategy, we will try to pick
1058 -- between the stock or anyclass strategies
1059 Nothing -> mk_eqn_no_mechanism mk_data_eqn bale_out
1060
1061 mk_data_eqn :: DerivSpecMechanism -- How GHC should proceed attempting to
1062 -- derive this instance, determined in
1063 -- mkDataTypeEqn/mkNewTypeEqn
1064 -> DerivM EarlyDerivSpec
1065 mk_data_eqn mechanism
1066 = do DerivEnv { denv_overlap_mode = overlap_mode
1067 , denv_tvs = tvs
1068 , denv_tc = tc
1069 , denv_tc_args = tc_args
1070 , denv_rep_tc = rep_tc
1071 , denv_cls = cls
1072 , denv_cls_tys = cls_tys
1073 , denv_mtheta = mtheta } <- ask
1074 let inst_ty = mkTyConApp tc tc_args
1075 inst_tys = cls_tys ++ [inst_ty]
1076 doDerivInstErrorChecks1 mechanism
1077 loc <- lift getSrcSpanM
1078 dfun_name <- lift $ newDFunName' cls tc
1079 case mtheta of
1080 Nothing -> -- Infer context
1081 do { (inferred_constraints, tvs', inst_tys')
1082 <- inferConstraints mechanism
1083 ; return $ InferTheta $ DS
1084 { ds_loc = loc
1085 , ds_name = dfun_name, ds_tvs = tvs'
1086 , ds_cls = cls, ds_tys = inst_tys'
1087 , ds_tc = rep_tc
1088 , ds_theta = inferred_constraints
1089 , ds_overlap = overlap_mode
1090 , ds_mechanism = mechanism } }
1091
1092 Just theta -> do -- Specified context
1093 return $ GivenTheta $ DS
1094 { ds_loc = loc
1095 , ds_name = dfun_name, ds_tvs = tvs
1096 , ds_cls = cls, ds_tys = inst_tys
1097 , ds_tc = rep_tc
1098 , ds_theta = theta
1099 , ds_overlap = overlap_mode
1100 , ds_mechanism = mechanism }
1101
1102 mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
1103 -> (SDoc -> DerivM EarlyDerivSpec)
1104 -> DerivM EarlyDerivSpec
1105 mk_eqn_stock go_for_it bale_out
1106 = do DerivEnv { denv_rep_tc = rep_tc
1107 , denv_cls = cls
1108 , denv_cls_tys = cls_tys
1109 , denv_mtheta = mtheta } <- ask
1110 dflags <- getDynFlags
1111 case checkSideConditions dflags mtheta cls cls_tys rep_tc of
1112 CanDerive -> mk_eqn_stock' go_for_it
1113 DerivableClassError msg -> bale_out msg
1114 _ -> bale_out (nonStdErr cls)
1115
1116 mk_eqn_stock' :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
1117 -> DerivM EarlyDerivSpec
1118 mk_eqn_stock' go_for_it
1119 = do cls <- asks denv_cls
1120 go_for_it $
1121 case hasStockDeriving cls of
1122 Just gen_fn -> DerivSpecStock gen_fn
1123 Nothing ->
1124 pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)
1125
1126 mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
1127 -> (SDoc -> DerivM EarlyDerivSpec)
1128 -> DerivM EarlyDerivSpec
1129 mk_eqn_anyclass go_for_it bale_out
1130 = do dflags <- getDynFlags
1131 case canDeriveAnyClass dflags of
1132 IsValid -> go_for_it DerivSpecAnyClass
1133 NotValid msg -> bale_out msg
1134
1135 mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
1136 -> (SDoc -> DerivM EarlyDerivSpec)
1137 -> DerivM EarlyDerivSpec
1138 mk_eqn_no_mechanism go_for_it bale_out
1139 = do DerivEnv { denv_tc = tc
1140 , denv_rep_tc = rep_tc
1141 , denv_cls = cls
1142 , denv_cls_tys = cls_tys
1143 , denv_mtheta = mtheta } <- ask
1144 dflags <- getDynFlags
1145
1146 -- See Note [Deriving instances for classes themselves]
1147 let dac_error msg
1148 | isClassTyCon rep_tc
1149 = quotes (ppr tc) <+> text "is a type class,"
1150 <+> text "and can only have a derived instance"
1151 $+$ text "if DeriveAnyClass is enabled"
1152 | otherwise
1153 = nonStdErr cls $$ msg
1154
1155 case checkSideConditions dflags mtheta cls cls_tys rep_tc of
1156 -- NB: pass the *representation* tycon to checkSideConditions
1157 NonDerivableClass msg -> bale_out (dac_error msg)
1158 DerivableClassError msg -> bale_out msg
1159 CanDerive -> mk_eqn_stock' go_for_it
1160 DerivableViaInstance -> go_for_it DerivSpecAnyClass
1161
1162 {-
1163 ************************************************************************
1164 * *
1165 Deriving newtypes
1166 * *
1167 ************************************************************************
1168 -}
1169
1170 mkNewTypeEqn :: DerivM EarlyDerivSpec
1171 mkNewTypeEqn
1172 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1173 = do DerivEnv { denv_overlap_mode = overlap_mode
1174 , denv_tvs = tvs
1175 , denv_tc = tycon
1176 , denv_tc_args = tc_args
1177 , denv_rep_tc = rep_tycon
1178 , denv_rep_tc_args = rep_tc_args
1179 , denv_cls = cls
1180 , denv_cls_tys = cls_tys
1181 , denv_mtheta = mtheta
1182 , denv_strat = mb_strat } <- ask
1183 dflags <- getDynFlags
1184
1185 let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
1186 deriveAnyClass = xopt LangExt.DeriveAnyClass dflags
1187 go_for_it_gnd = do
1188 lift $ traceTc "newtype deriving:" $
1189 ppr tycon <+> ppr rep_tys <+> ppr all_thetas
1190 let mechanism = DerivSpecNewtype rep_inst_ty
1191 doDerivInstErrorChecks1 mechanism
1192 dfun_name <- lift $ newDFunName' cls tycon
1193 loc <- lift getSrcSpanM
1194 case mtheta of
1195 Just theta -> return $ GivenTheta $ DS
1196 { ds_loc = loc
1197 , ds_name = dfun_name, ds_tvs = tvs
1198 , ds_cls = cls, ds_tys = inst_tys
1199 , ds_tc = rep_tycon
1200 , ds_theta = theta
1201 , ds_overlap = overlap_mode
1202 , ds_mechanism = mechanism }
1203 Nothing -> return $ InferTheta $ DS
1204 { ds_loc = loc
1205 , ds_name = dfun_name, ds_tvs = tvs
1206 , ds_cls = cls, ds_tys = inst_tys
1207 , ds_tc = rep_tycon
1208 , ds_theta = all_thetas
1209 , ds_overlap = overlap_mode
1210 , ds_mechanism = mechanism }
1211 bale_out = bale_out' newtype_deriving
1212 bale_out' b msg = do err <- derivingThingErrM b msg
1213 lift $ failWithTc err
1214
1215 non_std = nonStdErr cls
1216 suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"
1217 <+> text "newtype-deriving extension"
1218
1219 -- Here is the plan for newtype derivings. We see
1220 -- newtype T a1...an = MkT (t ak+1...an)
1221 -- deriving (.., C s1 .. sm, ...)
1222 -- where t is a type,
1223 -- ak+1...an is a suffix of a1..an, and are all tyvars
1224 -- ak+1...an do not occur free in t, nor in the s1..sm
1225 -- (C s1 ... sm) is a *partial applications* of class C
1226 -- with the last parameter missing
1227 -- (T a1 .. ak) matches the kind of C's last argument
1228 -- (and hence so does t)
1229 -- The latter kind-check has been done by deriveTyData already,
1230 -- and tc_args are already trimmed
1231 --
1232 -- We generate the instance
1233 -- instance forall ({a1..ak} u fvs(s1..sm)).
1234 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
1235 -- where T a1...ap is the partial application of
1236 -- the LHS of the correct kind and p >= k
1237 --
1238 -- NB: the variables below are:
1239 -- tc_tvs = [a1, ..., an]
1240 -- tyvars_to_keep = [a1, ..., ak]
1241 -- rep_ty = t ak .. an
1242 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
1243 -- tys = [s1, ..., sm]
1244 -- rep_fn' = t
1245 --
1246 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1247 -- We generate the instance
1248 -- instance Monad (ST s) => Monad (T s) where
1249
1250 nt_eta_arity = newTyConEtadArity rep_tycon
1251 -- For newtype T a b = MkT (S a a b), the TyCon
1252 -- machinery already eta-reduces the representation type, so
1253 -- we know that
1254 -- T a ~ S a a
1255 -- That's convenient here, because we may have to apply
1256 -- it to fewer than its original complement of arguments
1257
1258 -- Note [Newtype representation]
1259 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1260 -- Need newTyConRhs (*not* a recursive representation finder)
1261 -- to get the representation type. For example
1262 -- newtype B = MkB Int
1263 -- newtype A = MkA B deriving( Num )
1264 -- We want the Num instance of B, *not* the Num instance of Int,
1265 -- when making the Num instance of A!
1266 rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1267 rep_tys = cls_tys ++ [rep_inst_ty]
1268 rep_pred = mkClassPred cls rep_tys
1269 rep_pred_o = mkPredOrigin DerivOrigin TypeLevel rep_pred
1270 -- rep_pred is the representation dictionary, from where
1271 -- we are gong to get all the methods for the newtype
1272 -- dictionary
1273
1274 -- Next we figure out what superclass dictionaries to use
1275 -- See Note [Newtype deriving superclasses] above
1276 sc_preds :: [PredOrigin]
1277 cls_tyvars = classTyVars cls
1278 inst_ty = mkTyConApp tycon tc_args
1279 inst_tys = cls_tys ++ [inst_ty]
1280 sc_preds = map (mkPredOrigin DerivOrigin TypeLevel) $
1281 substTheta (zipTvSubst cls_tyvars inst_tys) $
1282 classSCTheta cls
1283
1284 -- Next we collect constraints for the class methods
1285 -- If there are no methods, we don't need any constraints
1286 -- Otherwise we need (C rep_ty), for the representation methods,
1287 -- and constraints to coerce each individual method
1288 meth_preds :: [PredOrigin]
1289 meths = classMethods cls
1290 meth_preds | null meths = [] -- No methods => no constraints
1291 -- (Trac #12814)
1292 | otherwise = rep_pred_o : coercible_constraints
1293 coercible_constraints
1294 = [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel
1295 (mkReprPrimEqPred t1 t2)
1296 | meth <- meths
1297 , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
1298 inst_tys rep_inst_ty meth ]
1299
1300 all_thetas :: [ThetaOrigin]
1301 all_thetas = [mkThetaOriginFromPreds $ meth_preds ++ sc_preds]
1302
1303 -------------------------------------------------------------------
1304 -- Figuring out whether we can only do this newtype-deriving thing
1305
1306 -- See Note [Determining whether newtype-deriving is appropriate]
1307 might_derive_via_coercible
1308 = not (non_coercible_class cls)
1309 && coercion_looks_sensible
1310 -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
1311 coercion_looks_sensible
1312 = eta_ok
1313 -- Check (a) from Note [GND and associated type families]
1314 && ats_ok
1315 -- Check (b) from Note [GND and associated type families]
1316 && isNothing at_without_last_cls_tv
1317
1318 -- Check that eta reduction is OK
1319 eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
1320 -- The newtype can be eta-reduced to match the number
1321 -- of type argument actually supplied
1322 -- newtype T a b = MkT (S [a] b) deriving( Monad )
1323 -- Here the 'b' must be the same in the rep type (S [a] b)
1324 -- And the [a] must not mention 'b'. That's all handled
1325 -- by nt_eta_rity.
1326
1327 (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
1328 ats_ok = null adf_tcs
1329 -- We cannot newtype-derive data family instances
1330
1331 at_without_last_cls_tv
1332 = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
1333 at_tcs = classATs cls
1334 last_cls_tv = ASSERT( notNull cls_tyvars )
1335 last cls_tyvars
1336
1337 cant_derive_err
1338 = vcat [ ppUnless eta_ok eta_msg
1339 , ppUnless ats_ok ats_msg
1340 , maybe empty at_tv_msg
1341 at_without_last_cls_tv]
1342 eta_msg = text "cannot eta-reduce the representation type enough"
1343 ats_msg = text "the class has associated data types"
1344 at_tv_msg at_tc = hang
1345 (text "the associated type" <+> quotes (ppr at_tc)
1346 <+> text "is not parameterized over the last type variable")
1347 2 (text "of the class" <+> quotes (ppr cls))
1348
1349 MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
1350 case mb_strat of
1351 Just StockStrategy -> mk_eqn_stock mk_data_eqn bale_out
1352 Just AnyclassStrategy -> mk_eqn_anyclass mk_data_eqn bale_out
1353 Just NewtypeStrategy ->
1354 -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
1355 -- we don't need to perform all of the checks we normally would,
1356 -- such as if the class being derived is known to produce ill-roled
1357 -- coercions (e.g., Traversable), since we can just derive the
1358 -- instance and let it error if need be.
1359 -- See Note [Determining whether newtype-deriving is appropriate]
1360 if coercion_looks_sensible && newtype_deriving
1361 then go_for_it_gnd
1362 else bale_out (cant_derive_err $$
1363 if newtype_deriving then empty else suggest_gnd)
1364 Nothing
1365 | might_derive_via_coercible
1366 && ((newtype_deriving && not deriveAnyClass)
1367 || std_class_via_coercible cls)
1368 -> go_for_it_gnd
1369 | otherwise
1370 -> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1371 DerivableClassError msg
1372 -- There's a particular corner case where
1373 --
1374 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
1375 -- both enabled at the same time
1376 -- 2. We're deriving a particular stock derivable class
1377 -- (such as Functor)
1378 --
1379 -- and the previous cases won't catch it. This fixes the bug
1380 -- reported in Trac #10598.
1381 | might_derive_via_coercible && newtype_deriving
1382 -> go_for_it_gnd
1383 -- Otherwise, throw an error for a stock class
1384 | might_derive_via_coercible && not newtype_deriving
1385 -> bale_out (msg $$ suggest_gnd)
1386 | otherwise
1387 -> bale_out msg
1388
1389 -- Must use newtype deriving or DeriveAnyClass
1390 NonDerivableClass _msg
1391 -- Too hard, even with newtype deriving
1392 | newtype_deriving -> bale_out cant_derive_err
1393 -- Try newtype deriving!
1394 -- Here we suggest GeneralizedNewtypeDeriving even in cases
1395 -- where it may not be applicable. See Trac #9600.
1396 | otherwise -> bale_out (non_std $$ suggest_gnd)
1397
1398 -- DerivableViaInstance
1399 DerivableViaInstance -> do
1400 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
1401 -- enabled, we take the diplomatic approach of defaulting to
1402 -- DeriveAnyClass, but emitting a warning about the choice.
1403 -- See Note [Deriving strategies]
1404 when (newtype_deriving && deriveAnyClass) $
1405 lift $ addWarnTc NoReason $ sep
1406 [ text "Both DeriveAnyClass and"
1407 <+> text "GeneralizedNewtypeDeriving are enabled"
1408 , text "Defaulting to the DeriveAnyClass strategy"
1409 <+> text "for instantiating" <+> ppr cls ]
1410 mk_data_eqn DerivSpecAnyClass
1411 -- CanDerive
1412 CanDerive -> mk_eqn_stock' mk_data_eqn
1413
1414 {-
1415 Note [Recursive newtypes]
1416 ~~~~~~~~~~~~~~~~~~~~~~~~~
1417 Newtype deriving works fine, even if the newtype is recursive.
1418 e.g. newtype S1 = S1 [T1 ()]
1419 newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1420 Remember, too, that type families are currently (conservatively) given
1421 a recursive flag, so this also allows newtype deriving to work
1422 for type famillies.
1423
1424 We used to exclude recursive types, because we had a rather simple
1425 minded way of generating the instance decl:
1426 newtype A = MkA [A]
1427 instance Eq [A] => Eq A -- Makes typechecker loop!
1428 But now we require a simple context, so it's ok.
1429
1430 Note [Determining whether newtype-deriving is appropriate]
1431 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1432 When we see
1433 newtype NT = MkNT Foo
1434 deriving C
1435 we have to decide how to perform the deriving. Do we do newtype deriving,
1436 or do we do normal deriving? In general, we prefer to do newtype deriving
1437 wherever possible. So, we try newtype deriving unless there's a glaring
1438 reason not to.
1439
1440 "Glaring reasons not to" include trying to derive a class for which a
1441 coercion-based instance doesn't make sense. These classes are listed in
1442 the definition of non_coercible_class. They include Show (since it must
1443 show the name of the datatype) and Traversable (since a coercion-based
1444 Traversable instance is ill-roled).
1445
1446 However, non_coercible_class is ignored if the user explicitly requests
1447 to derive an instance with GeneralizedNewtypeDeriving using the newtype
1448 deriving strategy. In such a scenario, GHC will unquestioningly try to
1449 derive the instance via coercions (even if the final generated code is
1450 ill-roled!). See Note [Deriving strategies].
1451
1452 Note that newtype deriving might fail, even after we commit to it. This
1453 is because the derived instance uses `coerce`, which must satisfy its
1454 `Coercible` constraint. This is different than other deriving scenarios,
1455 where we're sure that the resulting instance will type-check.
1456
1457 Note [GND and associated type families]
1458 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1459 It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for
1460 classes with associated type families. A general recipe is:
1461
1462 class C x y z where
1463 type T y z x
1464 op :: x -> [y] -> z
1465
1466 newtype N a = MkN <rep-type> deriving( C )
1467
1468 =====>
1469
1470 instance C x y <rep-type> => C x y (N a) where
1471 type T y (N a) x = T y <rep-type> x
1472 op = coerce (op :: x -> [y] -> <rep-type>)
1473
1474 However, we must watch out for three things:
1475
1476 (a) The class must not contain any data families. If it did, we'd have to
1477 generate a fresh data constructor name for the derived data family
1478 instance, and it's not clear how to do this.
1479
1480 (b) Each associated type family's type variables must mention the last type
1481 variable of the class. As an example, you wouldn't be able to use GND to
1482 derive an instance of this class:
1483
1484 class C a b where
1485 type T a
1486
1487 But you would be able to derive an instance of this class:
1488
1489 class C a b where
1490 type T b
1491
1492 The difference is that in the latter T mentions the last parameter of C
1493 (i.e., it mentions b), but the former T does not. If you tried, e.g.,
1494
1495 newtype Foo x = Foo x deriving (C a)
1496
1497 with the former definition of C, you'd end up with something like this:
1498
1499 instance C a (Foo x) where
1500 type T a = T ???
1501
1502 This T family instance doesn't mention the newtype (or its representation
1503 type) at all, so we disallow such constructions with GND.
1504
1505 (c) UndecidableInstances might need to be enabled. Here's a case where it is
1506 most definitely necessary:
1507
1508 class C a where
1509 type T a
1510 newtype Loop = Loop MkLoop deriving C
1511
1512 =====>
1513
1514 instance C Loop where
1515 type T Loop = T Loop
1516
1517 Obviously, T Loop would send the typechecker into a loop. Unfortunately,
1518 you might even need UndecidableInstances even in cases where the
1519 typechecker would be guaranteed to terminate. For example:
1520
1521 instance C Int where
1522 type C Int = Int
1523 newtype MyInt = MyInt Int deriving C
1524
1525 =====>
1526
1527 instance C MyInt where
1528 type T MyInt = T Int
1529
1530 GHC's termination checker isn't sophisticated enough to conclude that the
1531 definition of T MyInt terminates, so UndecidableInstances is required.
1532
1533 ************************************************************************
1534 * *
1535 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1536 * *
1537 ************************************************************************
1538
1539 After all the trouble to figure out the required context for the
1540 derived instance declarations, all that's left is to chug along to
1541 produce them. They will then be shoved into @tcInstDecls2@, which
1542 will do all its usual business.
1543
1544 There are lots of possibilities for code to generate. Here are
1545 various general remarks.
1546
1547 PRINCIPLES:
1548 \begin{itemize}
1549 \item
1550 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1551 ``you-couldn't-do-better-by-hand'' efficient.
1552
1553 \item
1554 Deriving @Show@---also pretty common--- should also be reasonable good code.
1555
1556 \item
1557 Deriving for the other classes isn't that common or that big a deal.
1558 \end{itemize}
1559
1560 PRAGMATICS:
1561
1562 \begin{itemize}
1563 \item
1564 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1565
1566 \item
1567 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1568
1569 \item
1570 We {\em normally} generate code only for the non-defaulted methods;
1571 there are some exceptions for @Eq@ and (especially) @Ord@...
1572
1573 \item
1574 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1575 constructor's numeric (@Int#@) tag. These are generated by
1576 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1577 these is around is given by @hasCon2TagFun@.
1578
1579 The examples under the different sections below will make this
1580 clearer.
1581
1582 \item
1583 Much less often (really just for deriving @Ix@), we use a
1584 @_tag2con_<tycon>@ function. See the examples.
1585
1586 \item
1587 We use the renamer!!! Reason: we're supposed to be
1588 producing @LHsBinds Name@ for the methods, but that means
1589 producing correctly-uniquified code on the fly. This is entirely
1590 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1591 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1592 the renamer. What a great hack!
1593 \end{itemize}
1594 -}
1595
1596 -- Generate the InstInfo for the required instance paired with the
1597 -- *representation* tycon for that instance,
1598 -- plus any auxiliary bindings required
1599 --
1600 -- Representation tycons differ from the tycon in the instance signature in
1601 -- case of instances for indexed families.
1602 --
1603 genInst :: DerivSpec theta
1604 -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
1605 -- We must use continuation-returning style here to get the order in which we
1606 -- typecheck family instances and derived instances right.
1607 -- See Note [Staging of tcDeriving]
1608 genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
1609 , ds_mechanism = mechanism, ds_tys = tys
1610 , ds_cls = clas, ds_loc = loc })
1611 = do (meth_binds, deriv_stuff, unusedNames)
1612 <- set_span_and_ctxt $
1613 genDerivStuff mechanism loc clas rep_tycon tys tvs
1614 let mk_inst_info theta = set_span_and_ctxt $ do
1615 inst_spec <- newDerivClsInst theta spec
1616 doDerivInstErrorChecks2 clas inst_spec mechanism
1617 traceTc "newder" (ppr inst_spec)
1618 return $ InstInfo
1619 { iSpec = inst_spec
1620 , iBinds = InstBindings
1621 { ib_binds = meth_binds
1622 , ib_tyvars = map Var.varName tvs
1623 , ib_pragmas = []
1624 , ib_extensions = extensions
1625 , ib_derived = True } }
1626 return (mk_inst_info, deriv_stuff, unusedNames)
1627 where
1628 extensions :: [LangExt.Extension]
1629 extensions
1630 | isDerivSpecNewtype mechanism
1631 -- Both these flags are needed for higher-rank uses of coerce
1632 -- See Note [Newtype-deriving instances] in TcGenDeriv
1633 = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]
1634 | otherwise
1635 = []
1636
1637 set_span_and_ctxt :: TcM a -> TcM a
1638 set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
1639
1640 doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
1641 doDerivInstErrorChecks1 mechanism = do
1642 DerivEnv { denv_tc = tc
1643 , denv_rep_tc = rep_tc
1644 , denv_mtheta = mtheta } <- ask
1645 let anyclass_strategy = isDerivSpecAnyClass mechanism
1646 bale_out msg = do err <- derivingThingErrMechanism mechanism msg
1647 lift $ failWithTc err
1648
1649 -- For standalone deriving (mtheta /= Nothing),
1650 -- check that all the data constructors are in scope...
1651 rdr_env <- lift getGlobalRdrEnv
1652 let data_con_names = map dataConName (tyConDataCons rep_tc)
1653 hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
1654 (isAbstractTyCon rep_tc ||
1655 any not_in_scope data_con_names)
1656 not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc)
1657
1658 lift $ addUsedDataCons rdr_env rep_tc
1659
1660 -- ...however, we don't perform this check if we're using DeriveAnyClass,
1661 -- since it doesn't generate any code that requires use of a data
1662 -- constructor.
1663 unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $
1664 bale_out $ derivingHiddenErr tc
1665
1666 doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
1667 doDerivInstErrorChecks2 clas clas_inst mechanism
1668 = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
1669 ; dflags <- getDynFlags
1670 -- Check for Generic instances that are derived with an exotic
1671 -- deriving strategy like DAC
1672 -- See Note [Deriving strategies]
1673 ; when (exotic_mechanism && className clas `elem` genericClassNames) $
1674 do { failIfTc (safeLanguageOn dflags) gen_inst_err
1675 ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
1676 where
1677 exotic_mechanism = case mechanism of
1678 DerivSpecStock{} -> False
1679 _ -> True
1680
1681 gen_inst_err = text "Generic instances can only be derived in"
1682 <+> text "Safe Haskell using the stock strategy."
1683
1684 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
1685 -> TyCon -> [Type] -> [TyVar]
1686 -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
1687 genDerivStuff mechanism loc clas tycon inst_tys tyvars
1688 = case mechanism of
1689 -- See Note [Bindings for Generalised Newtype Deriving]
1690 DerivSpecNewtype rhs_ty -> do
1691 (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys rhs_ty
1692 return (binds, faminsts, maybeToList unusedConName)
1693
1694 -- Try a stock deriver
1695 DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
1696
1697 -- If there isn't a stock deriver, our last resort is -XDeriveAnyClass
1698 -- (since -XGeneralizedNewtypeDeriving fell through).
1699 DerivSpecAnyClass -> do
1700 let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
1701 mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
1702 dflags <- getDynFlags
1703 tyfam_insts <-
1704 -- canDeriveAnyClass should ensure that this code can't be reached
1705 -- unless -XDeriveAnyClass is enabled.
1706 ASSERT2( isValid (canDeriveAnyClass dflags)
1707 , ppr "genDerivStuff: bad derived class" <+> ppr clas )
1708 mapM (tcATDefault loc mini_subst emptyNameSet)
1709 (classATItems clas)
1710 return ( emptyBag -- No method bindings are needed...
1711 , listToBag (map DerivFamInst (concat tyfam_insts))
1712 -- ...but we may need to generate binding for associated type
1713 -- family default instances.
1714 -- See Note [DeriveAnyClass and default family instances]
1715 , [] )
1716 where
1717 unusedConName :: Maybe Name
1718 unusedConName
1719 | isDerivSpecNewtype mechanism
1720 -- See Note [Newtype deriving and unused constructors]
1721 = Just $ getName $ head $ tyConDataCons tycon
1722 | otherwise
1723 = Nothing
1724
1725 {-
1726 Note [Bindings for Generalised Newtype Deriving]
1727 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1728 Consider
1729 class Eq a => C a where
1730 f :: a -> a
1731 newtype N a = MkN [a] deriving( C )
1732 instance Eq (N a) where ...
1733
1734 The 'deriving C' clause generates, in effect
1735 instance (C [a], Eq a) => C (N a) where
1736 f = coerce (f :: [a] -> [a])
1737
1738 This generates a cast for each method, but allows the superclasse to
1739 be worked out in the usual way. In this case the superclass (Eq (N
1740 a)) will be solved by the explicit Eq (N a) instance. We do *not*
1741 create the superclasses by casting the superclass dictionaries for the
1742 representation type.
1743
1744 See the paper "Safe zero-cost coercions for Haskell".
1745
1746 Note [DeriveAnyClass and default family instances]
1747 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1748
1749 When a class has a associated type family with a default instance, e.g.:
1750
1751 class C a where
1752 type T a
1753 type T a = Char
1754
1755 then there are a couple of scenarios in which a user would expect T a to
1756 default to Char. One is when an instance declaration for C is given without
1757 an implementation for T:
1758
1759 instance C Int
1760
1761 Another scenario in which this can occur is when the -XDeriveAnyClass extension
1762 is used:
1763
1764 data Example = Example deriving (C, Generic)
1765
1766 In the latter case, we must take care to check if C has any associated type
1767 families with default instances, because -XDeriveAnyClass will never provide
1768 an implementation for them. We "fill in" the default instances using the
1769 tcATDefault function from TcClassDcl (which is also used in TcInstDcls to
1770 handle the empty instance declaration case).
1771
1772 Note [Deriving strategies]
1773 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1774 GHC has a notion of deriving strategies, which allow the user to explicitly
1775 request which approach to use when deriving an instance (enabled with the
1776 -XDerivingStrategies language extension). For more information, refer to the
1777 original Trac ticket (#10598) or the associated wiki page:
1778 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
1779
1780 A deriving strategy can be specified in a deriving clause:
1781
1782 newtype Foo = MkFoo Bar
1783 deriving newtype C
1784
1785 Or in a standalone deriving declaration:
1786
1787 deriving anyclass instance C Foo
1788
1789 -XDerivingStrategies also allows the use of multiple deriving clauses per data
1790 declaration so that a user can derive some instance with one deriving strategy
1791 and other instances with another deriving strategy. For example:
1792
1793 newtype Baz = Baz Quux
1794 deriving (Eq, Ord)
1795 deriving stock (Read, Show)
1796 deriving newtype (Num, Floating)
1797 deriving anyclass C
1798
1799 Currently, the deriving strategies are:
1800
1801 * stock: Have GHC implement a "standard" instance for a data type, if possible
1802 (e.g., Eq, Ord, Generic, Data, Functor, etc.)
1803
1804 * anyclass: Use -XDeriveAnyClass
1805
1806 * newtype: Use -XGeneralizedNewtypeDeriving
1807
1808 If an explicit deriving strategy is not given, GHC has an algorithm it uses to
1809 determine which strategy it will actually use. The algorithm is quite long,
1810 so it lives in the Haskell wiki at
1811 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
1812 ("The deriving strategy resolution algorithm" section).
1813
1814 Internally, GHC uses the DerivStrategy datatype to denote a user-requested
1815 deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
1816 GHC will use to derive the instance after taking the above steps. In other
1817 words, GHC will always settle on a DerivSpecMechnism, even if the user did not
1818 ask for a particular DerivStrategy (using the algorithm linked to above).
1819
1820 Note [Deriving instances for classes themselves]
1821 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1822 Much of the code in TcDeriv assumes that deriving only works on data types.
1823 But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
1824 reasonable to do something like this:
1825
1826 {-# LANGUAGE DeriveAnyClass #-}
1827 class C1 (a :: Constraint) where
1828 class C2 where
1829 deriving instance C1 C2
1830 -- This is equivalent to `instance C1 C2`
1831
1832 If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
1833 deriving), we throw a special error message indicating that DeriveAnyClass is
1834 the only way to go. We don't bother throwing this error if an explicit 'stock'
1835 or 'newtype' keyword is used, since both options have their own perfectly
1836 sensible error messages in the case of the above code (as C1 isn't a stock
1837 derivable class, and C2 isn't a newtype).
1838
1839 ************************************************************************
1840 * *
1841 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1842 * *
1843 ************************************************************************
1844 -}
1845
1846 nonUnaryErr :: LHsSigType GhcRn -> SDoc
1847 nonUnaryErr ct = quotes (ppr ct)
1848 <+> text "is not a unary constraint, as expected by a deriving clause"
1849
1850 nonStdErr :: Class -> SDoc
1851 nonStdErr cls =
1852 quotes (ppr cls)
1853 <+> text "is not a stock derivable class (Eq, Show, etc.)"
1854
1855 gndNonNewtypeErr :: SDoc
1856 gndNonNewtypeErr =
1857 text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
1858
1859 derivingNullaryErr :: MsgDoc
1860 derivingNullaryErr = text "Cannot derive instances for nullary classes"
1861
1862 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc
1863 derivingKindErr tc cls cls_tys cls_kind enough_args
1864 = sep [ hang (text "Cannot derive well-kinded instance of form"
1865 <+> quotes (pprClassPred cls cls_tys
1866 <+> parens (ppr tc <+> text "...")))
1867 2 gen1_suggestion
1868 , nest 2 (text "Class" <+> quotes (ppr cls)
1869 <+> text "expects an argument of kind"
1870 <+> quotes (pprKind cls_kind))
1871 ]
1872 where
1873 gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args
1874 = text "(Perhaps you intended to use PolyKinds)"
1875 | otherwise = Outputable.empty
1876
1877 derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
1878 derivingEtaErr cls cls_tys inst_ty
1879 = sep [text "Cannot eta-reduce to an instance of form",
1880 nest 2 (text "instance (...) =>"
1881 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1882
1883 derivingThingErr :: Bool -> Class -> [Type] -> Type
1884 -> Maybe DerivStrategy -> MsgDoc -> MsgDoc
1885 derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why
1886 = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat
1887 (maybe empty ppr mb_strat) why
1888
1889 derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
1890 derivingThingErrM newtype_deriving why
1891 = do DerivEnv { denv_tc = tc
1892 , denv_tc_args = tc_args
1893 , denv_cls = cls
1894 , denv_cls_tys = cls_tys
1895 , denv_strat = mb_strat } <- ask
1896 pure $ derivingThingErr newtype_deriving cls cls_tys
1897 (mkTyConApp tc tc_args) mb_strat why
1898
1899 derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
1900 derivingThingErrMechanism mechanism why
1901 = do DerivEnv { denv_tc = tc
1902 , denv_tc_args = tc_args
1903 , denv_cls = cls
1904 , denv_cls_tys = cls_tys
1905 , denv_strat = mb_strat } <- ask
1906 pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys
1907 (mkTyConApp tc tc_args) mb_strat (ppr mechanism) why
1908
1909 derivingThingErr' :: Bool -> Class -> [Type] -> Type
1910 -> Maybe DerivStrategy -> MsgDoc -> MsgDoc -> MsgDoc
1911 derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why
1912 = sep [(hang (text "Can't make a derived instance of")
1913 2 (quotes (ppr pred) <+> via_mechanism)
1914 $$ nest 2 extra) <> colon,
1915 nest 2 why]
1916 where
1917 strat_used = isJust mb_strat
1918 extra | not strat_used, newtype_deriving
1919 = text "(even with cunning GeneralizedNewtypeDeriving)"
1920 | otherwise = empty
1921 pred = mkClassPred cls (cls_tys ++ [inst_ty])
1922 via_mechanism | strat_used
1923 = text "with the" <+> strat_msg <+> text "strategy"
1924 | otherwise
1925 = empty
1926
1927 derivingHiddenErr :: TyCon -> SDoc
1928 derivingHiddenErr tc
1929 = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1930 2 (text "so you cannot derive an instance for it")
1931
1932 standaloneCtxt :: LHsSigType GhcRn -> SDoc
1933 standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
1934 2 (quotes (ppr ty))
1935
1936 unboxedTyConErr :: String -> MsgDoc
1937 unboxedTyConErr thing =
1938 text "The last argument of the instance cannot be an unboxed" <+> text thing