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