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