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