Make start address of `osReserveHeapMemory` tunable via command line -xb
[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 ImplicitParams #-}
11
12 module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
13
14 #include "HsVersions.h"
15
16 import HsSyn
17 import DynFlags
18
19 import TcRnMonad
20 import FamInst
21 import TcErrors( reportAllUnsolved )
22 import TcValidity( validDerivPred, allDistinctTyVars )
23 import TcClassDcl( tcATDefault, tcMkDeclCtxt )
24 import TcEnv
25 import TcGenDeriv -- Deriv stuff
26 import TcGenGenerics
27 import InstEnv
28 import Inst
29 import FamInstEnv
30 import TcHsType
31 import TcMType
32 import TcSimplify
33 import TcUnify( buildImplicationFor )
34
35 import RnNames( extendGlobalRdrEnvRn )
36 import RnBinds
37 import RnEnv
38 import RnSource ( addTcgDUs )
39 import Avail
40
41 import Unify( tcUnifyTy )
42 import Class
43 import Type
44 import ErrUtils
45 import DataCon
46 import Maybes
47 import RdrName
48 import Name
49 import NameSet
50 import TyCon
51 import TcType
52 import Var
53 import VarEnv
54 import VarSet
55 import PrelNames
56 import THNames ( liftClassKey )
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 Data.List
68 #if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
69 import GHC.Stack (CallStack)
70 #endif
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 -- DerivSpec is purely local to this module
90 data DerivSpec theta = DS { ds_loc :: SrcSpan
91 , ds_name :: Name -- DFun name
92 , ds_tvs :: [TyVar]
93 , ds_theta :: theta
94 , ds_cls :: Class
95 , ds_tys :: [Type]
96 , ds_tc :: TyCon
97 , ds_overlap :: Maybe OverlapMode
98 , ds_newtype :: Maybe Type } -- The newtype rep type
99 -- This spec implies a dfun declaration of the form
100 -- df :: forall tvs. theta => C tys
101 -- The Name is the name for the DFun we'll build
102 -- The tyvars bind all the variables in the theta
103 -- For type families, the tycon in
104 -- in ds_tys is the *family* tycon
105 -- in ds_tc is the *representation* type
106 -- For non-family tycons, both are the same
107
108 -- the theta is either the given and final theta, in standalone deriving,
109 -- or the not-yet-simplified list of constraints together with their origin
110
111 -- ds_newtype = Just rep_ty <=> Generalised Newtype Deriving (GND)
112 -- Nothing <=> Vanilla deriving
113
114 {-
115 Example:
116
117 newtype instance T [a] = MkT (Tree a) deriving( C s )
118 ==>
119 axiom T [a] = :RTList a
120 axiom :RTList a = Tree a
121
122 DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
123 , ds_tc = :RTList, ds_newtype = Just (Tree a) }
124 -}
125
126 type DerivContext = Maybe ThetaType
127 -- Nothing <=> Vanilla deriving; infer the context of the instance decl
128 -- Just theta <=> Standalone deriving: context supplied by programmer
129
130 -- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
131 -- and whether or the constraint deals in types or kinds.
132 data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
133 type ThetaOrigin = [PredOrigin]
134
135 mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
136 mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
137
138 mkThetaOrigin :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaOrigin
139 mkThetaOrigin origin t_or_k = map (mkPredOrigin origin t_or_k)
140
141 substPredOrigin ::
142 -- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
143 #if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
144 (?callStack :: CallStack) =>
145 #endif
146 TCvSubst -> PredOrigin -> PredOrigin
147 substPredOrigin subst (PredOrigin pred origin t_or_k)
148 = PredOrigin (substTy subst pred) origin t_or_k
149
150 substThetaOrigin ::
151 -- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
152 #if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
153 (?callStack :: CallStack) =>
154 #endif
155 TCvSubst -> ThetaOrigin -> ThetaOrigin
156 substThetaOrigin subst = map (substPredOrigin subst)
157
158 data EarlyDerivSpec = InferTheta (DerivSpec ThetaOrigin)
159 | GivenTheta (DerivSpec ThetaType)
160 -- InferTheta ds => the context for the instance should be inferred
161 -- In this case ds_theta is the list of all the constraints
162 -- needed, such as (Eq [a], Eq a), together with a suitable CtLoc
163 -- to get good error messages.
164 -- The inference process is to reduce this to a
165 -- simpler form (e.g. Eq a)
166 --
167 -- GivenTheta ds => the exact context for the instance is supplied
168 -- by the programmer; it is ds_theta
169 -- See Note [Inferring the instance context]
170
171 earlyDSLoc :: EarlyDerivSpec -> SrcSpan
172 earlyDSLoc (InferTheta spec) = ds_loc spec
173 earlyDSLoc (GivenTheta spec) = ds_loc spec
174
175 splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType])
176 splitEarlyDerivSpec [] = ([],[])
177 splitEarlyDerivSpec (InferTheta spec : specs) =
178 case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
179 splitEarlyDerivSpec (GivenTheta spec : specs) =
180 case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
181
182 pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
183 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
184 ds_cls = c, ds_tys = tys, ds_theta = rhs })
185 = hang (text "DerivSpec")
186 2 (vcat [ text "ds_loc =" <+> ppr l
187 , text "ds_name =" <+> ppr n
188 , text "ds_tvs =" <+> ppr tvs
189 , text "ds_cls =" <+> ppr c
190 , text "ds_tys =" <+> ppr tys
191 , text "ds_theta =" <+> ppr rhs ])
192
193 instance Outputable theta => Outputable (DerivSpec theta) where
194 ppr = pprDerivSpec
195
196 instance Outputable EarlyDerivSpec where
197 ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
198 ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
199
200 instance Outputable PredOrigin where
201 ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
202
203 {- Note [Inferring the instance context]
204 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
205 There are two sorts of 'deriving':
206
207 * InferTheta: the deriving clause for a data type
208 data T a = T1 a deriving( Eq )
209 Here we must infer an instance context,
210 and generate instance declaration
211 instance Eq a => Eq (T a) where ...
212
213 * CheckTheta: standalone deriving
214 deriving instance Eq a => Eq (T a)
215 Here we only need to fill in the bindings;
216 the instance context is user-supplied
217
218 For a deriving clause (InferTheta) we must figure out the
219 instance context (inferConstraints). Suppose we are inferring
220 the instance context for
221 C t1 .. tn (T s1 .. sm)
222 There are two cases
223
224 * (T s1 .. sm) :: * (the normal case)
225 Then we behave like Eq and guess (C t1 .. tn t)
226 for each data constructor arg of type t. More
227 details below.
228
229 * (T s1 .. sm) :: * -> * (the functor-like case)
230 Then we behave like Functor.
231
232 In both cases we produce a bunch of un-simplified constraints
233 and them simplify them in simplifyInstanceContexts; see
234 Note [Simplifying the instance context].
235
236 In the functor-like case, we may need to unify some kind variables with * in
237 order for the generated instance to be well-kinded. An example from
238 Trac #10524:
239
240 newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
241 = Compose (f (g a)) deriving Functor
242
243 Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
244 (k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
245 alone isn't enough, since k2 wasn't unified with *:
246
247 instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
248 Functor (Compose f g) where ...
249
250 The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
251
252 1. Collect all of a datatype's subtypes which require functor-like
253 constraints.
254 2. For each subtype, create a substitution by unifying the subtype's kind
255 with (* -> *).
256 3. Compose all the substitutions into one, then apply that substitution to
257 all of the in-scope type variables and the instance types.
258
259 Note [Data decl contexts]
260 ~~~~~~~~~~~~~~~~~~~~~~~~~
261 Consider
262
263 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
264
265 We will need an instance decl like:
266
267 instance (Read a, RealFloat a) => Read (Complex a) where
268 ...
269
270 The RealFloat in the context is because the read method for Complex is bound
271 to construct a Complex, and doing that requires that the argument type is
272 in RealFloat.
273
274 But this ain't true for Show, Eq, Ord, etc, since they don't construct
275 a Complex; they only take them apart.
276
277 Our approach: identify the offending classes, and add the data type
278 context to the instance decl. The "offending classes" are
279
280 Read, Enum?
281
282 FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
283 pattern matching against a constructor from a data type with a context
284 gives rise to the constraints for that context -- or at least the thinned
285 version. So now all classes are "offending".
286
287 Note [Newtype deriving]
288 ~~~~~~~~~~~~~~~~~~~~~~~
289 Consider this:
290 class C a b
291 instance C [a] Char
292 newtype T = T Char deriving( C [a] )
293
294 Notice the free 'a' in the deriving. We have to fill this out to
295 newtype T = T Char deriving( forall a. C [a] )
296
297 And then translate it to:
298 instance C [a] Char => C [a] T where ...
299
300
301 Note [Newtype deriving superclasses]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 (See also Trac #1220 for an interesting exchange on newtype
304 deriving and superclasses.)
305
306 The 'tys' here come from the partial application in the deriving
307 clause. The last arg is the new instance type.
308
309 We must pass the superclasses; the newtype might be an instance
310 of them in a different way than the representation type
311 E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
312 Then the Show instance is not done via Coercible; it shows
313 Foo 3 as "Foo 3"
314 The Num instance is derived via Coercible, but the Show superclass
315 dictionary must the Show instance for Foo, *not* the Show dictionary
316 gotten from the Num dictionary. So we must build a whole new dictionary
317 not just use the Num one. The instance we want is something like:
318 instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
319 (+) = ((+)@a)
320 ...etc...
321 There may be a coercion needed which we get from the tycon for the newtype
322 when the dict is constructed in TcInstDcls.tcInstDecl2
323
324
325 Note [Unused constructors and deriving clauses]
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 See Trac #3221. Consider
328 data T = T1 | T2 deriving( Show )
329 Are T1 and T2 unused? Well, no: the deriving clause expands to mention
330 both of them. So we gather defs/uses from deriving just like anything else.
331
332 -}
333
334 -- | Stuff needed to process a `deriving` clause
335 data DerivInfo = DerivInfo { di_rep_tc :: TyCon
336 -- ^ The data tycon for normal datatypes,
337 -- or the *representation* tycon for data families
338 , di_preds :: [LHsSigType Name]
339 , di_ctxt :: SDoc -- ^ error context
340 }
341
342 -- | Extract `deriving` clauses of proper data type (skips data families)
343 mkDerivInfos :: [LTyClDecl Name] -> TcM [DerivInfo]
344 mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
345 where
346
347 mk_deriv decl@(DataDecl { tcdLName = L _ data_name
348 , tcdDataDefn =
349 HsDataDefn { dd_derivs = Just (L _ preds) } })
350 = do { tycon <- tcLookupTyCon data_name
351 ; return [DerivInfo { di_rep_tc = tycon, di_preds = preds
352 , di_ctxt = tcMkDeclCtxt decl }] }
353 mk_deriv _ = return []
354
355 {-
356
357 ************************************************************************
358 * *
359 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
360 * *
361 ************************************************************************
362 -}
363
364 tcDeriving :: [DerivInfo] -- All `deriving` clauses
365 -> [LDerivDecl Name] -- All stand-alone deriving declarations
366 -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
367 tcDeriving deriv_infos deriv_decls
368 = recoverM (do { g <- getGblEnv
369 ; return (g, emptyBag, emptyValBindsOut)}) $
370 do { -- Fish the "deriving"-related information out of the TcEnv
371 -- And make the necessary "equations".
372 is_boot <- tcIsHsBootOrSig
373 ; traceTc "tcDeriving" (ppr is_boot)
374
375 ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
376 ; traceTc "tcDeriving 1" (ppr early_specs)
377
378 ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
379 ; insts1 <- mapM genInst given_specs
380
381 -- the stand-alone derived instances (@insts1@) are used when inferring
382 -- the contexts for "deriving" clauses' instances (@infer_specs@)
383 ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
384 simplifyInstanceContexts infer_specs
385
386 ; insts2 <- mapM genInst final_specs
387
388 ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
389 ; loc <- getSrcSpanM
390 ; let (binds, famInsts) = genAuxBinds loc (unionManyBags deriv_stuff)
391
392 ; dflags <- getDynFlags
393
394 ; (inst_info, rn_binds, rn_dus) <-
395 renameDeriv is_boot inst_infos binds
396
397 ; unless (isEmptyBag inst_info) $
398 liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
399 (ddump_deriving inst_info rn_binds famInsts))
400
401 ; gbl_env <- tcExtendLocalFamInstEnv (bagToList famInsts) $
402 tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
403 ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ catMaybes maybe_fvs)
404 ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
405 where
406 ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
407 -> Bag FamInst -- ^ Rep type family instances
408 -> SDoc
409 ddump_deriving inst_infos extra_binds repFamInsts
410 = hang (text "Derived instances:")
411 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
412 $$ ppr extra_binds)
413 $$ hangP "GHC.Generics representation types:"
414 (vcat (map pprRepTy (bagToList repFamInsts)))
415
416 hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
417
418 -- Prints the representable type family instance
419 pprRepTy :: FamInst -> SDoc
420 pprRepTy fi@(FamInst { fi_tys = lhs })
421 = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
422 equals <+> ppr rhs
423 where rhs = famInstRHS fi
424
425 renameDeriv :: Bool
426 -> [InstInfo RdrName]
427 -> Bag (LHsBind RdrName, LSig RdrName)
428 -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
429 renameDeriv is_boot inst_infos bagBinds
430 | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
431 -- The inst-info bindings will all be empty, but it's easier to
432 -- just use rn_inst_info to change the type appropriately
433 = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
434 ; return ( listToBag rn_inst_infos
435 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
436
437 | otherwise
438 = discardWarnings $ -- Discard warnings about unused bindings etc
439 setXOptM LangExt.EmptyCase $ -- Derived decls (for empty types) can have
440 -- case x of {}
441 setXOptM LangExt.ScopedTypeVariables $ -- Derived decls (for newtype-deriving) can
442 setXOptM LangExt.KindSignatures $ -- used ScopedTypeVariables & KindSignatures
443 do {
444 -- Bring the extra deriving stuff into scope
445 -- before renaming the instances themselves
446 ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
447 ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
448 ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
449 ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
450 ; let bndrs = collectHsValBinders rn_aux_lhs
451 ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
452 ; setEnvs envs $
453 do { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
454 ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
455 ; return (listToBag rn_inst_infos, rn_aux,
456 dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
457
458 where
459 rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
460 rn_inst_info
461 inst_info@(InstInfo { iSpec = inst
462 , iBinds = InstBindings
463 { ib_binds = binds
464 , ib_tyvars = tyvars
465 , ib_pragmas = sigs
466 , ib_extensions = exts -- Only for type-checking
467 , ib_derived = sa } })
468 = ASSERT( null sigs )
469 bindLocalNamesFV tyvars $
470 do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
471 ; let binds' = InstBindings { ib_binds = rn_binds
472 , ib_tyvars = tyvars
473 , ib_pragmas = []
474 , ib_extensions = exts
475 , ib_derived = sa }
476 ; return (inst_info { iBinds = binds' }, fvs) }
477
478 {-
479 Note [Newtype deriving and unused constructors]
480 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
481 Consider this (see Trac #1954):
482
483 module Bug(P) where
484 newtype P a = MkP (IO a) deriving Monad
485
486 If you compile with -Wunused-binds you do not expect the warning
487 "Defined but not used: data consructor MkP". Yet the newtype deriving
488 code does not explicitly mention MkP, but it should behave as if you
489 had written
490 instance Monad P where
491 return x = MkP (return x)
492 ...etc...
493
494 So we want to signal a user of the data constructor 'MkP'.
495 This is the reason behind the (Maybe Name) part of the return type
496 of genInst.
497
498 Note [Why we don't pass rep_tc into deriveTyData]
499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
500 Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
501 the rep_tc by means of a lookup. And yet we have the rep_tc right here!
502 Why look it up again? Answer: it's just easier this way.
503 We drop some number of arguments from the end of the datatype definition
504 in deriveTyData. The arguments are dropped from the fam_tc.
505 This action may drop a *different* number of arguments
506 passed to the rep_tc, depending on how many free variables, etc., the
507 dropped patterns have.
508
509 Also, this technique carries over the kind substitution from deriveTyData
510 nicely.
511
512 ************************************************************************
513 * *
514 From HsSyn to DerivSpec
515 * *
516 ************************************************************************
517
518 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
519 -}
520
521 makeDerivSpecs :: Bool
522 -> [DerivInfo]
523 -> [LDerivDecl Name]
524 -> TcM [EarlyDerivSpec]
525 makeDerivSpecs is_boot deriv_infos deriv_decls
526 = do { eqns1 <- concatMapM (recoverM (return []) . deriveDerivInfo) deriv_infos
527 ; eqns2 <- concatMapM (recoverM (return []) . deriveStandalone) deriv_decls
528 ; let eqns = eqns1 ++ eqns2
529
530 ; if is_boot then -- No 'deriving' at all in hs-boot files
531 do { unless (null eqns) (add_deriv_err (head eqns))
532 ; return [] }
533 else return eqns }
534 where
535 add_deriv_err eqn
536 = setSrcSpan (earlyDSLoc eqn) $
537 addErr (hang (text "Deriving not permitted in hs-boot file")
538 2 (text "Use an instance declaration instead"))
539
540 ------------------------------------------------------------------
541 -- | Process a `deriving` clause
542 deriveDerivInfo :: DerivInfo -> TcM [EarlyDerivSpec]
543 deriveDerivInfo (DerivInfo { di_rep_tc = rep_tc, di_preds = preds
544 , di_ctxt = err_ctxt })
545 = addErrCtxt err_ctxt $
546 concatMapM (deriveTyData tvs tc tys) preds
547 where
548 tvs = tyConTyVars rep_tc
549 (tc, tys) = case tyConFamInstSig_maybe rep_tc of
550 -- data family:
551 Just (fam_tc, pats, _) -> (fam_tc, pats)
552 -- NB: deriveTyData wants the *user-specified*
553 -- name. See Note [Why we don't pass rep_tc into deriveTyData]
554
555 _ -> (rep_tc, mkTyVarTys tvs) -- datatype
556
557 ------------------------------------------------------------------
558 deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
559 -- Standalone deriving declarations
560 -- e.g. deriving instance Show a => Show (T a)
561 -- Rather like tcLocalInstDecl
562 deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode))
563 = setSrcSpan loc $
564 addErrCtxt (standaloneCtxt deriv_ty) $
565 do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
566 ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
567 ; traceTc "Standalone deriving;" $ vcat
568 [ text "tvs:" <+> ppr tvs
569 , text "theta:" <+> ppr theta
570 , text "cls:" <+> ppr cls
571 , text "tys:" <+> ppr inst_tys ]
572 -- C.f. TcInstDcls.tcLocalInstDecl1
573 ; checkTc (not (null inst_tys)) derivingNullaryErr
574
575 ; let cls_tys = take (length inst_tys - 1) inst_tys
576 inst_ty = last inst_tys
577 ; traceTc "Standalone deriving:" $ vcat
578 [ text "class:" <+> ppr cls
579 , text "class types:" <+> ppr cls_tys
580 , text "type:" <+> ppr inst_ty ]
581
582 ; case tcSplitTyConApp_maybe inst_ty of
583 Just (tc, tc_args)
584 | className cls == typeableClassName
585 -> do warnUselessTypeable
586 return []
587
588 | isAlgTyCon tc || isDataFamilyTyCon tc -- All other classes
589 -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
590 tvs cls cls_tys tc tc_args
591 (Just theta)
592 ; return [spec] }
593
594 _ -> -- Complain about functions, primitive types, etc,
595 failWithTc $ derivingThingErr False cls cls_tys inst_ty $
596 text "The last argument of the instance must be a data or newtype application"
597 }
598
599 warnUselessTypeable :: TcM ()
600 warnUselessTypeable
601 = do { warn <- woptM Opt_WarnDerivingTypeable
602 ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
603 $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
604 text "has no effect: all types now auto-derive Typeable" }
605
606 ------------------------------------------------------------------
607 deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance
608 -- Can be a data instance, hence [Type] args
609 -> LHsSigType Name -- The deriving predicate
610 -> TcM [EarlyDerivSpec]
611 -- The deriving clause of a data or newtype declaration
612 -- I.e. not standalone deriving
613 deriveTyData tvs tc tc_args deriv_pred
614 = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item
615 do { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
616 <- tcExtendTyVarEnv tvs $
617 tcHsDeriv deriv_pred
618 -- Deriving preds may (now) mention
619 -- the type variables for the type constructor, hence tcExtendTyVarenv
620 -- The "deriv_pred" is a LHsType to take account of the fact that for
621 -- newtype deriving we allow deriving (forall a. C [a]).
622
623 -- Typeable is special, because Typeable :: forall k. k -> Constraint
624 -- so the argument kind 'k' is not decomposable by splitKindFunTys
625 -- as is the case for all other derivable type classes
626 ; when (length cls_arg_kinds /= 1) $
627 failWithTc (nonUnaryErr deriv_pred)
628 ; let [cls_arg_kind] = cls_arg_kinds
629 ; if className cls == typeableClassName
630 then do warnUselessTypeable
631 return []
632 else
633
634 do { -- Given data T a b c = ... deriving( C d ),
635 -- we want to drop type variables from T so that (C d (T a)) is well-kinded
636 let (arg_kinds, _) = splitFunTys cls_arg_kind
637 n_args_to_drop = length arg_kinds
638 n_args_to_keep = tyConArity tc - n_args_to_drop
639 (tc_args_to_keep, args_to_drop)
640 = splitAt n_args_to_keep tc_args
641 inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep)
642
643 -- Match up the kinds, and apply the resulting kind substitution
644 -- to the types. See Note [Unify kinds in deriving]
645 -- We are assuming the tycon tyvars and the class tyvars are distinct
646 mb_match = tcUnifyTy inst_ty_kind cls_arg_kind
647 enough_args = n_args_to_keep >= 0
648
649 -- Check that the result really is well-kinded
650 ; checkTc (enough_args && isJust mb_match)
651 (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)
652
653 ; let Just kind_subst = mb_match
654 ki_subst_range = getTCvSubstRangeFVs kind_subst
655 all_tkvs = toposortTyVars $
656 fvVarList $ unionFV
657 (tyCoFVsOfTypes tc_args_to_keep)
658 (FV.mkFVs deriv_tvs)
659 -- See Note [Unification of two kind variables in deriving]
660 unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
661 && not (v `elemVarSet` ki_subst_range))
662 all_tkvs
663 (subst, _) = mapAccumL substTyVarBndr
664 kind_subst unmapped_tkvs
665 final_tc_args = substTys subst tc_args_to_keep
666 final_cls_tys = substTys subst cls_tys
667 tkvs = tyCoVarsOfTypesWellScoped $
668 final_cls_tys ++ final_tc_args
669
670 ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred
671 , pprTvBndrs (tyCoVarsOfTypesList tc_args)
672 , ppr n_args_to_keep, ppr n_args_to_drop
673 , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
674 , ppr final_tc_args, ppr final_cls_tys ])
675
676 ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
677
678 ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop) -- (a, b, c)
679 (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
680 -- Check that
681 -- (a) The args to drop are all type variables; eg reject:
682 -- data instance T a Int = .... deriving( Monad )
683 -- (b) The args to drop are all *distinct* type variables; eg reject:
684 -- class C (a :: * -> * -> *) where ...
685 -- data instance T a a = ... deriving( C )
686 -- (c) The type class args, or remaining tycon args,
687 -- do not mention any of the dropped type variables
688 -- newtype T a s = ... deriving( ST s )
689 -- newtype instance K a a = ... deriving( Monad )
690
691 ; spec <- mkEqnHelp Nothing tkvs
692 cls final_cls_tys tc final_tc_args Nothing
693 ; traceTc "derivTyData" (ppr spec)
694 ; return [spec] } }
695
696
697 {-
698 Note [Unify kinds in deriving]
699 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
700 Consider (Trac #8534)
701 data T a b = MkT a deriving( Functor )
702 -- where Functor :: (*->*) -> Constraint
703
704 So T :: forall k. * -> k -> *. We want to get
705 instance Functor (T * (a:*)) where ...
706 Notice the '*' argument to T.
707
708 Moreover, as well as instantiating T's kind arguments, we may need to instantiate
709 C's kind args. Consider (Trac #8865):
710 newtype T a b = MkT (Either a b) deriving( Category )
711 where
712 Category :: forall k. (k -> k -> *) -> Constraint
713 We need to generate the instance
714 instance Category * (Either a) where ...
715 Notice the '*' argument to Category.
716
717 So we need to
718 * drop arguments from (T a b) to match the number of
719 arrows in the (last argument of the) class;
720 * and then *unify* kind of the remaining type against the
721 expected kind, to figure out how to instantiate C's and T's
722 kind arguments.
723
724 In the two examples,
725 * we unify kind-of( T k (a:k) ) ~ kind-of( Functor )
726 i.e. (k -> *) ~ (* -> *) to find k:=*.
727 yielding k:=*
728
729 * we unify kind-of( Either ) ~ kind-of( Category )
730 i.e. (* -> * -> *) ~ (k -> k -> k)
731 yielding k:=*
732
733 Now we get a kind substitution. We then need to:
734
735 1. Remove the substituted-out kind variables from the quantified kind vars
736
737 2. Apply the substitution to the kinds of quantified *type* vars
738 (and extend the substitution to reflect this change)
739
740 3. Apply that extended substitution to the non-dropped args (types and
741 kinds) of the type and class
742
743 Forgetting step (2) caused Trac #8893:
744 data V a = V [a] deriving Functor
745 data P (x::k->*) (a:k) = P (x a) deriving Functor
746 data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor
747
748 When deriving Functor for P, we unify k to *, but we then want
749 an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
750 and similarly for C. Notice the modified kind of x, both at binding
751 and occurrence sites.
752
753 This can lead to some surprising results when *visible* kind binder is
754 unified (in contrast to the above examples, in which only non-visible kind
755 binders were considered). Consider this example from Trac #11732:
756
757 data T k (a :: k) = MkT deriving Functor
758
759 Since unification yields k:=*, this results in a generated instance of:
760
761 instance Functor (T *) where ...
762
763 which looks odd at first glance, since one might expect the instance head
764 to be of the form Functor (T k). Indeed, one could envision an alternative
765 generated instance of:
766
767 instance (k ~ *) => Functor (T k) where
768
769 But this does not typecheck as the result of a -XTypeInType design decision:
770 kind equalities are not allowed to be bound in types, only terms. But in
771 essence, the two instance declarations are entirely equivalent, since even
772 though (T k) matches any kind k, the only possibly value for k is *, since
773 anything else is ill-typed. As a result, we can just as comfortably use (T *).
774
775 Another way of thinking about is: deriving clauses often infer constraints.
776 For example:
777
778 data S a = S a deriving Eq
779
780 infers an (Eq a) constraint in the derived instance. By analogy, when we
781 are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
782 The only distinction is that GHC instantiates equality constraints directly
783 during the deriving process.
784
785 Another quirk of this design choice manifests when typeclasses have visible
786 kind parameters. Consider this code (also from Trac #11732):
787
788 class Cat k (cat :: k -> k -> *) where
789 catId :: cat a a
790 catComp :: cat b c -> cat a b -> cat a c
791
792 instance Cat * (->) where
793 catId = id
794 catComp = (.)
795
796 newtype Fun a b = Fun (a -> b) deriving (Cat k)
797
798 Even though we requested an derived instance of the form (Cat k Fun), the
799 kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
800 the user wrote deriving (Cat *)).
801
802 Note [Unification of two kind variables in deriving]
803 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
804 As a special case of the Note above, it is possible to derive an instance of
805 a poly-kinded typeclass for a poly-kinded datatype. For example:
806
807 class Category (cat :: k -> k -> *) where
808 newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category
809
810 This case is suprisingly tricky. To see why, let's write out what instance GHC
811 will attempt to derive (using -fprint-explicit-kinds syntax):
812
813 instance Category k1 (T k2 c) where ...
814
815 GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
816 that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
817 the type variable binder for c, since its kind is (k2 -> k2 -> *).
818
819 We used to accomplish this by doing the following:
820
821 unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
822 (subst, _) = mapAccumL substTyVarBndr kind_subst unmapped_tkvs
823
824 Where all_tkvs contains all kind variables in the class and instance types (in
825 this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
826 this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
827 to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
828 This is bad, because applying that substitution yields the following instance:
829
830 instance Category k_new (T k1 c) where ...
831
832 In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
833 in an ill-kinded instance (this caused Trac #11837).
834
835 To prevent this, we need to filter out any variable from all_tkvs which either
836
837 1. Appears in the domain of kind_subst. notElemTCvSubst checks this.
838 2. Appears in the range of kind_subst. To do this, we compute the free
839 variable set of the range of kind_subst with getTCvSubstRangeFVs, and check
840 if a kind variable appears in that set.
841
842 Note [Eta-reducing type synonyms]
843 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
844 One can instantiate a type in a data family instance with a type synonym that
845 mentions other type variables:
846
847 type Const a b = a
848 data family Fam (f :: * -> *) (a :: *)
849 newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
850
851 With -XTypeInType, it is also possible to define kind synonyms, and they can
852 mention other types in a datatype declaration. For example,
853
854 type Const a b = a
855 newtype T f (a :: Const * f) = T (f a) deriving Functor
856
857 When deriving, we need to perform eta-reduction analysis to ensure that none of
858 the eta-reduced type variables are mentioned elsewhere in the declaration. But
859 we need to be careful, because if we don't expand through the Const type
860 synonym, we will mistakenly believe that f is an eta-reduced type variable and
861 fail to derive Functor, even though the code above is correct (see Trac #11416,
862 where this was first noticed).
863
864 For this reason, we call exactTyCoVarsOfTypes on the eta-reduced types so that
865 we only consider the type variables that remain after expanding through type
866 synonyms.
867
868 -- Use exactTyCoVarsOfTypes, not tyCoVarsOfTypes, so that we
869 -- don't mistakenly grab a type variable mentioned in a type
870 -- synonym that drops it.
871 -- See Note [Eta-reducing type synonyms].
872 dropped_tvs = exactTyCoVarsOfTypes args_to_drop
873 -}
874
875 mkEqnHelp :: Maybe OverlapMode
876 -> [TyVar]
877 -> Class -> [Type]
878 -> TyCon -> [Type]
879 -> DerivContext -- Just => context supplied (standalone deriving)
880 -- Nothing => context inferred (deriving on data decl)
881 -> TcRn EarlyDerivSpec
882 -- Make the EarlyDerivSpec for an instance
883 -- forall tvs. theta => cls (tys ++ [ty])
884 -- where the 'theta' is optional (that's the Maybe part)
885 -- Assumes that this declaration is well-kinded
886
887 mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
888 = do { -- Find the instance of a data family
889 -- Note [Looking up family instances for deriving]
890 fam_envs <- tcGetFamInstEnvs
891 ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
892 -- If it's still a data family, the lookup failed; i.e no instance exists
893 ; when (isDataFamilyTyCon rep_tc)
894 (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
895
896 -- For standalone deriving (mtheta /= Nothing),
897 -- check that all the data constructors are in scope.
898 ; rdr_env <- getGlobalRdrEnv
899 ; let data_con_names = map dataConName (tyConDataCons rep_tc)
900 hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
901 (isAbstractTyCon rep_tc ||
902 any not_in_scope data_con_names)
903 not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc)
904
905 ; addUsedDataCons rdr_env rep_tc
906 ; unless (isNothing mtheta || not hidden_data_cons)
907 (bale_out (derivingHiddenErr tycon))
908
909 ; dflags <- getDynFlags
910 ; if isDataTyCon rep_tc then
911 mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
912 tycon tc_args rep_tc rep_tc_args mtheta
913 else
914 mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
915 tycon tc_args rep_tc rep_tc_args mtheta }
916 where
917 bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
918
919 {-
920 Note [Looking up family instances for deriving]
921 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
922 tcLookupFamInstExact is an auxiliary lookup wrapper which requires
923 that looked-up family instances exist. If called with a vanilla
924 tycon, the old type application is simply returned.
925
926 If we have
927 data instance F () = ... deriving Eq
928 data instance F () = ... deriving Eq
929 then tcLookupFamInstExact will be confused by the two matches;
930 but that can't happen because tcInstDecls1 doesn't call tcDeriving
931 if there are any overlaps.
932
933 There are two other things that might go wrong with the lookup.
934 First, we might see a standalone deriving clause
935 deriving Eq (F ())
936 when there is no data instance F () in scope.
937
938 Note that it's OK to have
939 data instance F [a] = ...
940 deriving Eq (F [(a,b)])
941 where the match is not exact; the same holds for ordinary data types
942 with standalone deriving declarations.
943
944 Note [Deriving, type families, and partial applications]
945 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
946 When there are no type families, it's quite easy:
947
948 newtype S a = MkS [a]
949 -- :CoS :: S ~ [] -- Eta-reduced
950
951 instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
952 instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
953
954 When type familes are involved it's trickier:
955
956 data family T a b
957 newtype instance T Int a = MkT [a] deriving( Eq, Monad )
958 -- :RT is the representation type for (T Int a)
959 -- :Co:RT :: :RT ~ [] -- Eta-reduced!
960 -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced!
961
962 instance Eq [a] => Eq (T Int a) -- easy by coercion
963 -- d1 :: Eq [a]
964 -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
965
966 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
967 -- d1 :: Monad []
968 -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
969
970 Note the need for the eta-reduced rule axioms. After all, we can
971 write it out
972 instance Monad [] => Monad (T Int) -- only if we can eta reduce???
973 return x = MkT [x]
974 ... etc ...
975
976 See Note [Eta reduction for data families] in FamInstEnv
977
978 %************************************************************************
979 %* *
980 Deriving data types
981 * *
982 ************************************************************************
983 -}
984
985 mkDataTypeEqn :: DynFlags
986 -> Maybe OverlapMode
987 -> [TyVar] -- Universally quantified type variables in the instance
988 -> Class -- Class for which we need to derive an instance
989 -> [Type] -- Other parameters to the class except the last
990 -> TyCon -- Type constructor for which the instance is requested
991 -- (last parameter to the type class)
992 -> [Type] -- Parameters to the type constructor
993 -> TyCon -- rep of the above (for type families)
994 -> [Type] -- rep of the above
995 -> DerivContext -- Context of the instance, for standalone deriving
996 -> TcRn EarlyDerivSpec -- Return 'Nothing' if error
997
998 mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
999 tycon tc_args rep_tc rep_tc_args mtheta
1000 = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
1001 -- NB: pass the *representation* tycon to checkSideConditions
1002 NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg)
1003 DerivableClassError msg -> bale_out msg
1004 CanDerive -> go_for_it
1005 DerivableViaInstance -> go_for_it
1006 where
1007 go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
1008 bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
1009
1010 mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
1011 -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
1012 -> TcM EarlyDerivSpec
1013 mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
1014 = do loc <- getSrcSpanM
1015 dfun_name <- newDFunName' cls tycon
1016 case mtheta of
1017 Nothing -> -- Infer context
1018 inferConstraints tvs cls cls_tys
1019 inst_ty rep_tc rep_tc_args
1020 $ \inferred_constraints tvs' inst_tys' ->
1021 return $ InferTheta $ DS
1022 { ds_loc = loc
1023 , ds_name = dfun_name, ds_tvs = tvs'
1024 , ds_cls = cls, ds_tys = inst_tys'
1025 , ds_tc = rep_tc
1026 , ds_theta = inferred_constraints
1027 , ds_overlap = overlap_mode
1028 , ds_newtype = Nothing }
1029 Just theta -> do -- Specified context
1030 return $ GivenTheta $ DS
1031 { ds_loc = loc
1032 , ds_name = dfun_name, ds_tvs = tvs
1033 , ds_cls = cls, ds_tys = inst_tys
1034 , ds_tc = rep_tc
1035 , ds_theta = theta
1036 , ds_overlap = overlap_mode
1037 , ds_newtype = Nothing }
1038 where
1039 inst_ty = mkTyConApp tycon tc_args
1040 inst_tys = cls_tys ++ [inst_ty]
1041
1042 ----------------------
1043
1044 inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
1045 -> TyCon -> [TcType]
1046 -> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
1047 -> TcM a
1048 -- inferConstraints figures out the constraints needed for the
1049 -- instance declaration generated by a 'deriving' clause on a
1050 -- data type declaration. It also returns the new in-scope type
1051 -- variables and instance types, in case they were changed due to
1052 -- the presence of functor-like constraints.
1053 -- See Note [Inferring the instance context]
1054
1055 -- e.g. inferConstraints
1056 -- C Int (T [a]) -- Class and inst_tys
1057 -- :RTList a -- Rep tycon and its arg tys
1058 -- where T [a] ~R :RTList a
1059 --
1060 -- Generate a sufficiently large set of constraints that typechecking the
1061 -- generated method definitions should succeed. This set will be simplified
1062 -- before being used in the instance declaration
1063 inferConstraints tvs main_cls cls_tys inst_ty rep_tc rep_tc_args mkTheta
1064 | is_generic -- Generic constraints are easy
1065 = mkTheta [] tvs inst_tys
1066
1067 | is_generic1 -- Generic1 needs Functor
1068 = ASSERT( length rep_tc_tvs > 0 ) -- See Note [Getting base classes]
1069 ASSERT( length cls_tys == 1 ) -- Generic1 has a single kind variable
1070 do { functorClass <- tcLookupClass functorClassName
1071 ; con_arg_constraints (get_gen1_constraints functorClass) mkTheta }
1072
1073 | otherwise -- The others are a bit more complicated
1074 = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
1075 , ppr main_cls <+> ppr rep_tc
1076 $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
1077 con_arg_constraints get_std_constrained_tys
1078 $ \arg_constraints tvs' inst_tys' ->
1079 do { traceTc "inferConstraints" $ vcat
1080 [ ppr main_cls <+> ppr inst_tys'
1081 , ppr arg_constraints
1082 ]
1083 ; mkTheta (stupid_constraints ++ extra_constraints
1084 ++ sc_constraints ++ arg_constraints)
1085 tvs' inst_tys' }
1086 where
1087 tc_binders = tyConBinders rep_tc
1088 choose_level bndr
1089 | isNamedTyConBinder bndr = KindLevel
1090 | otherwise = TypeLevel
1091 t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
1092 -- want to report *kind* errors when possible
1093
1094 -- Constraints arising from the arguments of each constructor
1095 con_arg_constraints :: (CtOrigin -> TypeOrKind
1096 -> Type
1097 -> [(ThetaOrigin, Maybe TCvSubst)])
1098 -> (ThetaOrigin -> [TyVar] -> [TcType] -> TcM a)
1099 -> TcM a
1100 con_arg_constraints get_arg_constraints mkTheta
1101 = let (predss, mbSubsts) = unzip
1102 [ preds_and_mbSubst
1103 | data_con <- tyConDataCons rep_tc
1104 , (arg_n, arg_t_or_k, arg_ty)
1105 <- zip3 [1..] t_or_ks $
1106 dataConInstOrigArgTys data_con all_rep_tc_args
1107 -- No constraints for unlifted types
1108 -- See Note [Deriving and unboxed types]
1109 , not (isUnliftedType arg_ty)
1110 , let orig = DerivOriginDC data_con arg_n
1111 , preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty
1112 ]
1113 preds = concat predss
1114 -- If the constraints require a subtype to be of kind (* -> *)
1115 -- (which is the case for functor-like constraints), then we
1116 -- explicitly unify the subtype's kinds with (* -> *).
1117 -- See Note [Inferring the instance context]
1118 subst = foldl' composeTCvSubst
1119 emptyTCvSubst (catMaybes mbSubsts)
1120 unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
1121 && not (v `isInScope` subst)) tvs
1122 (subst', _) = mapAccumL substTyVarBndr subst unmapped_tvs
1123 preds' = substThetaOrigin subst' preds
1124 inst_tys' = substTys subst' inst_tys
1125 tvs' = tyCoVarsOfTypesWellScoped inst_tys'
1126 in mkTheta preds' tvs' inst_tys'
1127
1128 is_generic = main_cls `hasKey` genClassKey
1129 is_generic1 = main_cls `hasKey` gen1ClassKey
1130 -- is_functor_like: see Note [Inferring the instance context]
1131 is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
1132 || is_generic1 -- Technically, Generic1 requires a type of
1133 -- kind (k -> *), not (* -> *), but we still
1134 -- label it "functor-like" to make sure
1135 -- all_rep_tc_args has all the necessary type
1136 -- variables it needs to function.
1137
1138 get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
1139 -> [(ThetaOrigin, Maybe TCvSubst)]
1140 get_gen1_constraints functor_cls orig t_or_k ty
1141 = mk_functor_like_constraints orig t_or_k functor_cls $
1142 get_gen1_constrained_tys last_tv ty
1143
1144 get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
1145 -> [(ThetaOrigin, Maybe TCvSubst)]
1146 get_std_constrained_tys orig t_or_k ty
1147 | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $
1148 deepSubtypesContaining last_tv ty
1149 | otherwise = [( [mk_cls_pred orig t_or_k main_cls ty]
1150 , Nothing )]
1151
1152 mk_functor_like_constraints :: CtOrigin -> TypeOrKind
1153 -> Class -> [Type]
1154 -> [(ThetaOrigin, Maybe TCvSubst)]
1155 -- 'cls' is usually main_cls (Functor or Traversable etc), but if
1156 -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints
1157 --
1158 -- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)],
1159 -- and a kind substitution that results from unifying kind(ty) with * -> *.
1160 -- If the unification is successful, it will ensure that the resulting
1161 -- instance is well kinded. If not, the second constraint will result
1162 -- in an error message which points out the kind mismatch.
1163 -- See Note [Inferring the instance context]
1164 mk_functor_like_constraints orig t_or_k cls
1165 = map $ \ty -> let ki = typeKind ty in
1166 ( [ mk_cls_pred orig t_or_k cls ty
1167 , mkPredOrigin orig KindLevel
1168 (mkPrimEqPred ki typeToTypeKind) ]
1169 , tcUnifyTy ki typeToTypeKind
1170 )
1171
1172 rep_tc_tvs = tyConTyVars rep_tc
1173 last_tv = last rep_tc_tvs
1174 all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
1175 | otherwise = rep_tc_args
1176
1177 -- Constraints arising from superclasses
1178 -- See Note [Superclasses of derived instance]
1179 cls_tvs = classTyVars main_cls
1180 inst_tys = cls_tys ++ [inst_ty]
1181 sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)
1182 mkThetaOrigin DerivOrigin TypeLevel $
1183 substTheta cls_subst (classSCTheta main_cls)
1184 cls_subst = ASSERT( equalLength cls_tvs inst_tys )
1185 zipTvSubst cls_tvs inst_tys
1186
1187 -- Stupid constraints
1188 stupid_constraints = mkThetaOrigin DerivOrigin TypeLevel $
1189 substTheta tc_subst (tyConStupidTheta rep_tc)
1190 tc_subst = ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
1191 zipTvSubst rep_tc_tvs all_rep_tc_args
1192
1193 -- Extra Data constraints
1194 -- The Data class (only) requires that for
1195 -- instance (...) => Data (T t1 t2)
1196 -- IF t1:*, t2:*
1197 -- THEN (Data t1, Data t2) are among the (...) constraints
1198 -- Reason: when the IF holds, we generate a method
1199 -- dataCast2 f = gcast2 f
1200 -- and we need the Data constraints to typecheck the method
1201 extra_constraints
1202 | main_cls `hasKey` dataClassKey
1203 , all (isLiftedTypeKind . typeKind) rep_tc_args
1204 = [ mk_cls_pred DerivOrigin t_or_k main_cls ty
1205 | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
1206 | otherwise
1207 = []
1208
1209 mk_cls_pred orig t_or_k cls ty -- Don't forget to apply to cls_tys' too
1210 = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
1211 cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys'
1212 -- should be empty, since we are applying the
1213 -- class Functor.
1214 | otherwise = cls_tys
1215
1216 {- Note [Getting base classes]
1217 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1218 Functor and Typeable are defined in package 'base', and that is not available
1219 when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in
1220 ghc-prim does not use Functor or Typeable implicitly via these lookups.
1221
1222 Note [Deriving and unboxed types]
1223 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1224 We have some special hacks to support things like
1225 data T = MkT Int# deriving ( Show )
1226
1227 Specifically, we use TcGenDeriv.box to box the Int# into an Int
1228 (which we know how to show), and append a '#'. Parenthesis are not required
1229 for unboxed values (`MkT -3#` is a valid expression).
1230
1231 Note [Deriving any class]
1232 ~~~~~~~~~~~~~~~~~~~~~~~~~
1233 Classic uses of a deriving clause, or a standalone-deriving declaration, are
1234 for:
1235 * a built-in class like Eq or Show, for which GHC knows how to generate
1236 the instance code
1237 * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
1238
1239 The DeriveAnyClass extension adds a third way to derive instances, based on
1240 empty instance declarations.
1241
1242 The canonical use case is in combination with GHC.Generics and default method
1243 signatures. These allow us to have instance declarations being empty, but still
1244 useful, e.g.
1245
1246 data T a = ...blah..blah... deriving( Generic )
1247 instance C a => C (T a) -- No 'where' clause
1248
1249 where C is some "random" user-defined class.
1250
1251 This boilerplate code can be replaced by the more compact
1252
1253 data T a = ...blah..blah... deriving( Generic, C )
1254
1255 if DeriveAnyClass is enabled.
1256
1257 This is not restricted to Generics; any class can be derived, simply giving
1258 rise to an empty instance.
1259
1260 Unfortunately, it is not clear how to determine the context (in case of
1261 standard deriving; in standalone deriving, the user provides the context).
1262 GHC uses the same heuristic for figuring out the class context that it uses for
1263 Eq in the case of *-kinded classes, and for Functor in the case of
1264 * -> *-kinded classes. That may not be optimal or even wrong. But in such
1265 cases, standalone deriving can still be used.
1266 -}
1267
1268 ------------------------------------------------------------------
1269 -- Check side conditions that dis-allow derivability for particular classes
1270 -- This is *apart* from the newtype-deriving mechanism
1271 --
1272 -- Here we get the representation tycon in case of family instances as it has
1273 -- the data constructors - but we need to be careful to fall back to the
1274 -- family tycon (with indexes) in error messages.
1275
1276 data DerivStatus = CanDerive -- Standard class, can derive
1277 | DerivableClassError SDoc -- Standard class, but can't do it
1278 | DerivableViaInstance -- See Note [Deriving any class]
1279 | NonDerivableClass SDoc -- Non-standard class
1280
1281 -- A "standard" class is one defined in the Haskell report which GHC knows how
1282 -- to generate code for, such as Eq, Ord, Ix, etc.
1283
1284 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
1285 -> TyCon -- tycon
1286 -> DerivStatus
1287 checkSideConditions dflags mtheta cls cls_tys rep_tc
1288 | Just cond <- sideConditions mtheta cls
1289 = case (cond (dflags, rep_tc)) of
1290 NotValid err -> DerivableClassError err -- Class-specific error
1291 IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
1292 -> CanDerive
1293 -- All derivable classes are unary in the sense that there
1294 -- should be not types in cls_tys (i.e., no type args other
1295 -- than last). Note that cls_types can contain invisible
1296 -- types as well (e.g., for Generic1, which is poly-kinded),
1297 -- so make sure those are not counted.
1298 | otherwise -> DerivableClassError (classArgsErr cls cls_tys)
1299 -- e.g. deriving( Eq s )
1300
1301 | Just err <- canDeriveAnyClass dflags rep_tc cls
1302 = NonDerivableClass err -- DeriveAnyClass does not work
1303
1304 | otherwise
1305 = DerivableViaInstance -- DeriveAnyClass should work
1306
1307
1308 classArgsErr :: Class -> [Type] -> SDoc
1309 classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
1310
1311 nonUnaryErr :: LHsSigType Name -> SDoc
1312 nonUnaryErr ct = quotes (ppr ct)
1313 <+> text "is not a unary constraint, as expected by a deriving clause"
1314
1315 nonStdErr :: Class -> SDoc
1316 nonStdErr cls =
1317 quotes (ppr cls)
1318 <+> text "is not a standard derivable class (Eq, Show, etc.)"
1319
1320 sideConditions :: DerivContext -> Class -> Maybe Condition
1321 -- Side conditions for classes that GHC knows about,
1322 -- that is, "deriviable classes"
1323 -- Returns Nothing for a non-derivable class
1324 sideConditions mtheta cls
1325 | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
1326 | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
1327 | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
1328 | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls)
1329 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
1330 | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
1331 | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
1332 | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
1333 cond_std `andCond`
1334 cond_args cls)
1335 | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
1336 cond_vanilla `andCond`
1337 cond_functorOK True False)
1338 | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
1339 cond_vanilla `andCond`
1340 cond_functorOK False True)
1341 -- Functor/Fold/Trav works ok
1342 -- for rank-n types
1343 | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
1344 cond_vanilla `andCond`
1345 cond_functorOK False False)
1346 | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
1347 cond_vanilla `andCond`
1348 cond_RepresentableOk)
1349 | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
1350 cond_vanilla `andCond`
1351 cond_Representable1Ok)
1352 | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
1353 cond_vanilla `andCond`
1354 cond_args cls)
1355 | otherwise = Nothing
1356 where
1357 cls_key = getUnique cls
1358 cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one,
1359 -- and monotype arguments
1360 cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but
1361 -- allow no data cons or polytype arguments
1362
1363 canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
1364 -- Nothing: we can (try to) derive it via an empty instance declaration
1365 -- Just s: we can't, reason s
1366 -- Precondition: the class is not one of the standard ones
1367 canDeriveAnyClass dflags _tycon clas
1368 | not (xopt LangExt.DeriveAnyClass dflags)
1369 = Just (text "Try enabling DeriveAnyClass")
1370 | not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ])
1371 = Just (text "The last argument of class" <+> quotes (ppr clas)
1372 <+> text "does not have kind * or (* -> *)")
1373 | otherwise
1374 = Nothing -- OK!
1375 where
1376 -- We are making an instance (C t1 .. tn (T s1 .. sm))
1377 -- and we can only do so if the kind of C's last argument
1378 -- is * or (* -> *). Because only then can we make a reasonable
1379 -- guess at the instance context
1380 target_kind = tyVarKind (last (classTyVars clas))
1381
1382 typeToTypeKind :: Kind
1383 typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
1384
1385 type Condition = (DynFlags, TyCon) -> Validity
1386 -- TyCon is the *representation* tycon if the data type is an indexed one
1387 -- Nothing => OK
1388
1389 orCond :: Condition -> Condition -> Condition
1390 orCond c1 c2 tc
1391 = case (c1 tc, c2 tc) of
1392 (IsValid, _) -> IsValid -- c1 succeeds
1393 (_, IsValid) -> IsValid -- c21 succeeds
1394 (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y)
1395 -- Both fail
1396
1397 andCond :: Condition -> Condition -> Condition
1398 andCond c1 c2 tc = c1 tc `andValid` c2 tc
1399
1400 cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
1401 -- if standalone, we just say "yes, go for it"
1402 -> Bool -- True <=> permissive: allow higher rank
1403 -- args and no data constructors
1404 -> Condition
1405 cond_stdOK (Just _) _ _
1406 = IsValid -- Don't check these conservative conditions for
1407 -- standalone deriving; just generate the code
1408 -- and let the typechecker handle the result
1409 cond_stdOK Nothing permissive (_, rep_tc)
1410 | null data_cons
1411 , not permissive = NotValid (no_cons_why rep_tc $$ suggestion)
1412 | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)
1413 | otherwise = IsValid
1414 where
1415 suggestion = text "Possible fix: use a standalone deriving declaration instead"
1416 data_cons = tyConDataCons rep_tc
1417 con_whys = getInvalids (map check_con data_cons)
1418
1419 check_con :: DataCon -> Validity
1420 check_con con
1421 | not (null eq_spec)
1422 = bad "is a GADT"
1423 | not (null ex_tvs)
1424 = bad "has existential type variables in its type"
1425 | not (null theta)
1426 = bad "has constraints in its type"
1427 | not (permissive || all isTauTy (dataConOrigArgTys con))
1428 = bad "has a higher-rank type"
1429 | otherwise
1430 = IsValid
1431 where
1432 (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
1433 bad msg = NotValid (badCon con (text msg))
1434
1435 no_cons_why :: TyCon -> SDoc
1436 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
1437 text "must have at least one data constructor"
1438
1439 cond_RepresentableOk :: Condition
1440 cond_RepresentableOk (_, tc) = canDoGenerics tc
1441
1442 cond_Representable1Ok :: Condition
1443 cond_Representable1Ok (_, tc) = canDoGenerics1 tc
1444
1445 cond_enumOrProduct :: Class -> Condition
1446 cond_enumOrProduct cls = cond_isEnumeration `orCond`
1447 (cond_isProduct `andCond` cond_args cls)
1448
1449 cond_args :: Class -> Condition
1450 -- For some classes (eg Eq, Ord) we allow unlifted arg types
1451 -- by generating specialised code. For others (eg Data) we don't.
1452 cond_args cls (_, tc)
1453 = case bad_args of
1454 [] -> IsValid
1455 (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
1456 2 (text "for type" <+> quotes (ppr ty)))
1457 where
1458 bad_args = [ arg_ty | con <- tyConDataCons tc
1459 , arg_ty <- dataConOrigArgTys con
1460 , isUnliftedType arg_ty
1461 , not (ok_ty arg_ty) ]
1462
1463 cls_key = classKey cls
1464 ok_ty arg_ty
1465 | cls_key == eqClassKey = check_in arg_ty ordOpTbl
1466 | cls_key == ordClassKey = check_in arg_ty ordOpTbl
1467 | cls_key == showClassKey = check_in arg_ty boxConTbl
1468 | cls_key == liftClassKey = check_in arg_ty litConTbl
1469 | otherwise = False -- Read, Ix etc
1470
1471 check_in :: Type -> [(Type,a)] -> Bool
1472 check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
1473
1474
1475 cond_isEnumeration :: Condition
1476 cond_isEnumeration (_, rep_tc)
1477 | isEnumerationTyCon rep_tc = IsValid
1478 | otherwise = NotValid why
1479 where
1480 why = sep [ quotes (pprSourceTyCon rep_tc) <+>
1481 text "must be an enumeration type"
1482 , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
1483 -- See Note [Enumeration types] in TyCon
1484
1485 cond_isProduct :: Condition
1486 cond_isProduct (_, rep_tc)
1487 | isProductTyCon rep_tc = IsValid
1488 | otherwise = NotValid why
1489 where
1490 why = quotes (pprSourceTyCon rep_tc) <+>
1491 text "must have precisely one constructor"
1492
1493 cond_functorOK :: Bool -> Bool -> Condition
1494 -- OK for Functor/Foldable/Traversable class
1495 -- Currently: (a) at least one argument
1496 -- (b) don't use argument contravariantly
1497 -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
1498 -- (d) optionally: don't use function types
1499 -- (e) no "stupid context" on data type
1500 cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc)
1501 | null tc_tvs
1502 = NotValid (text "Data type" <+> quotes (ppr rep_tc)
1503 <+> text "must have some type parameters")
1504
1505 | not (null bad_stupid_theta)
1506 = NotValid (text "Data type" <+> quotes (ppr rep_tc)
1507 <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
1508
1509 | otherwise
1510 = allValid (map check_con data_cons)
1511 where
1512 tc_tvs = tyConTyVars rep_tc
1513 Just (_, last_tv) = snocView tc_tvs
1514 bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc)
1515 is_bad pred = last_tv `elemVarSet` tyCoVarsOfType pred
1516
1517 data_cons = tyConDataCons rep_tc
1518 check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
1519
1520 check_universal :: DataCon -> Validity
1521 check_universal con
1522 | allowExQuantifiedLastTyVar
1523 = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
1524 -- in TcGenDeriv
1525 | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
1526 , tv `elem` dataConUnivTyVars con
1527 , not (tv `elemVarSet` tyCoVarsOfTypes (dataConTheta con))
1528 = IsValid -- See Note [Check that the type variable is truly universal]
1529 | otherwise
1530 = NotValid (badCon con existential)
1531
1532 ft_check :: DataCon -> FFoldType Validity
1533 ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
1534 , ft_co_var = NotValid (badCon con covariant)
1535 , ft_fun = \x y -> if allowFunctions then x `andValid` y
1536 else NotValid (badCon con functions)
1537 , ft_tup = \_ xs -> allValid xs
1538 , ft_ty_app = \_ x -> x
1539 , ft_bad_app = NotValid (badCon con wrong_arg)
1540 , ft_forall = \_ x -> x }
1541
1542 existential = text "must be truly polymorphic in the last argument of the data type"
1543 covariant = text "must not use the type variable in a function argument"
1544 functions = text "must not contain function types"
1545 wrong_arg = text "must use the type variable only as the last argument of a data type"
1546
1547 checkFlag :: LangExt.Extension -> Condition
1548 checkFlag flag (dflags, _)
1549 | xopt flag dflags = IsValid
1550 | otherwise = NotValid why
1551 where
1552 why = text "You need " <> text flag_str
1553 <+> text "to derive an instance for this class"
1554 flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of
1555 [s] -> s
1556 other -> pprPanic "checkFlag" (ppr other)
1557
1558 std_class_via_coercible :: Class -> Bool
1559 -- These standard classes can be derived for a newtype
1560 -- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
1561 -- because giving so gives the same results as generating the boilerplate
1562 std_class_via_coercible clas
1563 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
1564 -- Not Read/Show/Lift because they respect the type
1565 -- Not Enum, because newtypes are never in Enum
1566
1567
1568 non_coercible_class :: Class -> Bool
1569 -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
1570 -- by Coercible, even with -XGeneralizedNewtypeDeriving
1571 -- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
1572 -- instance behave differently if there's a non-lawful Applicative out there.
1573 -- Besides, with roles, Coercible-deriving Traversable is ill-roled.
1574 non_coercible_class cls
1575 = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
1576 , genClassKey, gen1ClassKey, typeableClassKey
1577 , traversableClassKey, liftClassKey ])
1578
1579 badCon :: DataCon -> SDoc -> SDoc
1580 badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
1581
1582 {-
1583 Note [Check that the type variable is truly universal]
1584 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1585 For Functor and Traversable instances, we must check that the *last argument*
1586 of the type constructor is used truly universally quantified. Example
1587
1588 data T a b where
1589 T1 :: a -> b -> T a b -- Fine! Vanilla H-98
1590 T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b'
1591 T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic
1592 T4 :: Ord b => b -> T a b -- No! 'b' is constrained
1593 T5 :: b -> T b b -- No! 'b' is constrained
1594 T6 :: T a (b,b) -- No! 'b' is constrained
1595
1596 Notice that only the first of these constructors is vanilla H-98. We only
1597 need to take care about the last argument (b in this case). See Trac #8678.
1598 Eg. for T1-T3 we can write
1599
1600 fmap f (T1 a b) = T1 a (f b)
1601 fmap f (T2 b c) = T2 (f b) c
1602 fmap f (T3 x) = T3 (f x)
1603
1604 We need not perform these checks for Foldable instances, however, since
1605 functions in Foldable can only consume existentially quantified type variables,
1606 rather than produce them (as is the case in Functor and Traversable functions.)
1607 As a result, T can have a derived Foldable instance:
1608
1609 foldr f z (T1 a b) = f b z
1610 foldr f z (T2 b c) = f b z
1611 foldr f z (T3 x) = f x z
1612 foldr f z (T4 x) = f x z
1613 foldr f z (T5 x) = f x z
1614 foldr _ z T6 = z
1615
1616 See Note [DeriveFoldable with ExistentialQuantification] in TcGenDeriv.
1617
1618
1619 Note [Superclasses of derived instance]
1620 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1621 In general, a derived instance decl needs the superclasses of the derived
1622 class too. So if we have
1623 data T a = ...deriving( Ord )
1624 then the initial context for Ord (T a) should include Eq (T a). Often this is
1625 redundant; we'll also generate an Ord constraint for each constructor argument,
1626 and that will probably generate enough constraints to make the Eq (T a) constraint
1627 be satisfied too. But not always; consider:
1628
1629 data S a = S
1630 instance Eq (S a)
1631 instance Ord (S a)
1632
1633 data T a = MkT (S a) deriving( Ord )
1634 instance Num a => Eq (T a)
1635
1636 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1637 Similarly consider:
1638 data T a = MkT deriving( Data )
1639 Here there *is* no argument field, but we must nevertheless generate
1640 a context for the Data instances:
1641 instance Typeable a => Data (T a) where ...
1642
1643 ************************************************************************
1644 * *
1645 Deriving newtypes
1646 * *
1647 ************************************************************************
1648 -}
1649
1650 mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [TyVar] -> Class
1651 -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1652 -> DerivContext
1653 -> TcRn EarlyDerivSpec
1654 mkNewTypeEqn dflags overlap_mode tvs
1655 cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1656 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1657 | ASSERT( length cls_tys + 1 == classArity cls )
1658 might_derive_via_coercible && ((newtype_deriving && not deriveAnyClass)
1659 || std_class_via_coercible cls)
1660 = do traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1661 dfun_name <- newDFunName' cls tycon
1662 loc <- getSrcSpanM
1663 case mtheta of
1664 Just theta -> return $ GivenTheta $ DS
1665 { ds_loc = loc
1666 , ds_name = dfun_name, ds_tvs = dfun_tvs
1667 , ds_cls = cls, ds_tys = inst_tys
1668 , ds_tc = rep_tycon
1669 , ds_theta = theta
1670 , ds_overlap = overlap_mode
1671 , ds_newtype = Just rep_inst_ty }
1672 Nothing -> return $ InferTheta $ DS
1673 { ds_loc = loc
1674 , ds_name = dfun_name, ds_tvs = dfun_tvs
1675 , ds_cls = cls, ds_tys = inst_tys
1676 , ds_tc = rep_tycon
1677 , ds_theta = all_preds
1678 , ds_overlap = overlap_mode
1679 , ds_newtype = Just rep_inst_ty }
1680 | otherwise
1681 = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1682 -- Error with standard class
1683 DerivableClassError msg
1684 | might_derive_via_coercible -> bale_out (msg $$ suggest_gnd)
1685 | otherwise -> bale_out msg
1686
1687 -- Must use newtype deriving or DeriveAnyClass
1688 NonDerivableClass _msg
1689 -- Too hard, even with newtype deriving
1690 | newtype_deriving -> bale_out cant_derive_err
1691 -- Try newtype deriving!
1692 -- Here we suggest GeneralizedNewtypeDeriving even in cases where it may
1693 -- not be applicable. See Trac #9600.
1694 | otherwise -> bale_out (non_std $$ suggest_gnd)
1695
1696 -- CanDerive/DerivableViaInstance
1697 _ -> do when (newtype_deriving && deriveAnyClass) $
1698 addWarnTc NoReason
1699 (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled"
1700 , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ])
1701 go_for_it
1702 where
1703 newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
1704 deriveAnyClass = xopt LangExt.DeriveAnyClass dflags
1705 go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args
1706 rep_tycon rep_tc_args mtheta
1707 bale_out = bale_out' newtype_deriving
1708 bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
1709
1710 non_std = nonStdErr cls
1711 suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension"
1712
1713 -- Here is the plan for newtype derivings. We see
1714 -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1715 -- where t is a type,
1716 -- ak+1...an is a suffix of a1..an, and are all tyvars
1717 -- ak+1...an do not occur free in t, nor in the s1..sm
1718 -- (C s1 ... sm) is a *partial applications* of class C
1719 -- with the last parameter missing
1720 -- (T a1 .. ak) matches the kind of C's last argument
1721 -- (and hence so does t)
1722 -- The latter kind-check has been done by deriveTyData already,
1723 -- and tc_args are already trimmed
1724 --
1725 -- We generate the instance
1726 -- instance forall ({a1..ak} u fvs(s1..sm)).
1727 -- C s1 .. sm t => C s1 .. sm (T a1...ak)
1728 -- where T a1...ap is the partial application of
1729 -- the LHS of the correct kind and p >= k
1730 --
1731 -- NB: the variables below are:
1732 -- tc_tvs = [a1, ..., an]
1733 -- tyvars_to_keep = [a1, ..., ak]
1734 -- rep_ty = t ak .. an
1735 -- deriv_tvs = fvs(s1..sm) \ tc_tvs
1736 -- tys = [s1, ..., sm]
1737 -- rep_fn' = t
1738 --
1739 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1740 -- We generate the instance
1741 -- instance Monad (ST s) => Monad (T s) where
1742
1743 nt_eta_arity = newTyConEtadArity rep_tycon
1744 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1745 -- eta-reduces the representation type, so we know that
1746 -- T a ~ S a a
1747 -- That's convenient here, because we may have to apply
1748 -- it to fewer than its original complement of arguments
1749
1750 -- Note [Newtype representation]
1751 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1752 -- Need newTyConRhs (*not* a recursive representation finder)
1753 -- to get the representation type. For example
1754 -- newtype B = MkB Int
1755 -- newtype A = MkA B deriving( Num )
1756 -- We want the Num instance of B, *not* the Num instance of Int,
1757 -- when making the Num instance of A!
1758 rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1759 rep_tys = cls_tys ++ [rep_inst_ty]
1760 rep_pred = mkClassPred cls rep_tys
1761 rep_pred_o = mkPredOrigin DerivOrigin TypeLevel rep_pred
1762 -- rep_pred is the representation dictionary, from where
1763 -- we are gong to get all the methods for the newtype
1764 -- dictionary
1765
1766 -- Next we figure out what superclass dictionaries to use
1767 -- See Note [Newtype deriving superclasses] above
1768 cls_tyvars = classTyVars cls
1769 dfun_tvs = tyCoVarsOfTypesWellScoped inst_tys
1770 inst_ty = mkTyConApp tycon tc_args
1771 inst_tys = cls_tys ++ [inst_ty]
1772 sc_theta = mkThetaOrigin DerivOrigin TypeLevel $
1773 substTheta (zipTvSubst cls_tyvars inst_tys) $
1774 classSCTheta cls
1775
1776 -- Next we collect Coercible constraints between
1777 -- the Class method types, instantiated with the representation and the
1778 -- newtype type; precisely the constraints required for the
1779 -- calls to coercible that we are going to generate.
1780 coercible_constraints =
1781 [ let (Pair t1 t2) = mkCoerceClassMethEqn cls dfun_tvs inst_tys rep_inst_ty meth
1782 in mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel
1783 (mkReprPrimEqPred t1 t2)
1784 | meth <- classMethods cls ]
1785
1786 -- If there are no tyvars, there's no need
1787 -- to abstract over the dictionaries we need
1788 -- Example: newtype T = MkT Int deriving( C )
1789 -- We get the derived instance
1790 -- instance C T
1791 -- rather than
1792 -- instance C Int => C T
1793 all_preds = rep_pred_o : coercible_constraints ++ sc_theta -- NB: rep_pred comes first
1794
1795 -------------------------------------------------------------------
1796 -- Figuring out whether we can only do this newtype-deriving thing
1797
1798 -- See Note [Determining whether newtype-deriving is appropriate]
1799 might_derive_via_coercible
1800 = not (non_coercible_class cls)
1801 && eta_ok
1802 && ats_ok
1803 -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
1804
1805 -- Check that eta reduction is OK
1806 eta_ok = nt_eta_arity <= length rep_tc_args
1807 -- The newtype can be eta-reduced to match the number
1808 -- of type argument actually supplied
1809 -- newtype T a b = MkT (S [a] b) deriving( Monad )
1810 -- Here the 'b' must be the same in the rep type (S [a] b)
1811 -- And the [a] must not mention 'b'. That's all handled
1812 -- by nt_eta_rity.
1813
1814 ats_ok = null (classATs cls)
1815 -- No associated types for the class, because we don't
1816 -- currently generate type 'instance' decls; and cannot do
1817 -- so for 'data' instance decls
1818
1819 cant_derive_err
1820 = vcat [ ppUnless eta_ok eta_msg
1821 , ppUnless ats_ok ats_msg ]
1822 eta_msg = text "cannot eta-reduce the representation type enough"
1823 ats_msg = text "the class has associated types"
1824
1825 {-
1826 Note [Recursive newtypes]
1827 ~~~~~~~~~~~~~~~~~~~~~~~~~
1828 Newtype deriving works fine, even if the newtype is recursive.
1829 e.g. newtype S1 = S1 [T1 ()]
1830 newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1831 Remember, too, that type families are currently (conservatively) given
1832 a recursive flag, so this also allows newtype deriving to work
1833 for type famillies.
1834
1835 We used to exclude recursive types, because we had a rather simple
1836 minded way of generating the instance decl:
1837 newtype A = MkA [A]
1838 instance Eq [A] => Eq A -- Makes typechecker loop!
1839 But now we require a simple context, so it's ok.
1840
1841 Note [Determining whether newtype-deriving is appropriate]
1842 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1843 When we see
1844 newtype NT = MkNT Foo
1845 deriving C
1846 we have to decide how to perform the deriving. Do we do newtype deriving,
1847 or do we do normal deriving? In general, we prefer to do newtype deriving
1848 wherever possible. So, we try newtype deriving unless there's a glaring
1849 reason not to.
1850
1851 Note that newtype deriving might fail, even after we commit to it. This
1852 is because the derived instance uses `coerce`, which must satisfy its
1853 `Coercible` constraint. This is different than other deriving scenarios,
1854 where we're sure that the resulting instance will type-check.
1855
1856 ************************************************************************
1857 * *
1858 Finding the fixed point of deriving equations
1859 * *
1860 ************************************************************************
1861
1862 Note [Simplifying the instance context]
1863 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1864 Consider
1865
1866 data T a b = C1 (Foo a) (Bar b)
1867 | C2 Int (T b a)
1868 | C3 (T a a)
1869 deriving (Eq)
1870
1871 We want to come up with an instance declaration of the form
1872
1873 instance (Ping a, Pong b, ...) => Eq (T a b) where
1874 x == y = ...
1875
1876 It is pretty easy, albeit tedious, to fill in the code "...". The
1877 trick is to figure out what the context for the instance decl is,
1878 namely Ping, Pong and friends.
1879
1880 Let's call the context reqd for the T instance of class C at types
1881 (a,b, ...) C (T a b). Thus:
1882
1883 Eq (T a b) = (Ping a, Pong b, ...)
1884
1885 Now we can get a (recursive) equation from the data decl. This part
1886 is done by inferConstraints.
1887
1888 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
1889 u Eq (T b a) u Eq Int -- From C2
1890 u Eq (T a a) -- From C3
1891
1892
1893 Foo and Bar may have explicit instances for Eq, in which case we can
1894 just substitute for them. Alternatively, either or both may have
1895 their Eq instances given by deriving clauses, in which case they
1896 form part of the system of equations.
1897
1898 Now all we need do is simplify and solve the equations, iterating to
1899 find the least fixpoint. This is done by simplifyInstanceConstraints.
1900 Notice that the order of the arguments can
1901 switch around, as here in the recursive calls to T.
1902
1903 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
1904
1905 We start with:
1906
1907 Eq (T a b) = {} -- The empty set
1908
1909 Next iteration:
1910 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
1911 u Eq (T b a) u Eq Int -- From C2
1912 u Eq (T a a) -- From C3
1913
1914 After simplification:
1915 = Eq a u Ping b u {} u {} u {}
1916 = Eq a u Ping b
1917
1918 Next iteration:
1919
1920 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
1921 u Eq (T b a) u Eq Int -- From C2
1922 u Eq (T a a) -- From C3
1923
1924 After simplification:
1925 = Eq a u Ping b
1926 u (Eq b u Ping a)
1927 u (Eq a u Ping a)
1928
1929 = Eq a u Ping b u Eq b u Ping a
1930
1931 The next iteration gives the same result, so this is the fixpoint. We
1932 need to make a canonical form of the RHS to ensure convergence. We do
1933 this by simplifying the RHS to a form in which
1934
1935 - the classes constrain only tyvars
1936 - the list is sorted by tyvar (major key) and then class (minor key)
1937 - no duplicates, of course
1938
1939 Note [Deterministic simplifyInstanceContexts]
1940 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1941 Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting
1942 with nonDetCmpType puts the returned lists in a nondeterministic order.
1943 If we were to return them, we'd get class constraints in
1944 nondeterministic order.
1945
1946 Consider:
1947
1948 data ADT a b = Z a b deriving Eq
1949
1950 The generated code could be either:
1951
1952 instance (Eq a, Eq b) => Eq (Z a b) where
1953
1954 Or:
1955
1956 instance (Eq b, Eq a) => Eq (Z a b) where
1957
1958 To prevent the order from being nondeterministic we only
1959 canonicalize when comparing and return them in the same order as
1960 simplifyDeriv returned them.
1961 See also Note [nonDetCmpType nondeterminism]
1962 -}
1963
1964
1965 simplifyInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
1966 -- Used only for deriving clauses (InferTheta)
1967 -- not for standalone deriving
1968 -- See Note [Simplifying the instance context]
1969
1970 simplifyInstanceContexts [] = return []
1971
1972 simplifyInstanceContexts infer_specs
1973 = do { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1974 ; iterate_deriv 1 initial_solutions }
1975 where
1976 ------------------------------------------------------------------
1977 -- The initial solutions for the equations claim that each
1978 -- instance has an empty context; this solution is certainly
1979 -- in canonical form.
1980 initial_solutions :: [ThetaType]
1981 initial_solutions = [ [] | _ <- infer_specs ]
1982
1983 ------------------------------------------------------------------
1984 -- iterate_deriv calculates the next batch of solutions,
1985 -- compares it with the current one; finishes if they are the
1986 -- same, otherwise recurses with the new solutions.
1987 -- It fails if any iteration fails
1988 iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
1989 iterate_deriv n current_solns
1990 | n > 20 -- Looks as if we are in an infinite loop
1991 -- This can happen if we have -XUndecidableInstances
1992 -- (See TcSimplify.tcSimplifyDeriv.)
1993 = pprPanic "solveDerivEqns: probable loop"
1994 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1995 | otherwise
1996 = do { -- Extend the inst info from the explicit instance decls
1997 -- with the current set of solutions, and simplify each RHS
1998 inst_specs <- zipWithM newDerivClsInst current_solns infer_specs
1999 ; new_solns <- checkNoErrs $
2000 extendLocalInstEnv inst_specs $
2001 mapM gen_soln infer_specs
2002
2003 ; if (current_solns `eqSolution` new_solns) then
2004 return [ spec { ds_theta = soln }
2005 | (spec, soln) <- zip infer_specs current_solns ]
2006 else
2007 iterate_deriv (n+1) new_solns }
2008
2009 eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)
2010 -- Canonicalise for comparison
2011 -- See Note [Deterministic simplifyInstanceContexts]
2012 canSolution = map (sortBy nonDetCmpType)
2013 ------------------------------------------------------------------
2014 gen_soln :: DerivSpec ThetaOrigin -> TcM ThetaType
2015 gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
2016 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
2017 = setSrcSpan loc $
2018 addErrCtxt (derivInstCtxt the_pred) $
2019 do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
2020 -- checkValidInstance tyvars theta clas inst_tys
2021 -- Not necessary; see Note [Exotic derived instance contexts]
2022
2023 ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
2024 -- Claim: the result instance declaration is guaranteed valid
2025 -- Hence no need to call:
2026 -- checkValidInstance tyvars theta clas inst_tys
2027 ; return theta }
2028 where
2029 the_pred = mkClassPred clas inst_tys
2030
2031 ------------------------------------------------------------------
2032 newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
2033 newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
2034 , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
2035 = newClsInst overlap_mode dfun_name tvs theta clas tys
2036
2037 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
2038 -- Add new locally-defined instances; don't bother to check
2039 -- for functional dependency errors -- that'll happen in TcInstDcls
2040 extendLocalInstEnv dfuns thing_inside
2041 = do { env <- getGblEnv
2042 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
2043 env' = env { tcg_inst_env = inst_env' }
2044 ; setGblEnv env' thing_inside }
2045
2046 {-
2047 ***********************************************************************************
2048 * *
2049 * Simplify derived constraints
2050 * *
2051 ***********************************************************************************
2052 -}
2053
2054 -- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much
2055 -- as possible. Fail if not possible.
2056 simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are
2057 -- deriving. Only used for SkolemInfo.
2058 -> [TyVar] -- ^ The tyvars bound by @inst_ty@.
2059 -> ThetaOrigin -- ^ @wanted@ constraints, i.e. @['PredOrigin']@.
2060 -> TcM ThetaType -- ^ Needed constraints (after simplification),
2061 -- i.e. @['PredType']@.
2062 simplifyDeriv pred tvs theta
2063 = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
2064 -- The constraint solving machinery
2065 -- expects *TcTyVars* not TyVars.
2066 -- We use *non-overlappable* (vanilla) skolems
2067 -- See Note [Overlap and deriving]
2068
2069 ; let skol_set = mkVarSet tvs_skols
2070 skol_info = DerivSkol pred
2071 doc = text "deriving" <+> parens (ppr pred)
2072 mk_ct (PredOrigin t o t_or_k)
2073 = newWanted o (Just t_or_k) (substTy skol_subst t)
2074
2075 -- Generate the wanted constraints with the skolemized variables
2076 ; (wanted, tclvl) <- pushTcLevelM (mapM mk_ct theta)
2077
2078 ; traceTc "simplifyDeriv inputs" $
2079 vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
2080 -- Simplify the constraints
2081 ; residual_wanted <- simplifyWantedsTcM wanted
2082 -- Result is zonked
2083
2084 -- Split the resulting constraints into bad and good constraints,
2085 -- building an @unsolved :: WantedConstraints@ representing all
2086 -- the constraints we can't just shunt to the predicates.
2087 -- See Note [Exotic derived instance contexts]
2088 ; let residual_simple = wc_simple residual_wanted
2089 (bad, good) = partitionBagWith get_good residual_simple
2090 unsolved = residual_wanted { wc_simple = bad }
2091
2092 -- See Note [Exotic derived instance contexts]
2093
2094 get_good :: Ct -> Either Ct PredType
2095 get_good ct | validDerivPred skol_set p
2096 , isWantedCt ct
2097 = Right p
2098 -- NB re 'isWantedCt': residual_wanted may contain
2099 -- unsolved CtDerived and we stick them into the
2100 -- bad set so that reportUnsolved may decide what
2101 -- to do with them
2102 | otherwise
2103 = Left ct
2104 where p = ctPred ct
2105
2106 ; traceTc "simplifyDeriv outputs" $
2107 vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]
2108
2109 -- If we are deferring type errors, simply ignore any insoluble
2110 -- constraints. They'll come up again when we typecheck the
2111 -- generated instance declaration
2112 ; defer <- goptM Opt_DeferTypeErrors
2113 ; (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
2114 -- The buildImplicationFor is just to bind the skolems,
2115 -- in case they are mentioned in error messages
2116 -- See Trac #11347
2117 -- Report the (bad) unsolved constraints
2118 ; unless defer (reportAllUnsolved (mkImplicWC implic))
2119
2120
2121 -- Return the good unsolved constraints (unskolemizing on the way out.)
2122 ; let min_theta = mkMinimalBySCs (bagToList good)
2123 subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs
2124 -- The reverse substitution (sigh)
2125 ; return (substTheta subst_skol min_theta) }
2126
2127 {-
2128 Note [Overlap and deriving]
2129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
2130 Consider some overlapping instances:
2131 data Show a => Show [a] where ..
2132 data Show [Char] where ...
2133
2134 Now a data type with deriving:
2135 data T a = MkT [a] deriving( Show )
2136
2137 We want to get the derived instance
2138 instance Show [a] => Show (T a) where...
2139 and NOT
2140 instance Show a => Show (T a) where...
2141 so that the (Show (T Char)) instance does the Right Thing
2142
2143 It's very like the situation when we're inferring the type
2144 of a function
2145 f x = show [x]
2146 and we want to infer
2147 f :: Show [a] => a -> String
2148
2149 BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
2150 the context for the derived instance.
2151 Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
2152
2153 Note [Exotic derived instance contexts]
2154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2155 In a 'derived' instance declaration, we *infer* the context. It's a
2156 bit unclear what rules we should apply for this; the Haskell report is
2157 silent. Obviously, constraints like (Eq a) are fine, but what about
2158 data T f a = MkT (f a) deriving( Eq )
2159 where we'd get an Eq (f a) constraint. That's probably fine too.
2160
2161 One could go further: consider
2162 data T a b c = MkT (Foo a b c) deriving( Eq )
2163 instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
2164
2165 Notice that this instance (just) satisfies the Paterson termination
2166 conditions. Then we *could* derive an instance decl like this:
2167
2168 instance (C Int a, Eq b, Eq c) => Eq (T a b c)
2169 even though there is no instance for (C Int a), because there just
2170 *might* be an instance for, say, (C Int Bool) at a site where we
2171 need the equality instance for T's.
2172
2173 However, this seems pretty exotic, and it's quite tricky to allow
2174 this, and yet give sensible error messages in the (much more common)
2175 case where we really want that instance decl for C.
2176
2177 So for now we simply require that the derived instance context
2178 should have only type-variable constraints.
2179
2180 Here is another example:
2181 data Fix f = In (f (Fix f)) deriving( Eq )
2182 Here, if we are prepared to allow -XUndecidableInstances we
2183 could derive the instance
2184 instance Eq (f (Fix f)) => Eq (Fix f)
2185 but this is so delicate that I don't think it should happen inside
2186 'deriving'. If you want this, write it yourself!
2187
2188 NB: if you want to lift this condition, make sure you still meet the
2189 termination conditions! If not, the deriving mechanism generates
2190 larger and larger constraints. Example:
2191 data Succ a = S a
2192 data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
2193
2194 Note the lack of a Show instance for Succ. First we'll generate
2195 instance (Show (Succ a), Show a) => Show (Seq a)
2196 and then
2197 instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
2198 and so on. Instead we want to complain of no instance for (Show (Succ a)).
2199
2200 The bottom line
2201 ~~~~~~~~~~~~~~~
2202 Allow constraints which consist only of type variables, with no repeats.
2203
2204
2205 ************************************************************************
2206 * *
2207 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
2208 * *
2209 ************************************************************************
2210
2211 After all the trouble to figure out the required context for the
2212 derived instance declarations, all that's left is to chug along to
2213 produce them. They will then be shoved into @tcInstDecls2@, which
2214 will do all its usual business.
2215
2216 There are lots of possibilities for code to generate. Here are
2217 various general remarks.
2218
2219 PRINCIPLES:
2220 \begin{itemize}
2221 \item
2222 We want derived instances of @Eq@ and @Ord@ (both v common) to be
2223 ``you-couldn't-do-better-by-hand'' efficient.
2224
2225 \item
2226 Deriving @Show@---also pretty common--- should also be reasonable good code.
2227
2228 \item
2229 Deriving for the other classes isn't that common or that big a deal.
2230 \end{itemize}
2231
2232 PRAGMATICS:
2233
2234 \begin{itemize}
2235 \item
2236 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
2237
2238 \item
2239 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
2240
2241 \item
2242 We {\em normally} generate code only for the non-defaulted methods;
2243 there are some exceptions for @Eq@ and (especially) @Ord@...
2244
2245 \item
2246 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
2247 constructor's numeric (@Int#@) tag. These are generated by
2248 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
2249 these is around is given by @hasCon2TagFun@.
2250
2251 The examples under the different sections below will make this
2252 clearer.
2253
2254 \item
2255 Much less often (really just for deriving @Ix@), we use a
2256 @_tag2con_<tycon>@ function. See the examples.
2257
2258 \item
2259 We use the renamer!!! Reason: we're supposed to be
2260 producing @LHsBinds Name@ for the methods, but that means
2261 producing correctly-uniquified code on the fly. This is entirely
2262 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
2263 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
2264 the renamer. What a great hack!
2265 \end{itemize}
2266 -}
2267
2268 -- Generate the InstInfo for the required instance paired with the
2269 -- *representation* tycon for that instance,
2270 -- plus any auxiliary bindings required
2271 --
2272 -- Representation tycons differ from the tycon in the instance signature in
2273 -- case of instances for indexed families.
2274 --
2275 genInst :: DerivSpec ThetaType
2276 -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
2277 genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
2278 , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
2279 , ds_cls = clas, ds_loc = loc })
2280 | Just rhs_ty <- is_newtype -- See Note [Bindings for Generalised Newtype Deriving]
2281 = do { inst_spec <- newDerivClsInst theta spec
2282 ; return ( InstInfo
2283 { iSpec = inst_spec
2284 , iBinds = InstBindings
2285 { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
2286 , ib_tyvars = map Var.varName tvs -- Scope over bindings
2287 , ib_pragmas = []
2288 , ib_extensions = [ LangExt.ImpredicativeTypes
2289 , LangExt.RankNTypes ]
2290 , ib_derived = True } }
2291 , emptyBag
2292 , Just $ getName $ head $ tyConDataCons rep_tycon ) }
2293 -- See Note [Newtype deriving and unused constructors]
2294
2295 | otherwise
2296 = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas rep_tycon tys tvs
2297 ; inst_spec <- newDerivClsInst theta spec
2298 ; traceTc "newder" (ppr inst_spec)
2299 ; let inst_info = InstInfo { iSpec = inst_spec
2300 , iBinds = InstBindings
2301 { ib_binds = meth_binds
2302 , ib_tyvars = map Var.varName tvs
2303 , ib_pragmas = []
2304 , ib_extensions = []
2305 , ib_derived = True } }
2306 ; return ( inst_info, deriv_stuff, Nothing ) }
2307
2308 -- Generate the bindings needed for a derived class that isn't handled by
2309 -- -XGeneralizedNewtypeDeriving.
2310 genDerivStuff :: SrcSpan -> Class -> TyCon -> [Type] -> [TyVar]
2311 -> TcM (LHsBinds RdrName, BagDerivStuff)
2312 genDerivStuff loc clas tycon inst_tys tyvars
2313 -- Special case for DeriveGeneric
2314 | let ck = classKey clas
2315 , ck `elem` [genClassKey, gen1ClassKey]
2316 = let gk = if ck == genClassKey then Gen0 else Gen1
2317 -- TODO NSF: correctly identify when we're building Both instead of One
2318 in do
2319 (binds, faminst) <- gen_Generic_binds gk tycon inst_tys
2320 return (binds, unitBag (DerivFamInst faminst))
2321
2322 -- Not deriving Generic(1), so we first check if the compiler has built-in
2323 -- support for deriving the class in question.
2324 | Just gen_fn <- hasBuiltinDeriving clas
2325 = gen_fn loc tycon
2326
2327 | otherwise
2328 = do { -- If there isn't compiler support for deriving the class, our last
2329 -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
2330 -- fell through).
2331 let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
2332 mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
2333
2334 ; dflags <- getDynFlags
2335 ; tyfam_insts <-
2336 ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
2337 , ppr "genDerivStuff: bad derived class" <+> ppr clas )
2338 mapM (tcATDefault False loc mini_subst emptyNameSet)
2339 (classATItems clas)
2340 ; return ( emptyBag -- No method bindings are needed...
2341 , listToBag (map DerivFamInst (concat tyfam_insts))
2342 -- ...but we may need to generate binding for associated type
2343 -- family default instances.
2344 -- See Note [DeriveAnyClass and default family instances]
2345 ) }
2346
2347 {-
2348 Note [Bindings for Generalised Newtype Deriving]
2349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2350 Consider
2351 class Eq a => C a where
2352 f :: a -> a
2353 newtype N a = MkN [a] deriving( C )
2354 instance Eq (N a) where ...
2355
2356 The 'deriving C' clause generates, in effect
2357 instance (C [a], Eq a) => C (N a) where
2358 f = coerce (f :: [a] -> [a])
2359
2360 This generates a cast for each method, but allows the superclasse to
2361 be worked out in the usual way. In this case the superclass (Eq (N
2362 a)) will be solved by the explicit Eq (N a) instance. We do *not*
2363 create the superclasses by casting the superclass dictionaries for the
2364 representation type.
2365
2366 See the paper "Safe zero-cost coercions for Haskell".
2367
2368 Note [DeriveAnyClass and default family instances]
2369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2370
2371 When a class has a associated type family with a default instance, e.g.:
2372
2373 class C a where
2374 type T a
2375 type T a = Char
2376
2377 then there are a couple of scenarios in which a user would expect T a to
2378 default to Char. One is when an instance declaration for C is given without
2379 an implementation for T:
2380
2381 instance C Int
2382
2383 Another scenario in which this can occur is when the -XDeriveAnyClass extension
2384 is used:
2385
2386 data Example = Example deriving (C, Generic)
2387
2388 In the latter case, we must take care to check if C has any associated type
2389 families with default instances, because -XDeriveAnyClass will never provide
2390 an implementation for them. We "fill in" the default instances using the
2391 tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
2392 the empty instance declaration case).
2393
2394 ************************************************************************
2395 * *
2396 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
2397 * *
2398 ************************************************************************
2399 -}
2400
2401 derivingNullaryErr :: MsgDoc
2402 derivingNullaryErr = text "Cannot derive instances for nullary classes"
2403
2404 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc
2405 derivingKindErr tc cls cls_tys cls_kind enough_args
2406 = sep [ hang (text "Cannot derive well-kinded instance of form"
2407 <+> quotes (pprClassPred cls cls_tys
2408 <+> parens (ppr tc <+> text "...")))
2409 2 gen1_suggestion
2410 , nest 2 (text "Class" <+> quotes (ppr cls)
2411 <+> text "expects an argument of kind"
2412 <+> quotes (pprKind cls_kind))
2413 ]
2414 where
2415 gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args
2416 = text "(Perhaps you intended to use PolyKinds)"
2417 | otherwise = Outputable.empty
2418
2419 derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
2420 derivingEtaErr cls cls_tys inst_ty
2421 = sep [text "Cannot eta-reduce to an instance of form",
2422 nest 2 (text "instance (...) =>"
2423 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
2424
2425 derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc
2426 derivingThingErr newtype_deriving clas tys ty why
2427 = sep [(hang (text "Can't make a derived instance of")
2428 2 (quotes (ppr pred))
2429 $$ nest 2 extra) <> colon,
2430 nest 2 why]
2431 where
2432 extra | newtype_deriving = text "(even with cunning GeneralizedNewtypeDeriving)"
2433 | otherwise = Outputable.empty
2434 pred = mkClassPred clas (tys ++ [ty])
2435
2436 derivingHiddenErr :: TyCon -> SDoc
2437 derivingHiddenErr tc
2438 = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
2439 2 (text "so you cannot derive an instance for it")
2440
2441 standaloneCtxt :: LHsSigType Name -> SDoc
2442 standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
2443 2 (quotes (ppr ty))
2444
2445 derivInstCtxt :: PredType -> MsgDoc
2446 derivInstCtxt pred
2447 = text "When deriving the instance for" <+> parens (ppr pred)