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