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