gitlab-ci: Fix URL of Windows cabal-install tarball
[ghc.git] / compiler / typecheck / TcGenGenerics.hs
1 {-
2 (c) The University of Glasgow 2011
3
4
5 The deriving code for the Generic class
6 (equivalent to the code in TcGenDeriv, for other classes)
7 -}
8
9 {-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}
10 {-# LANGUAGE FlexibleContexts #-}
11 {-# LANGUAGE TypeFamilies #-}
12
13 module TcGenGenerics (canDoGenerics, canDoGenerics1,
14 GenericKind(..),
15 gen_Generic_binds, get_gen1_constrained_tys) where
16
17 import GhcPrelude
18
19 import GHC.Hs
20 import Type
21 import TcType
22 import TcGenDeriv
23 import TcGenFunctor
24 import DataCon
25 import TyCon
26 import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
27 import FamInst
28 import Module ( moduleName, moduleNameFS
29 , moduleUnitId, unitIdFS, getModule )
30 import IfaceEnv ( newGlobalBinder )
31 import Name hiding ( varName )
32 import RdrName
33 import BasicTypes
34 import TysPrim
35 import TysWiredIn
36 import PrelNames
37 import TcEnv
38 import TcRnMonad
39 import HscTypes
40 import ErrUtils( Validity(..), andValid )
41 import SrcLoc
42 import Bag
43 import VarEnv
44 import VarSet (elemVarSet)
45 import Outputable
46 import FastString
47 import Util
48
49 import Control.Monad (mplus)
50 import Data.List (zip4, partition)
51 import Data.Maybe (isJust)
52
53 #include "HsVersions.h"
54
55 {-
56 ************************************************************************
57 * *
58 \subsection{Bindings for the new generic deriving mechanism}
59 * *
60 ************************************************************************
61
62 For the generic representation we need to generate:
63 \begin{itemize}
64 \item A Generic instance
65 \item A Rep type instance
66 \item Many auxiliary datatypes and instances for them (for the meta-information)
67 \end{itemize}
68 -}
69
70 gen_Generic_binds :: GenericKind -> TyCon -> [Type]
71 -> TcM (LHsBinds GhcPs, FamInst)
72 gen_Generic_binds gk tc inst_tys = do
73 repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
74 return (mkBindsRep gk tc, repTyInsts)
75
76 {-
77 ************************************************************************
78 * *
79 \subsection{Generating representation types}
80 * *
81 ************************************************************************
82 -}
83
84 get_gen1_constrained_tys :: TyVar -> Type -> [Type]
85 -- called by TcDeriv.inferConstraints; generates a list of types, each of which
86 -- must be a Functor in order for the Generic1 instance to work.
87 get_gen1_constrained_tys argVar
88 = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
89 , ata_par1 = [], ata_rec1 = const []
90 , ata_comp = (:) }
91
92 {-
93
94 Note [Requirements for deriving Generic and Rep]
95 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
96
97 In the following, T, Tfun, and Targ are "meta-variables" ranging over type
98 expressions.
99
100 (Generic T) and (Rep T) are derivable for some type expression T if the
101 following constraints are satisfied.
102
103 (a) D is a type constructor *value*. In other words, D is either a type
104 constructor or it is equivalent to the head of a data family instance (up to
105 alpha-renaming).
106
107 (b) D cannot have a "stupid context".
108
109 (c) The right-hand side of D cannot include existential types, universally
110 quantified types, or "exotic" unlifted types. An exotic unlifted type
111 is one which is not listed in the definition of allowedUnliftedTy
112 (i.e., one for which we have no representation type).
113 See Note [Generics and unlifted types]
114
115 (d) T :: *.
116
117 (Generic1 T) and (Rep1 T) are derivable for some type expression T if the
118 following constraints are satisfied.
119
120 (a),(b),(c) As above.
121
122 (d) T must expect arguments, and its last parameter must have kind *.
123
124 We use `a' to denote the parameter of D that corresponds to the last
125 parameter of T.
126
127 (e) For any type-level application (Tfun Targ) in the right-hand side of D
128 where the head of Tfun is not a tuple constructor:
129
130 (b1) `a' must not occur in Tfun.
131
132 (b2) If `a' occurs in Targ, then Tfun :: * -> *.
133
134 -}
135
136 canDoGenerics :: TyCon -> Validity
137 -- canDoGenerics determines if Generic/Rep can be derived.
138 --
139 -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
140 -- care of because canDoGenerics is applied to rep tycons.
141 --
142 -- It returns IsValid if deriving is possible. It returns (NotValid reason)
143 -- if not.
144 canDoGenerics tc
145 = mergeErrors (
146 -- Check (b) from Note [Requirements for deriving Generic and Rep].
147 (if (not (null (tyConStupidTheta tc)))
148 then (NotValid (tc_name <+> text "must not have a datatype context"))
149 else IsValid)
150 -- See comment below
151 : (map bad_con (tyConDataCons tc)))
152 where
153 -- The tc can be a representation tycon. When we want to display it to the
154 -- user (in an error message) we should print its parent
155 tc_name = ppr $ case tyConFamInst_maybe tc of
156 Just (ptc, _) -> ptc
157 _ -> tc
158
159 -- Check (c) from Note [Requirements for deriving Generic and Rep].
160 --
161 -- If any of the constructors has an exotic unlifted type as argument,
162 -- then we can't build the embedding-projection pair, because
163 -- it relies on instantiating *polymorphic* sum and product types
164 -- at the argument types of the constructors
165 bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
166 then (NotValid (ppr dc <+> text
167 "must not have exotic unlifted or polymorphic arguments"))
168 else (if (not (isVanillaDataCon dc))
169 then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
170 else IsValid)
171
172 -- Nor can we do the job if it's an existential data constructor,
173 -- Nor if the args are polymorphic types (I don't think)
174 bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))
175 || not (isTauTy ty)
176
177 -- Returns True the Type argument is an unlifted type which has a
178 -- corresponding generic representation type. For example,
179 -- (allowedUnliftedTy Int#) would return True since there is the UInt
180 -- representation type.
181 allowedUnliftedTy :: Type -> Bool
182 allowedUnliftedTy = isJust . unboxedRepRDRs
183
184 mergeErrors :: [Validity] -> Validity
185 mergeErrors [] = IsValid
186 mergeErrors (NotValid s:t) = case mergeErrors t of
187 IsValid -> NotValid s
188 NotValid s' -> NotValid (s <> text ", and" $$ s')
189 mergeErrors (IsValid : t) = mergeErrors t
190
191 -- A datatype used only inside of canDoGenerics1. It's the result of analysing
192 -- a type term.
193 data Check_for_CanDoGenerics1 = CCDG1
194 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in
195 -- this type?
196 , _ccdg1_errors :: Validity -- errors generated by this type
197 }
198
199 {-
200
201 Note [degenerate use of FFoldType]
202 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
203
204 We use foldDataConArgs here only for its ability to treat tuples
205 specially. foldDataConArgs also tracks covariance (though it assumes all
206 higher-order type parameters are covariant) and has hooks for special handling
207 of functions and polytypes, but we do *not* use those.
208
209 The key issue is that Generic1 deriving currently offers no sophisticated
210 support for functions. For example, we cannot handle
211
212 data F a = F ((a -> Int) -> Int)
213
214 even though a is occurring covariantly.
215
216 In fact, our rule is harsh: a is simply not allowed to occur within the first
217 argument of (->). We treat (->) the same as any other non-tuple tycon.
218
219 Unfortunately, this means we have to track "the parameter occurs in this type"
220 explicitly, even though foldDataConArgs is also doing this internally.
221
222 -}
223
224 -- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
225 --
226 -- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
227 -- are taken care of by the call to canDoGenerics.
228 --
229 -- It returns IsValid if deriving is possible. It returns (NotValid reason)
230 -- if not.
231 canDoGenerics1 :: TyCon -> Validity
232 canDoGenerics1 rep_tc =
233 canDoGenerics rep_tc `andValid` additionalChecks
234 where
235 additionalChecks
236 -- check (d) from Note [Requirements for deriving Generic and Rep]
237 | null (tyConTyVars rep_tc) = NotValid $
238 text "Data type" <+> quotes (ppr rep_tc)
239 <+> text "must have some type parameters"
240
241 | otherwise = mergeErrors $ concatMap check_con data_cons
242
243 data_cons = tyConDataCons rep_tc
244 check_con con = case check_vanilla con of
245 j@(NotValid {}) -> [j]
246 IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
247
248 bad :: DataCon -> SDoc -> SDoc
249 bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg
250
251 check_vanilla :: DataCon -> Validity
252 check_vanilla con | isVanillaDataCon con = IsValid
253 | otherwise = NotValid (bad con existential)
254
255 bmzero = CCDG1 False IsValid
256 bmbad con s = CCDG1 True $ NotValid $ bad con s
257 bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
258
259 -- check (e) from Note [Requirements for deriving Generic and Rep]
260 -- See also Note [degenerate use of FFoldType]
261 ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
262 ft_check con = FT
263 { ft_triv = bmzero
264
265 , ft_var = caseVar, ft_co_var = caseVar
266
267 -- (component_0,component_1,...,component_n)
268 , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
269 then bmbad con wrong_arg
270 else foldr bmplus bmzero components
271
272 -- (dom -> rng), where the head of ty is not a tuple tycon
273 , ft_fun = \dom rng -> -- cf #8516
274 if _ccdg1_hasParam dom
275 then bmbad con wrong_arg
276 else bmplus dom rng
277
278 -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
279 -- the parameter of interest does not occur in ty
280 , ft_ty_app = \_ arg -> arg
281
282 , ft_bad_app = bmbad con wrong_arg
283 , ft_forall = \_ body -> body -- polytypes are handled elsewhere
284 }
285 where
286 caseVar = CCDG1 True IsValid
287
288
289 existential = text "must not have existential arguments"
290 wrong_arg = text "applies a type to an argument involving the last parameter"
291 $$ text "but the applied type is not of kind * -> *"
292
293 {-
294 ************************************************************************
295 * *
296 \subsection{Generating the RHS of a generic default method}
297 * *
298 ************************************************************************
299 -}
300
301 type US = Int -- Local unique supply, just a plain Int
302 type Alt = (LPat GhcPs, LHsExpr GhcPs)
303
304 -- GenericKind serves to mark if a datatype derives Generic (Gen0) or
305 -- Generic1 (Gen1).
306 data GenericKind = Gen0 | Gen1
307
308 -- as above, but with a payload of the TyCon's name for "the" parameter
309 data GenericKind_ = Gen0_ | Gen1_ TyVar
310
311 -- as above, but using a single datacon's name for "the" parameter
312 data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
313
314 forgetArgVar :: GenericKind_DC -> GenericKind
315 forgetArgVar Gen0_DC = Gen0
316 forgetArgVar Gen1_DC{} = Gen1
317
318 -- When working only within a single datacon, "the" parameter's name should
319 -- match that datacon's name for it.
320 gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
321 gk2gkDC Gen0_ _ = Gen0_DC
322 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
323
324
325 -- Bindings for the Generic instance
326 mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
327 mkBindsRep gk tycon =
328 unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
329 `unionBags`
330 unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
331 where
332 -- The topmost M1 (the datatype metadata) has the exact same type
333 -- across all cases of a from/to definition, and can be factored out
334 -- to save some allocations during typechecking.
335 -- See Note [Generics compilation speed tricks]
336 from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
337 $ nlHsPar $ nlHsCase x_Expr from_matches
338 to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
339
340 from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
341 to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ]
342 loc = srcLocSpan (getSrcLoc tycon)
343 datacons = tyConDataCons tycon
344
345 (from01_RDR, to01_RDR) = case gk of
346 Gen0 -> (from_RDR, to_RDR)
347 Gen1 -> (from1_RDR, to1_RDR)
348
349 -- Recurse over the sum first
350 from_alts, to_alts :: [Alt]
351 (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
352 where gk_ = case gk of
353 Gen0 -> Gen0_
354 Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
355 Gen1_ (last tyvars)
356 where tyvars = tyConTyVars tycon
357
358 --------------------------------------------------------------------------------
359 -- The type synonym instance and synonym
360 -- type instance Rep (D a b) = Rep_D a b
361 -- type Rep_D a b = ...representation type for D ...
362 --------------------------------------------------------------------------------
363
364 tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
365 -> TyCon -- The type to generate representation for
366 -> [Type] -- The type(s) to which Generic(1) is applied
367 -- in the generated instance
368 -> TcM FamInst -- Generated representation0 coercion
369 tc_mkRepFamInsts gk tycon inst_tys =
370 -- Consider the example input tycon `D`, where data D a b = D_ a
371 -- Also consider `R:DInt`, where { data family D x y :: * -> *
372 -- ; data instance D Int a b = D_ a }
373 do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
374 fam_tc <- case gk of
375 Gen0 -> tcLookupTyCon repTyConName
376 Gen1 -> tcLookupTyCon rep1TyConName
377
378 ; fam_envs <- tcGetFamInstEnvs
379
380 ; let -- If the derived instance is
381 -- instance Generic (Foo x)
382 -- then:
383 -- `arg_ki` = *, `inst_ty` = Foo x :: *
384 --
385 -- If the derived instance is
386 -- instance Generic1 (Bar x :: k -> *)
387 -- then:
388 -- `arg_k` = k, `inst_ty` = Bar x :: k -> *
389 (arg_ki, inst_ty) = case (gk, inst_tys) of
390 (Gen0, [inst_t]) -> (liftedTypeKind, inst_t)
391 (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t)
392 _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
393
394 ; let mbFamInst = tyConFamInst_maybe tycon
395 -- If we're examining a data family instance, we grab the parent
396 -- TyCon (ptc) and use it to determine the type arguments
397 -- (inst_args) for the data family *instance*'s type variables.
398 ptc = maybe tycon fst mbFamInst
399 (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd
400 $ tcSplitTyConApp inst_ty
401
402 ; let -- `tyvars` = [a,b]
403 (tyvars, gk_) = case gk of
404 Gen0 -> (all_tyvars, Gen0_)
405 Gen1 -> ASSERT(not $ null all_tyvars)
406 (init all_tyvars, Gen1_ $ last all_tyvars)
407 where all_tyvars = tyConTyVars tycon
408
409 -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
410 ; repTy <- tc_mkRepTy gk_ tycon arg_ki
411
412 -- `rep_name` is a name we generate for the synonym
413 ; mod <- getModule
414 ; loc <- getSrcSpanM
415 ; let tc_occ = nameOccName (tyConName tycon)
416 rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
417 ; rep_name <- newGlobalBinder mod rep_occ loc
418
419 -- We make sure to substitute the tyvars with their user-supplied
420 -- type arguments before generating the Rep/Rep1 instance, since some
421 -- of the tyvars might have been instantiated when deriving.
422 -- See Note [Generating a correctly typed Rep instance].
423 ; let (env_tyvars, env_inst_args)
424 = case gk_ of
425 Gen0_ -> (tyvars, inst_args)
426 Gen1_ last_tv
427 -- See the "wrinkle" in
428 -- Note [Generating a correctly typed Rep instance]
429 -> ( last_tv : tyvars
430 , anyTypeOfKind (tyVarKind last_tv) : inst_args )
431 env = zipTyEnv env_tyvars env_inst_args
432 in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys)
433 subst = mkTvSubst in_scope env
434 repTy' = substTyUnchecked subst repTy
435 tcv' = tyCoVarsOfTypeList inst_ty
436 (tv', cv') = partition isTyVar tcv'
437 tvs' = scopedSort tv'
438 cvs' = scopedSort cv'
439 axiom = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'
440 fam_tc inst_tys repTy'
441
442 ; newFamInst SynFamilyInst axiom }
443
444 --------------------------------------------------------------------------------
445 -- Type representation
446 --------------------------------------------------------------------------------
447
448 -- | See documentation of 'argTyFold'; that function uses the fields of this
449 -- type to interpret the structure of a type when that type is considered as an
450 -- argument to a constructor that is being represented with 'Rep1'.
451 data ArgTyAlg a = ArgTyAlg
452 { ata_rec0 :: (Type -> a)
453 , ata_par1 :: a, ata_rec1 :: (Type -> a)
454 , ata_comp :: (Type -> a -> a)
455 }
456
457 -- | @argTyFold@ implements a generalised and safer variant of the @arg@
458 -- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
459 -- is conceptually equivalent to:
460 --
461 -- > arg t = case t of
462 -- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t
463 -- > App f [t'] |
464 -- > representable1 f &&
465 -- > t' == argVar -> Rec1 f
466 -- > App f [t'] |
467 -- > representable1 f &&
468 -- > t' has tyvars -> f :.: (arg t')
469 -- > _ -> Rec0 t
470 --
471 -- where @argVar@ is the last type variable in the data type declaration we are
472 -- finding the representation for.
473 --
474 -- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
475 -- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
476 -- @:.:@.
477 --
478 -- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
479 -- some data types. The problematic case is when @t@ is an application of a
480 -- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
481 -- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
482 -- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
483 -- representable1 checks have been relaxed, and others were moved to
484 -- @canDoGenerics1@.
485 argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
486 argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
487 ata_par1 = mkPar1, ata_rec1 = mkRec1,
488 ata_comp = mkComp}) =
489 -- mkRec0 is the default; use it if there is no interesting structure
490 -- (e.g. occurrences of parameters or recursive occurrences)
491 \t -> maybe (mkRec0 t) id $ go t where
492 go :: Type -> -- type to fold through
493 Maybe a -- the result (e.g. representation type), unless it's trivial
494 go t = isParam `mplus` isApp where
495
496 isParam = do -- handles parameters
497 t' <- getTyVar_maybe t
498 Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
499 else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
500
501 isApp = do -- handles applications
502 (phi, beta) <- tcSplitAppTy_maybe t
503
504 let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
505
506 -- Does it have no interesting structure to represent?
507 if not interesting then Nothing
508 else -- Is the argument the parameter? Special case for mkRec1.
509 if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
510 else mkComp phi `fmap` go beta -- It must be a composition.
511
512
513 tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
514 GenericKind_
515 -- The type to generate representation for
516 -> TyCon
517 -- The kind of the representation type's argument
518 -- See Note [Handling kinds in a Rep instance]
519 -> Kind
520 -- Generated representation0 type
521 -> TcM Type
522 tc_mkRepTy gk_ tycon k =
523 do
524 d1 <- tcLookupTyCon d1TyConName
525 c1 <- tcLookupTyCon c1TyConName
526 s1 <- tcLookupTyCon s1TyConName
527 rec0 <- tcLookupTyCon rec0TyConName
528 rec1 <- tcLookupTyCon rec1TyConName
529 par1 <- tcLookupTyCon par1TyConName
530 u1 <- tcLookupTyCon u1TyConName
531 v1 <- tcLookupTyCon v1TyConName
532 plus <- tcLookupTyCon sumTyConName
533 times <- tcLookupTyCon prodTyConName
534 comp <- tcLookupTyCon compTyConName
535 uAddr <- tcLookupTyCon uAddrTyConName
536 uChar <- tcLookupTyCon uCharTyConName
537 uDouble <- tcLookupTyCon uDoubleTyConName
538 uFloat <- tcLookupTyCon uFloatTyConName
539 uInt <- tcLookupTyCon uIntTyConName
540 uWord <- tcLookupTyCon uWordTyConName
541
542 let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
543
544 md <- tcLookupPromDataCon metaDataDataConName
545 mc <- tcLookupPromDataCon metaConsDataConName
546 ms <- tcLookupPromDataCon metaSelDataConName
547 pPrefix <- tcLookupPromDataCon prefixIDataConName
548 pInfix <- tcLookupPromDataCon infixIDataConName
549 pLA <- tcLookupPromDataCon leftAssociativeDataConName
550 pRA <- tcLookupPromDataCon rightAssociativeDataConName
551 pNA <- tcLookupPromDataCon notAssociativeDataConName
552 pSUpk <- tcLookupPromDataCon sourceUnpackDataConName
553 pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName
554 pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
555 pSLzy <- tcLookupPromDataCon sourceLazyDataConName
556 pSStr <- tcLookupPromDataCon sourceStrictDataConName
557 pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
558 pDLzy <- tcLookupPromDataCon decidedLazyDataConName
559 pDStr <- tcLookupPromDataCon decidedStrictDataConName
560 pDUpk <- tcLookupPromDataCon decidedUnpackDataConName
561
562 fix_env <- getFixityEnv
563
564 let mkSum' a b = mkTyConApp plus [k,a,b]
565 mkProd a b = mkTyConApp times [k,a,b]
566 mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
567 mkRec1 a = mkTyConApp rec1 [k,a]
568 mkPar1 = mkTyConTy par1
569 mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
570 mkC a = mkTyConApp c1 [ k
571 , metaConsTy a
572 , prod (dataConInstOrigArgTys a
573 . mkTyVarTys . tyConTyVars $ tycon)
574 (dataConSrcBangs a)
575 (dataConImplBangs a)
576 (dataConFieldLabels a)]
577 mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]
578
579 -- Sums and products are done in the same way for both Rep and Rep1
580 sumP [] = mkTyConApp v1 [k]
581 sumP l = foldBal mkSum' . map mkC $ l
582 -- The Bool is True if this constructor has labelled fields
583 prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
584 prod [] _ _ _ = mkTyConApp u1 [k]
585 prod l sb ib fl = foldBal mkProd
586 [ ASSERT(null fl || lengthExceeds fl j)
587 arg t sb' ib' (if null fl
588 then Nothing
589 else Just (fl !! j))
590 | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
591
592 arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
593 arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
594 -- Here we previously used Par0 if t was a type variable, but we
595 -- realized that we can't always guarantee that we are wrapping-up
596 -- all type variables in Par0. So we decided to stop using Par0
597 -- altogether, and use Rec0 all the time.
598 Gen0_ -> mkRec0 t
599 Gen1_ argVar -> argPar argVar t
600 where
601 -- Builds argument representation for Rep1 (more complicated due to
602 -- the presence of composition).
603 argPar argVar = argTyFold argVar $ ArgTyAlg
604 {ata_rec0 = mkRec0, ata_par1 = mkPar1,
605 ata_rec1 = mkRec1, ata_comp = mkComp comp k}
606
607 tyConName_user = case tyConFamInst_maybe tycon of
608 Just (ptycon, _) -> tyConName ptycon
609 Nothing -> tyConName tycon
610
611 dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
612 mdName = mkStrLitTy . moduleNameFS . moduleName
613 . nameModule . tyConName $ tycon
614 pkgName = mkStrLitTy . unitIdFS . moduleUnitId
615 . nameModule . tyConName $ tycon
616 isNT = mkTyConTy $ if isNewTyCon tycon
617 then promotedTrueDataCon
618 else promotedFalseDataCon
619
620 ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
621 ctFix c
622 | dataConIsInfix c
623 = case lookupFixity fix_env (dataConName c) of
624 Fixity _ n InfixL -> buildFix n pLA
625 Fixity _ n InfixR -> buildFix n pRA
626 Fixity _ n InfixN -> buildFix n pNA
627 | otherwise = mkTyConTy pPrefix
628 buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
629 , mkNumLitTy (fromIntegral n)]
630
631 isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
632 then promotedTrueDataCon
633 else promotedFalseDataCon
634
635 selName = mkStrLitTy . flLabel
636
637 mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind]
638 mbSel (Just s) = mkTyConApp promotedJustDataCon
639 [typeSymbolKind, selName s]
640
641 metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT]
642 metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
643 metaSelTy mlbl su ss ib =
644 mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
645 where
646 pSUpkness = mkTyConTy $ case su of
647 SrcUnpack -> pSUpk
648 SrcNoUnpack -> pSNUpk
649 NoSrcUnpack -> pNSUpkness
650
651 pSStrness = mkTyConTy $ case ss of
652 SrcLazy -> pSLzy
653 SrcStrict -> pSStr
654 NoSrcStrict -> pNSStrness
655
656 pDStrness = mkTyConTy $ case ib of
657 HsLazy -> pDLzy
658 HsStrict -> pDStr
659 HsUnpack{} -> pDUpk
660
661 return (mkD tycon)
662
663 mkComp :: TyCon -> Kind -> Type -> Type -> Type
664 mkComp comp k f g
665 | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g]
666 | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g]
667 where
668 -- Which of these is the case?
669 -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
670 -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
671 -- We want to instantiate with k1=k, and k2=*
672 -- Reason for k2=*: see Note [Handling kinds in a Rep instance]
673 -- But we need to know which way round!
674 k1_first = k_first == p_kind_var
675 [k_first,_,_,_,p] = tyConTyVars comp
676 Just p_kind_var = getTyVar_maybe (tyVarKind p)
677
678 -- Given the TyCons for each URec-related type synonym, check to see if the
679 -- given type is an unlifted type that generics understands. If so, return
680 -- its representation type. Otherwise, return Rec0.
681 -- See Note [Generics and unlifted types]
682 mkBoxTy :: TyCon -- UAddr
683 -> TyCon -- UChar
684 -> TyCon -- UDouble
685 -> TyCon -- UFloat
686 -> TyCon -- UInt
687 -> TyCon -- UWord
688 -> TyCon -- Rec0
689 -> Kind -- What to instantiate Rec0's kind variable with
690 -> Type
691 -> Type
692 mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
693 | ty `eqType` addrPrimTy = mkTyConApp uAddr [k]
694 | ty `eqType` charPrimTy = mkTyConApp uChar [k]
695 | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
696 | ty `eqType` floatPrimTy = mkTyConApp uFloat [k]
697 | ty `eqType` intPrimTy = mkTyConApp uInt [k]
698 | ty `eqType` wordPrimTy = mkTyConApp uWord [k]
699 | otherwise = mkTyConApp rec0 [k,ty]
700
701 --------------------------------------------------------------------------------
702 -- Dealing with sums
703 --------------------------------------------------------------------------------
704
705 mkSum :: GenericKind_ -- Generic or Generic1?
706 -> US -- Base for generating unique names
707 -> [DataCon] -- The data constructors
708 -> ([Alt], -- Alternatives for the T->Trep "from" function
709 [Alt]) -- Alternatives for the Trep->T "to" function
710
711 -- Datatype without any constructors
712 mkSum _ _ [] = ([from_alt], [to_alt])
713 where
714 from_alt = (x_Pat, nlHsCase x_Expr [])
715 to_alt = (x_Pat, nlHsCase x_Expr [])
716 -- These M1s are meta-information for the datatype
717
718 -- Datatype with at least one constructor
719 mkSum gk_ us datacons =
720 -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
721 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
722 | (d,i) <- zip datacons [1..] ]
723
724 -- Build the sum for a particular constructor
725 mk1Sum :: GenericKind_DC -- Generic or Generic1?
726 -> US -- Base for generating unique names
727 -> Int -- The index of this constructor
728 -> Int -- Total number of constructors
729 -> DataCon -- The data constructor
730 -> (Alt, -- Alternative for the T->Trep "from" function
731 Alt) -- Alternative for the Trep->T "to" function
732 mk1Sum gk_ us i n datacon = (from_alt, to_alt)
733 where
734 gk = forgetArgVar gk_
735
736 -- Existentials already excluded
737 argTys = dataConOrigArgTys datacon
738 n_args = dataConSourceArity datacon
739
740 datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
741 datacon_vars = map fst datacon_varTys
742 us' = us + n_args
743
744 datacon_rdr = getRdrName datacon
745
746 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
747 from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)
748
749 to_alt = ( genLR_P i n (mkProd_P gk us' datacon_varTys)
750 , to_alt_rhs
751 ) -- These M1s are meta-information for the datatype
752 to_alt_rhs = case gk_ of
753 Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
754 Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
755 where
756 argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
757 converter = argTyFold argVar $ ArgTyAlg
758 {ata_rec0 = nlHsVar . unboxRepRDR,
759 ata_par1 = nlHsVar unPar1_RDR,
760 ata_rec1 = const $ nlHsVar unRec1_RDR,
761 ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
762 `nlHsCompose` nlHsVar unComp1_RDR}
763
764
765 -- Generates the L1/R1 sum pattern
766 genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
767 genLR_P i n p
768 | n == 0 = error "impossible"
769 | n == 1 = p
770 | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
771 | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
772 where m = div n 2
773
774 -- Generates the L1/R1 sum expression
775 genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
776 genLR_E i n e
777 | n == 0 = error "impossible"
778 | n == 1 = e
779 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
780 nlHsPar (genLR_E i (div n 2) e)
781 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp`
782 nlHsPar (genLR_E (i-m) (n-m) e)
783 where m = div n 2
784
785 --------------------------------------------------------------------------------
786 -- Dealing with products
787 --------------------------------------------------------------------------------
788
789 -- Build a product expression
790 mkProd_E :: GenericKind_DC -- Generic or Generic1?
791 -> US -- Base for unique names
792 -> [(RdrName, Type)]
793 -- List of variables matched on the lhs and their types
794 -> LHsExpr GhcPs -- Resulting product expression
795 mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
796 mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
797 -- These M1s are meta-information for the constructor
798 where
799 appVars = map (wrapArg_E gk_) varTys
800 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
801
802 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
803 wrapArg_E Gen0_DC (var, ty) = mkM1_E $
804 boxRepRDR ty `nlHsVarApps` [var]
805 -- This M1 is meta-information for the selector
806 wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
807 converter ty `nlHsApp` nlHsVar var
808 -- This M1 is meta-information for the selector
809 where converter = argTyFold argVar $ ArgTyAlg
810 {ata_rec0 = nlHsVar . boxRepRDR,
811 ata_par1 = nlHsVar par1DataCon_RDR,
812 ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
813 ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
814 (nlHsVar fmap_RDR `nlHsApp` cnv)}
815
816 boxRepRDR :: Type -> RdrName
817 boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
818
819 unboxRepRDR :: Type -> RdrName
820 unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
821
822 -- Retrieve the RDRs associated with each URec data family instance
823 -- constructor. See Note [Generics and unlifted types]
824 unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
825 unboxedRepRDRs ty
826 | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR)
827 | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR)
828 | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
829 | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR)
830 | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR)
831 | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR)
832 | otherwise = Nothing
833
834 -- Build a product pattern
835 mkProd_P :: GenericKind -- Gen0 or Gen1
836 -> US -- Base for unique names
837 -> [(RdrName, Type)] -- List of variables to match,
838 -- along with their types
839 -> LPat GhcPs -- Resulting product pattern
840 mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
841 mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
842 -- These M1s are meta-information for the constructor
843 where
844 appVars = unzipWith (wrapArg_P gk) varTys
845 prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
846
847 wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
848 wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
849 -- This M1 is meta-information for the selector
850 wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
851
852 mkGenericLocal :: US -> RdrName
853 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
854
855 x_RDR :: RdrName
856 x_RDR = mkVarUnqual (fsLit "x")
857
858 x_Expr :: LHsExpr GhcPs
859 x_Expr = nlHsVar x_RDR
860
861 x_Pat :: LPat GhcPs
862 x_Pat = nlVarPat x_RDR
863
864 mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
865 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
866
867 mkM1_P :: LPat GhcPs -> LPat GhcPs
868 mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
869
870 nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
871 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
872
873 -- | Variant of foldr1 for producing balanced lists
874 foldBal :: (a -> a -> a) -> [a] -> a
875 foldBal op = foldBal' op (error "foldBal: empty list")
876
877 foldBal' :: (a -> a -> a) -> a -> [a] -> a
878 foldBal' _ x [] = x
879 foldBal' _ _ [y] = y
880 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
881 in foldBal' op x a `op` foldBal' op x b
882
883 {-
884 Note [Generics and unlifted types]
885 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
886 Normally, all constants are marked with K1/Rec0. The exception to this rule is
887 when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
888 that case, we must use a data family instance of URec (from GHC.Generics) to
889 mark it. As a result, before we can generate K1 or unK1, we must first check
890 to see if the type is actually one of the unlifted types for which URec has a
891 data family instance; if so, we generate that instead.
892
893 See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more
894 details on why URec is implemented the way it is.
895
896 Note [Generating a correctly typed Rep instance]
897 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
898 tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
899 Generic(1). That is, it derives the ellipsis in the following:
900
901 instance Generic Foo where
902 type Rep Foo = ...
903
904 However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
905 a Generic(1) instance is being derived, not the fully instantiated type. As a
906 result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
907 the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
908 can cause problems when the instance has instantiated type variables
909 (see #11732). As an example:
910
911 data T a = MkT a
912 deriving instance Generic (T Int)
913 ==>
914 instance Generic (T Int) where
915 type Rep (T Int) = (... (Rec0 a)) -- wrong!
916
917 -XStandaloneDeriving is one way for the type variables to become instantiated.
918 Another way is when Generic1 is being derived for a datatype with a visible
919 kind binder, e.g.,
920
921 data P k (a :: k) = MkP k deriving Generic1
922 ==>
923 instance Generic1 (P *) where
924 type Rep1 (P *) = (... (Rec0 k)) -- wrong!
925
926 See Note [Unify kinds in deriving] in TcDeriv.
927
928 In any such scenario, we must prevent a discrepancy between the LHS and RHS of
929 a Rep(1) instance. To do so, we create a type variable substitution that maps
930 the tyConTyVars of the TyCon to their counterparts in the fully instantiated
931 type. (For example, using T above as example, you'd map a :-> Int.) We then
932 apply the substitution to the RHS before generating the instance.
933
934 A wrinkle in all of this: when forming the type variable substitution for
935 Generic1 instances, we map the last type variable of the tycon to Any. Why?
936 It's because of wily data types like this one (#15012):
937
938 data T a = MkT (FakeOut a)
939 type FakeOut a = Int
940
941 If we ignore a, then we'll produce the following Rep1 instance:
942
943 instance Generic1 T where
944 type Rep1 T = ... (Rec0 (FakeOut a))
945 ...
946
947 Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we
948 ensure that `a` is mapped to Any:
949
950 instance Generic1 T where
951 type Rep1 T = ... (Rec0 (FakeOut Any))
952 ...
953
954 And now all is good.
955
956 Alternatively, we could have avoided this problem by expanding all type
957 synonyms on the RHSes of Rep1 instances. But we might blow up the size of
958 these types even further by doing this, so we choose not to do so.
959
960 Note [Handling kinds in a Rep instance]
961 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
962 Because Generic1 is poly-kinded, the representation types were generalized to
963 be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
964 the kind of the instance being derived to all the representation type
965 constructors. For instance, if you have
966
967 data Empty (a :: k) = Empty deriving Generic1
968
969 Then the generated code is now approximately (with -fprint-explicit-kinds
970 syntax):
971
972 instance Generic1 k (Empty k) where
973 type Rep1 k (Empty k) = U1 k
974
975 Most representation types have only one kind variable, making them easy to deal
976 with. The only non-trivial case is (:.:), which is only used in Generic1
977 instances:
978
979 newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
980 Comp1 { unComp1 :: f (g p) }
981
982 Here, we do something a bit counter-intuitive: we make k1 be the kind of the
983 instance being derived, and we always make k2 be *. Why *? It's because
984 the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
985 for some types x and y. In other words, the second type to which (:.:) is
986 applied always has kind k -> *, for some kind k, so k2 cannot possibly be
987 anything other than * in a generated Generic1 instance.
988
989 Note [Generics compilation speed tricks]
990 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
991 Deriving Generic(1) is known to have a large constant factor during
992 compilation, which contributes to noticeable compilation slowdowns when
993 deriving Generic(1) for large datatypes (see #5642).
994
995 To ease the pain, there is a trick one can play when generating definitions for
996 to(1) and from(1). If you have a datatype like:
997
998 data Letter = A | B | C | D
999
1000 then a naïve Generic instance for Letter would be:
1001
1002 instance Generic Letter where
1003 type Rep Letter = D1 ('MetaData ...) ...
1004
1005 to (M1 (L1 (L1 (M1 U1)))) = A
1006 to (M1 (L1 (R1 (M1 U1)))) = B
1007 to (M1 (R1 (L1 (M1 U1)))) = C
1008 to (M1 (R1 (R1 (M1 U1)))) = D
1009
1010 from A = M1 (L1 (L1 (M1 U1)))
1011 from B = M1 (L1 (R1 (M1 U1)))
1012 from C = M1 (R1 (L1 (M1 U1)))
1013 from D = M1 (R1 (R1 (M1 U1)))
1014
1015 Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
1016 expression in the 'from' definition, the topmost constructor is M1. This
1017 corresponds to the datatype-specific metadata (the D1 in the Rep Letter
1018 instance). But this is wasteful from a typechecking perspective, since this
1019 definition requires GHC to typecheck an application of M1 in every single case,
1020 leading to an O(n) increase in the number of coercions the typechecker has to
1021 solve, which in turn increases allocations and degrades compilation speed.
1022
1023 Luckily, since the topmost M1 has the exact same type across every case, we can
1024 factor it out reduce the typechecker's burden:
1025
1026 instance Generic Letter where
1027 type Rep Letter = D1 ('MetaData ...) ...
1028
1029 to (M1 x) = case x of
1030 L1 (L1 (M1 U1)) -> A
1031 L1 (R1 (M1 U1)) -> B
1032 R1 (L1 (M1 U1)) -> C
1033 R1 (R1 (M1 U1)) -> D
1034
1035 from x = M1 (case x of
1036 A -> L1 (L1 (M1 U1))
1037 B -> L1 (R1 (M1 U1))
1038 C -> R1 (L1 (M1 U1))
1039 D -> R1 (R1 (M1 U1)))
1040
1041 A simple change, but one that pays off, since it goes turns an O(n) amount of
1042 coercions to an O(1) amount.
1043 -}