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