f27516258bcd87b163caf42583cd3be303319228
[ghc.git] / compiler / typecheck / TcDerivUtils.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Error-checking and other utilities for @deriving@ clauses or declarations.
7 -}
8
9 {-# LANGUAGE TypeFamilies #-}
10
11 module TcDerivUtils (
12 DerivM, DerivEnv(..),
13 DerivSpec(..), pprDerivSpec,
14 DerivSpecMechanism(..), isDerivSpecStock,
15 isDerivSpecNewtype, isDerivSpecAnyClass,
16 DerivContext, DerivStatus(..),
17 PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
18 mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
19 checkSideConditions, hasStockDeriving,
20 canDeriveAnyClass,
21 std_class_via_coercible, non_coercible_class,
22 newDerivClsInst, extendLocalInstEnv
23 ) where
24
25 import GhcPrelude
26
27 import Bag
28 import BasicTypes
29 import Class
30 import DataCon
31 import DynFlags
32 import ErrUtils
33 import HscTypes (lookupFixity, mi_fix)
34 import HsSyn
35 import Inst
36 import InstEnv
37 import LoadIface (loadInterfaceForName)
38 import Module (getModule)
39 import Name
40 import Outputable
41 import PrelNames
42 import SrcLoc
43 import TcGenDeriv
44 import TcGenFunctor
45 import TcGenGenerics
46 import TcRnMonad
47 import TcType
48 import THNames (liftClassKey)
49 import TyCon
50 import Type
51 import Util
52 import VarSet
53
54 import Control.Monad.Trans.Reader
55 import qualified GHC.LanguageExtensions as LangExt
56 import ListSetOps (assocMaybe)
57
58 -- | To avoid having to manually plumb everything in 'DerivEnv' throughout
59 -- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which
60 -- is a simple reader around 'TcRn'.
61 type DerivM = ReaderT DerivEnv TcRn
62
63 -- | Contains all of the information known about a derived instance when
64 -- determining what its @EarlyDerivSpec@ should be.
65 data DerivEnv = DerivEnv
66 { denv_overlap_mode :: Maybe OverlapMode
67 -- ^ Is this an overlapping instance?
68 , denv_tvs :: [TyVar]
69 -- ^ Universally quantified type variables in the instance
70 , denv_cls :: Class
71 -- ^ Class for which we need to derive an instance
72 , denv_cls_tys :: [Type]
73 -- ^ Other arguments to the class except the last
74 , denv_tc :: TyCon
75 -- ^ Type constructor for which the instance is requested
76 -- (last arguments to the type class)
77 , denv_tc_args :: [Type]
78 -- ^ Arguments to the type constructor
79 , denv_rep_tc :: TyCon
80 -- ^ The representation tycon for 'denv_tc'
81 -- (for data family instances)
82 , denv_rep_tc_args :: [Type]
83 -- ^ The representation types for 'denv_tc_args'
84 -- (for data family instances)
85 , denv_mtheta :: DerivContext
86 -- ^ 'Just' the context of the instance, for standalone deriving.
87 -- 'Nothing' for @deriving@ clauses.
88 , denv_strat :: Maybe DerivStrategy
89 -- ^ 'Just' if user requests a particular deriving strategy.
90 -- Otherwise, 'Nothing'.
91 }
92
93 instance Outputable DerivEnv where
94 ppr (DerivEnv { denv_overlap_mode = overlap_mode
95 , denv_tvs = tvs
96 , denv_cls = cls
97 , denv_cls_tys = cls_tys
98 , denv_tc = tc
99 , denv_tc_args = tc_args
100 , denv_rep_tc = rep_tc
101 , denv_rep_tc_args = rep_tc_args
102 , denv_mtheta = mtheta
103 , denv_strat = mb_strat })
104 = hang (text "DerivEnv")
105 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
106 , text "denv_tvs" <+> ppr tvs
107 , text "denv_cls" <+> ppr cls
108 , text "denv_cls_tys" <+> ppr cls_tys
109 , text "denv_tc" <+> ppr tc
110 , text "denv_tc_args" <+> ppr tc_args
111 , text "denv_rep_tc" <+> ppr rep_tc
112 , text "denv_rep_tc_args" <+> ppr rep_tc_args
113 , text "denv_mtheta" <+> ppr mtheta
114 , text "denv_strat" <+> ppr mb_strat ])
115
116 data DerivSpec theta = DS { ds_loc :: SrcSpan
117 , ds_name :: Name -- DFun name
118 , ds_tvs :: [TyVar]
119 , ds_theta :: theta
120 , ds_cls :: Class
121 , ds_tys :: [Type]
122 , ds_tc :: TyCon
123 , ds_overlap :: Maybe OverlapMode
124 , ds_mechanism :: DerivSpecMechanism }
125 -- This spec implies a dfun declaration of the form
126 -- df :: forall tvs. theta => C tys
127 -- The Name is the name for the DFun we'll build
128 -- The tyvars bind all the variables in the theta
129 -- For type families, the tycon in
130 -- in ds_tys is the *family* tycon
131 -- in ds_tc is the *representation* type
132 -- For non-family tycons, both are the same
133
134 -- the theta is either the given and final theta, in standalone deriving,
135 -- or the not-yet-simplified list of constraints together with their origin
136
137 -- ds_mechanism specifies the means by which GHC derives the instance.
138 -- See Note [Deriving strategies] in TcDeriv
139
140 {-
141 Example:
142
143 newtype instance T [a] = MkT (Tree a) deriving( C s )
144 ==>
145 axiom T [a] = :RTList a
146 axiom :RTList a = Tree a
147
148 DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
149 , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
150 -}
151
152 pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
153 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
154 ds_tys = tys, ds_theta = rhs, ds_mechanism = mech })
155 = hang (text "DerivSpec")
156 2 (vcat [ text "ds_loc =" <+> ppr l
157 , text "ds_name =" <+> ppr n
158 , text "ds_tvs =" <+> ppr tvs
159 , text "ds_cls =" <+> ppr c
160 , text "ds_tys =" <+> ppr tys
161 , text "ds_theta =" <+> ppr rhs
162 , text "ds_mechanism =" <+> ppr mech ])
163
164 instance Outputable theta => Outputable (DerivSpec theta) where
165 ppr = pprDerivSpec
166
167 -- What action to take in order to derive a class instance.
168 -- See Note [Deriving strategies] in TcDeriv
169 data DerivSpecMechanism
170 = DerivSpecStock -- "Standard" classes
171 (SrcSpan -> TyCon
172 -> [Type]
173 -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
174 -- This function returns three things:
175 --
176 -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
177 -- (e.g., @compare (T x) (T y) = compare x y@)
178 -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived
179 -- instance. As examples, derived 'Generic' instances require
180 -- associated type family instances, and derived 'Eq' and 'Ord'
181 -- instances require top-level @con2tag@ functions.
182 -- See Note [Auxiliary binders] in TcGenDeriv.
183 -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be
184 -- suppressed. This is used to suppress unused warnings for record
185 -- selectors when deriving 'Read', 'Show', or 'Generic'.
186 -- See Note [Deriving and unused record selectors].
187
188 | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
189 Type -- The newtype rep type
190
191 | DerivSpecAnyClass -- -XDeriveAnyClass
192
193 isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass
194 :: DerivSpecMechanism -> Bool
195 isDerivSpecStock (DerivSpecStock{}) = True
196 isDerivSpecStock _ = False
197
198 isDerivSpecNewtype (DerivSpecNewtype{}) = True
199 isDerivSpecNewtype _ = False
200
201 isDerivSpecAnyClass (DerivSpecAnyClass{}) = True
202 isDerivSpecAnyClass _ = False
203
204 -- A DerivSpecMechanism can be losslessly converted to a DerivStrategy.
205 mechanismToStrategy :: DerivSpecMechanism -> DerivStrategy
206 mechanismToStrategy (DerivSpecStock{}) = StockStrategy
207 mechanismToStrategy (DerivSpecNewtype{}) = NewtypeStrategy
208 mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy
209
210 instance Outputable DerivSpecMechanism where
211 ppr = ppr . mechanismToStrategy
212
213 type DerivContext = Maybe ThetaType
214 -- Nothing <=> Vanilla deriving; infer the context of the instance decl
215 -- Just theta <=> Standalone deriving: context supplied by programmer
216
217 data DerivStatus = CanDerive -- Stock class, can derive
218 | DerivableClassError SDoc -- Stock class, but can't do it
219 | DerivableViaInstance -- See Note [Deriving any class]
220 | NonDerivableClass SDoc -- Non-stock class
221
222 -- A stock class is one either defined in the Haskell report or for which GHC
223 -- otherwise knows how to generate code for (possibly requiring the use of a
224 -- language extension), such as Eq, Ord, Ix, Data, Generic, etc.
225
226 -- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
227 -- and whether or the constraint deals in types or kinds.
228 data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
229
230 -- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') alongside
231 -- any corresponding given constraints ('to_givens') and locally quantified
232 -- type variables ('to_tvs').
233 --
234 -- In most cases, 'to_givens' will be empty, as most deriving mechanisms (e.g.,
235 -- stock and newtype deriving) do not require given constraints. The exception
236 -- is @DeriveAnyClass@, which can involve given constraints. For example,
237 -- if you tried to derive an instance for the following class using
238 -- @DeriveAnyClass@:
239 --
240 -- @
241 -- class Foo a where
242 -- bar :: a -> b -> String
243 -- default bar :: (Show a, Ix b) => a -> b -> String
244 -- bar = show
245 --
246 -- baz :: Eq a => a -> a -> Bool
247 -- default baz :: Ord a => a -> a -> Bool
248 -- baz x y = compare x y == EQ
249 -- @
250 --
251 -- Then it would generate two 'ThetaOrigin's, one for each method:
252 --
253 -- @
254 -- [ ThetaOrigin { to_tvs = [b]
255 -- , to_givens = []
256 -- , to_wanted_origins = [Show a, Ix b] }
257 -- , ThetaOrigin { to_tvs = []
258 -- , to_givens = [Eq a]
259 -- , to_wanted_origins = [Ord a] }
260 -- ]
261 -- @
262 data ThetaOrigin
263 = ThetaOrigin { to_tvs :: [TyVar]
264 , to_givens :: ThetaType
265 , to_wanted_origins :: [PredOrigin] }
266
267 instance Outputable PredOrigin where
268 ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
269
270 instance Outputable ThetaOrigin where
271 ppr (ThetaOrigin { to_tvs = tvs
272 , to_givens = givens
273 , to_wanted_origins = wanted_origins })
274 = hang (text "ThetaOrigin")
275 2 (vcat [ text "to_tvs =" <+> ppr tvs
276 , text "to_givens =" <+> ppr givens
277 , text "to_wanted_origins =" <+> ppr wanted_origins ])
278
279 mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
280 mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
281
282 mkThetaOrigin :: CtOrigin -> TypeOrKind -> [TyVar] -> ThetaType -> ThetaType
283 -> ThetaOrigin
284 mkThetaOrigin origin t_or_k tvs givens
285 = ThetaOrigin tvs givens . map (mkPredOrigin origin t_or_k)
286
287 -- A common case where the ThetaOrigin only contains wanted constraints, with
288 -- no givens or locally scoped type variables.
289 mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
290 mkThetaOriginFromPreds = ThetaOrigin [] []
291
292 substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
293 substPredOrigin subst (PredOrigin pred origin t_or_k)
294 = PredOrigin (substTy subst pred) origin t_or_k
295
296 {-
297 ************************************************************************
298 * *
299 Class deriving diagnostics
300 * *
301 ************************************************************************
302
303 Only certain blessed classes can be used in a deriving clause (without the
304 assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
305 are listed below in the definition of hasStockDeriving. The sideConditions
306 function determines the criteria that needs to be met in order for a particular
307 class to be able to be derived successfully.
308
309 A class might be able to be used in a deriving clause if -XDeriveAnyClass
310 is willing to support it. The canDeriveAnyClass function checks if this is the
311 case.
312 -}
313
314 hasStockDeriving
315 :: Class -> Maybe (SrcSpan
316 -> TyCon
317 -> [Type]
318 -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
319 hasStockDeriving clas
320 = assocMaybe gen_list (getUnique clas)
321 where
322 gen_list
323 :: [(Unique, SrcSpan
324 -> TyCon
325 -> [Type]
326 -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
327 gen_list = [ (eqClassKey, simpleM gen_Eq_binds)
328 , (ordClassKey, simpleM gen_Ord_binds)
329 , (enumClassKey, simpleM gen_Enum_binds)
330 , (boundedClassKey, simple gen_Bounded_binds)
331 , (ixClassKey, simpleM gen_Ix_binds)
332 , (showClassKey, read_or_show gen_Show_binds)
333 , (readClassKey, read_or_show gen_Read_binds)
334 , (dataClassKey, simpleM gen_Data_binds)
335 , (functorClassKey, simple gen_Functor_binds)
336 , (foldableClassKey, simple gen_Foldable_binds)
337 , (traversableClassKey, simple gen_Traversable_binds)
338 , (liftClassKey, simple gen_Lift_binds)
339 , (genClassKey, generic (gen_Generic_binds Gen0))
340 , (gen1ClassKey, generic (gen_Generic_binds Gen1)) ]
341
342 simple gen_fn loc tc _
343 = let (binds, deriv_stuff) = gen_fn loc tc
344 in return (binds, deriv_stuff, [])
345
346 simpleM gen_fn loc tc _
347 = do { (binds, deriv_stuff) <- gen_fn loc tc
348 ; return (binds, deriv_stuff, []) }
349
350 read_or_show gen_fn loc tc _
351 = do { fix_env <- getDataConFixityFun tc
352 ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
353 field_names = all_field_names tc
354 ; return (binds, deriv_stuff, field_names) }
355
356 generic gen_fn _ tc inst_tys
357 = do { (binds, faminst) <- gen_fn tc inst_tys
358 ; let field_names = all_field_names tc
359 ; return (binds, unitBag (DerivFamInst faminst), field_names) }
360
361 -- See Note [Deriving and unused record selectors]
362 all_field_names = map flSelector . concatMap dataConFieldLabels
363 . tyConDataCons
364
365 {-
366 Note [Deriving and unused record selectors]
367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368 Consider this (see Trac #13919):
369
370 module Main (main) where
371
372 data Foo = MkFoo {bar :: String} deriving Show
373
374 main :: IO ()
375 main = print (Foo "hello")
376
377 Strictly speaking, the record selector `bar` is unused in this module, since
378 neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
379 However, the behavior of `main` is affected by the presence of `bar`, since
380 it will print different output depending on whether `MkFoo` is defined using
381 record selectors or not. Therefore, we do not to issue a
382 "Defined but not used: ‘bar’" warning for this module, since removing `bar`
383 changes the program's behavior. This is the reason behind the [Name] part of
384 the return type of `hasStockDeriving`—it tracks all of the record selector
385 `Name`s for which -Wunused-binds should be suppressed.
386
387 Currently, the only three stock derived classes that require this are Read,
388 Show, and Generic, as their derived code all depend on the record selectors
389 of the derived data type's constructors.
390
391 See also Note [Newtype deriving and unused constructors] in TcDeriv for
392 another example of a similar trick.
393 -}
394
395 getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
396 -- If the TyCon is locally defined, we want the local fixity env;
397 -- but if it is imported (which happens for standalone deriving)
398 -- we need to get the fixity env from the interface file
399 -- c.f. RnEnv.lookupFixity, and Trac #9830
400 getDataConFixityFun tc
401 = do { this_mod <- getModule
402 ; if nameIsLocalOrFrom this_mod name
403 then do { fix_env <- getFixityEnv
404 ; return (lookupFixity fix_env) }
405 else do { iface <- loadInterfaceForName doc name
406 -- Should already be loaded!
407 ; return (mi_fix iface . nameOccName) } }
408 where
409 name = tyConName tc
410 doc = text "Data con fixities for" <+> ppr name
411
412 ------------------------------------------------------------------
413 -- Check side conditions that dis-allow derivability for particular classes
414 -- This is *apart* from the newtype-deriving mechanism
415 --
416 -- Here we get the representation tycon in case of family instances as it has
417 -- the data constructors - but we need to be careful to fall back to the
418 -- family tycon (with indexes) in error messages.
419
420 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
421 -> TyCon -- tycon
422 -> DerivStatus
423 checkSideConditions dflags mtheta cls cls_tys rep_tc
424 | Just cond <- sideConditions mtheta cls
425 = case (cond dflags rep_tc) of
426 NotValid err -> DerivableClassError err -- Class-specific error
427 IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
428 -> CanDerive
429 -- All stock derivable classes are unary in the sense that
430 -- there should be not types in cls_tys (i.e., no type args
431 -- other than last). Note that cls_types can contain
432 -- invisible types as well (e.g., for Generic1, which is
433 -- poly-kinded), so make sure those are not counted.
434 | otherwise -> DerivableClassError (classArgsErr cls cls_tys)
435 -- e.g. deriving( Eq s )
436
437 | NotValid err <- canDeriveAnyClass dflags
438 = NonDerivableClass err -- DeriveAnyClass does not work
439
440 | otherwise
441 = DerivableViaInstance -- DeriveAnyClass should work
442
443 classArgsErr :: Class -> [Type] -> SDoc
444 classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
445
446 -- Side conditions (whether the datatype must have at least one constructor,
447 -- required language extensions, etc.) for using GHC's stock deriving
448 -- mechanism on certain classes (as opposed to classes that require
449 -- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
450 -- class for which stock deriving isn't possible.
451 sideConditions :: DerivContext -> Class -> Maybe Condition
452 sideConditions mtheta cls
453 | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
454 | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
455 | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
456 | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls)
457 | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
458 | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
459 | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
460 | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
461 cond_std `andCond`
462 cond_args cls)
463 | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
464 cond_vanilla `andCond`
465 cond_functorOK True False)
466 | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
467 cond_vanilla `andCond`
468 cond_functorOK False True)
469 -- Functor/Fold/Trav works ok
470 -- for rank-n types
471 | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
472 cond_vanilla `andCond`
473 cond_functorOK False False)
474 | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
475 cond_vanilla `andCond`
476 cond_RepresentableOk)
477 | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
478 cond_vanilla `andCond`
479 cond_Representable1Ok)
480 | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
481 cond_vanilla `andCond`
482 cond_args cls)
483 | otherwise = Nothing
484 where
485 cls_key = getUnique cls
486 cond_std = cond_stdOK mtheta False -- Vanilla data constructors, at least one,
487 -- and monotype arguments
488 cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but
489 -- allow no data cons or polytype arguments
490
491 canDeriveAnyClass :: DynFlags -> Validity
492 -- IsValid: we can (try to) derive it via an empty instance declaration
493 -- NotValid s: we can't, reason s
494 canDeriveAnyClass dflags
495 | not (xopt LangExt.DeriveAnyClass dflags)
496 = NotValid (text "Try enabling DeriveAnyClass")
497 | otherwise
498 = IsValid -- OK!
499
500 type Condition = DynFlags -> TyCon -> Validity
501 -- TyCon is the *representation* tycon if the data type is an indexed one
502 -- Nothing => OK
503
504 orCond :: Condition -> Condition -> Condition
505 orCond c1 c2 dflags tc
506 = case (c1 dflags tc, c2 dflags tc) of
507 (IsValid, _) -> IsValid -- c1 succeeds
508 (_, IsValid) -> IsValid -- c21 succeeds
509 (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y)
510 -- Both fail
511
512 andCond :: Condition -> Condition -> Condition
513 andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc
514
515 cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
516 -- if standalone, we just say "yes, go for it"
517 -> Bool -- True <=> permissive: allow higher rank
518 -- args and no data constructors
519 -> Condition
520 cond_stdOK (Just _) _ _ _
521 = IsValid -- Don't check these conservative conditions for
522 -- standalone deriving; just generate the code
523 -- and let the typechecker handle the result
524 cond_stdOK Nothing permissive _ rep_tc
525 | null data_cons
526 , not permissive = NotValid (no_cons_why rep_tc $$ suggestion)
527 | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)
528 | otherwise = IsValid
529 where
530 suggestion = text "Possible fix: use a standalone deriving declaration instead"
531 data_cons = tyConDataCons rep_tc
532 con_whys = getInvalids (map check_con data_cons)
533
534 check_con :: DataCon -> Validity
535 check_con con
536 | not (null eq_spec)
537 = bad "is a GADT"
538 | not (null ex_tvs)
539 = bad "has existential type variables in its type"
540 | not (null theta)
541 = bad "has constraints in its type"
542 | not (permissive || all isTauTy (dataConOrigArgTys con))
543 = bad "has a higher-rank type"
544 | otherwise
545 = IsValid
546 where
547 (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
548 bad msg = NotValid (badCon con (text msg))
549
550 no_cons_why :: TyCon -> SDoc
551 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
552 text "must have at least one data constructor"
553
554 cond_RepresentableOk :: Condition
555 cond_RepresentableOk _ tc = canDoGenerics tc
556
557 cond_Representable1Ok :: Condition
558 cond_Representable1Ok _ tc = canDoGenerics1 tc
559
560 cond_enumOrProduct :: Class -> Condition
561 cond_enumOrProduct cls = cond_isEnumeration `orCond`
562 (cond_isProduct `andCond` cond_args cls)
563
564 cond_args :: Class -> Condition
565 -- For some classes (eg Eq, Ord) we allow unlifted arg types
566 -- by generating specialised code. For others (eg Data) we don't.
567 cond_args cls _ tc
568 = case bad_args of
569 [] -> IsValid
570 (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
571 2 (text "for type" <+> quotes (ppr ty)))
572 where
573 bad_args = [ arg_ty | con <- tyConDataCons tc
574 , arg_ty <- dataConOrigArgTys con
575 , isUnliftedType arg_ty
576 , not (ok_ty arg_ty) ]
577
578 cls_key = classKey cls
579 ok_ty arg_ty
580 | cls_key == eqClassKey = check_in arg_ty ordOpTbl
581 | cls_key == ordClassKey = check_in arg_ty ordOpTbl
582 | cls_key == showClassKey = check_in arg_ty boxConTbl
583 | cls_key == liftClassKey = check_in arg_ty litConTbl
584 | otherwise = False -- Read, Ix etc
585
586 check_in :: Type -> [(Type,a)] -> Bool
587 check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
588
589
590 cond_isEnumeration :: Condition
591 cond_isEnumeration _ rep_tc
592 | isEnumerationTyCon rep_tc = IsValid
593 | otherwise = NotValid why
594 where
595 why = sep [ quotes (pprSourceTyCon rep_tc) <+>
596 text "must be an enumeration type"
597 , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
598 -- See Note [Enumeration types] in TyCon
599
600 cond_isProduct :: Condition
601 cond_isProduct _ rep_tc
602 | isProductTyCon rep_tc = IsValid
603 | otherwise = NotValid why
604 where
605 why = quotes (pprSourceTyCon rep_tc) <+>
606 text "must have precisely one constructor"
607
608 cond_functorOK :: Bool -> Bool -> Condition
609 -- OK for Functor/Foldable/Traversable class
610 -- Currently: (a) at least one argument
611 -- (b) don't use argument contravariantly
612 -- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
613 -- (d) optionally: don't use function types
614 -- (e) no "stupid context" on data type
615 cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
616 | null tc_tvs
617 = NotValid (text "Data type" <+> quotes (ppr rep_tc)
618 <+> text "must have some type parameters")
619
620 | not (null bad_stupid_theta)
621 = NotValid (text "Data type" <+> quotes (ppr rep_tc)
622 <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
623
624 | otherwise
625 = allValid (map check_con data_cons)
626 where
627 tc_tvs = tyConTyVars rep_tc
628 Just (_, last_tv) = snocView tc_tvs
629 bad_stupid_theta = filter is_bad (tyConStupidTheta rep_tc)
630 is_bad pred = last_tv `elemVarSet` exactTyCoVarsOfType pred
631 -- See Note [Check that the type variable is truly universal]
632
633 data_cons = tyConDataCons rep_tc
634 check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
635
636 check_universal :: DataCon -> Validity
637 check_universal con
638 | allowExQuantifiedLastTyVar
639 = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
640 -- in TcGenFunctor
641 | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
642 , tv `elem` dataConUnivTyVars con
643 , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))
644 = IsValid -- See Note [Check that the type variable is truly universal]
645 | otherwise
646 = NotValid (badCon con existential)
647
648 ft_check :: DataCon -> FFoldType Validity
649 ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
650 , ft_co_var = NotValid (badCon con covariant)
651 , ft_fun = \x y -> if allowFunctions then x `andValid` y
652 else NotValid (badCon con functions)
653 , ft_tup = \_ xs -> allValid xs
654 , ft_ty_app = \_ x -> x
655 , ft_bad_app = NotValid (badCon con wrong_arg)
656 , ft_forall = \_ x -> x }
657
658 existential = text "must be truly polymorphic in the last argument of the data type"
659 covariant = text "must not use the type variable in a function argument"
660 functions = text "must not contain function types"
661 wrong_arg = text "must use the type variable only as the last argument of a data type"
662
663 checkFlag :: LangExt.Extension -> Condition
664 checkFlag flag dflags _
665 | xopt flag dflags = IsValid
666 | otherwise = NotValid why
667 where
668 why = text "You need " <> text flag_str
669 <+> text "to derive an instance for this class"
670 flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of
671 [s] -> s
672 other -> pprPanic "checkFlag" (ppr other)
673
674 std_class_via_coercible :: Class -> Bool
675 -- These standard classes can be derived for a newtype
676 -- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
677 -- because giving so gives the same results as generating the boilerplate
678 std_class_via_coercible clas
679 = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
680 -- Not Read/Show because they respect the type
681 -- Not Enum, because newtypes are never in Enum
682
683
684 non_coercible_class :: Class -> Bool
685 -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
686 -- by Coercible, even with -XGeneralizedNewtypeDeriving
687 -- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
688 -- instance behave differently if there's a non-lawful Applicative out there.
689 -- Besides, with roles, Coercible-deriving Traversable is ill-roled.
690 non_coercible_class cls
691 = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
692 , genClassKey, gen1ClassKey, typeableClassKey
693 , traversableClassKey, liftClassKey ])
694
695 badCon :: DataCon -> SDoc -> SDoc
696 badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
697
698 ------------------------------------------------------------------
699
700 newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
701 newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
702 , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
703 = newClsInst overlap_mode dfun_name tvs theta clas tys
704
705 extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
706 -- Add new locally-defined instances; don't bother to check
707 -- for functional dependency errors -- that'll happen in TcInstDcls
708 extendLocalInstEnv dfuns thing_inside
709 = do { env <- getGblEnv
710 ; let inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
711 env' = env { tcg_inst_env = inst_env' }
712 ; setGblEnv env' thing_inside }
713
714 {-
715 Note [Deriving any class]
716 ~~~~~~~~~~~~~~~~~~~~~~~~~
717 Classic uses of a deriving clause, or a standalone-deriving declaration, are
718 for:
719 * a stock class like Eq or Show, for which GHC knows how to generate
720 the instance code
721 * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
722
723 The DeriveAnyClass extension adds a third way to derive instances, based on
724 empty instance declarations.
725
726 The canonical use case is in combination with GHC.Generics and default method
727 signatures. These allow us to have instance declarations being empty, but still
728 useful, e.g.
729
730 data T a = ...blah..blah... deriving( Generic )
731 instance C a => C (T a) -- No 'where' clause
732
733 where C is some "random" user-defined class.
734
735 This boilerplate code can be replaced by the more compact
736
737 data T a = ...blah..blah... deriving( Generic, C )
738
739 if DeriveAnyClass is enabled.
740
741 This is not restricted to Generics; any class can be derived, simply giving
742 rise to an empty instance.
743
744 Unfortunately, it is not clear how to determine the context (when using a
745 deriving clause; in standalone deriving, the user provides the context).
746 GHC uses the same heuristic for figuring out the class context that it uses for
747 Eq in the case of *-kinded classes, and for Functor in the case of
748 * -> *-kinded classes. That may not be optimal or even wrong. But in such
749 cases, standalone deriving can still be used.
750
751 Note [Check that the type variable is truly universal]
752 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
753 For Functor and Traversable instances, we must check that the *last argument*
754 of the type constructor is used truly universally quantified. Example
755
756 data T a b where
757 T1 :: a -> b -> T a b -- Fine! Vanilla H-98
758 T2 :: b -> c -> T a b -- Fine! Existential c, but we can still map over 'b'
759 T3 :: b -> T Int b -- Fine! Constraint 'a', but 'b' is still polymorphic
760 T4 :: Ord b => b -> T a b -- No! 'b' is constrained
761 T5 :: b -> T b b -- No! 'b' is constrained
762 T6 :: T a (b,b) -- No! 'b' is constrained
763
764 Notice that only the first of these constructors is vanilla H-98. We only
765 need to take care about the last argument (b in this case). See Trac #8678.
766 Eg. for T1-T3 we can write
767
768 fmap f (T1 a b) = T1 a (f b)
769 fmap f (T2 b c) = T2 (f b) c
770 fmap f (T3 x) = T3 (f x)
771
772 We need not perform these checks for Foldable instances, however, since
773 functions in Foldable can only consume existentially quantified type variables,
774 rather than produce them (as is the case in Functor and Traversable functions.)
775 As a result, T can have a derived Foldable instance:
776
777 foldr f z (T1 a b) = f b z
778 foldr f z (T2 b c) = f b z
779 foldr f z (T3 x) = f x z
780 foldr f z (T4 x) = f x z
781 foldr f z (T5 x) = f x z
782 foldr _ z T6 = z
783
784 See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.
785
786 For Functor and Traversable, we must take care not to let type synonyms
787 unfairly reject a type for not being truly universally quantified. An
788 example of this is:
789
790 type C (a :: Constraint) b = a
791 data T a b = C (Show a) b => MkT b
792
793 Here, the existential context (C (Show a) b) does technically mention the last
794 type variable b. But this is OK, because expanding the type synonym C would
795 give us the context (Show a), which doesn't mention b. Therefore, we must make
796 sure to expand type synonyms before performing this check. Not doing so led to
797 Trac #13813.
798 -}