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