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