Use lengthIs and friends in more places
[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
334 $ nlHsPar $ nlHsCase x_Expr from_matches
335 to_eqn = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
336
337 from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
338 to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ]
339 loc = srcLocSpan (getSrcLoc tycon)
340 datacons = tyConDataCons tycon
341
342 (from01_RDR, to01_RDR) = case gk of
343 Gen0 -> (from_RDR, to_RDR)
344 Gen1 -> (from1_RDR, to1_RDR)
345
346 -- Recurse over the sum first
347 from_alts, to_alts :: [Alt]
348 (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
349 where gk_ = case gk of
350 Gen0 -> Gen0_
351 Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
352 Gen1_ (last tyvars)
353 where tyvars = tyConTyVars tycon
354
355 --------------------------------------------------------------------------------
356 -- The type synonym instance and synonym
357 -- type instance Rep (D a b) = Rep_D a b
358 -- type Rep_D a b = ...representation type for D ...
359 --------------------------------------------------------------------------------
360
361 tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
362 -> TyCon -- The type to generate representation for
363 -> [Type] -- The type(s) to which Generic(1) is applied
364 -- in the generated instance
365 -> TcM FamInst -- Generated representation0 coercion
366 tc_mkRepFamInsts gk tycon inst_tys =
367 -- Consider the example input tycon `D`, where data D a b = D_ a
368 -- Also consider `R:DInt`, where { data family D x y :: * -> *
369 -- ; data instance D Int a b = D_ a }
370 do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
371 fam_tc <- case gk of
372 Gen0 -> tcLookupTyCon repTyConName
373 Gen1 -> tcLookupTyCon rep1TyConName
374
375 ; fam_envs <- tcGetFamInstEnvs
376
377 ; let -- If the derived instance is
378 -- instance Generic (Foo x)
379 -- then:
380 -- `arg_ki` = *, `inst_ty` = Foo x :: *
381 --
382 -- If the derived instance is
383 -- instance Generic1 (Bar x :: k -> *)
384 -- then:
385 -- `arg_k` = k, `inst_ty` = Bar x :: k -> *
386 (arg_ki, inst_ty) = case (gk, inst_tys) of
387 (Gen0, [inst_t]) -> (liftedTypeKind, inst_t)
388 (Gen1, [arg_k, inst_t]) -> (arg_k, inst_t)
389 _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
390
391 ; let mbFamInst = tyConFamInst_maybe tycon
392 -- If we're examining a data family instance, we grab the parent
393 -- TyCon (ptc) and use it to determine the type arguments
394 -- (inst_args) for the data family *instance*'s type variables.
395 ptc = maybe tycon fst mbFamInst
396 (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd
397 $ tcSplitTyConApp inst_ty
398
399 ; let -- `tyvars` = [a,b]
400 (tyvars, gk_) = case gk of
401 Gen0 -> (all_tyvars, Gen0_)
402 Gen1 -> ASSERT(not $ null all_tyvars)
403 (init all_tyvars, Gen1_ $ last all_tyvars)
404 where all_tyvars = tyConTyVars tycon
405
406 -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
407 ; repTy <- tc_mkRepTy gk_ tycon arg_ki
408
409 -- `rep_name` is a name we generate for the synonym
410 ; mod <- getModule
411 ; loc <- getSrcSpanM
412 ; let tc_occ = nameOccName (tyConName tycon)
413 rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
414 ; rep_name <- newGlobalBinder mod rep_occ loc
415
416 -- We make sure to substitute the tyvars with their user-supplied
417 -- type arguments before generating the Rep/Rep1 instance, since some
418 -- of the tyvars might have been instantiated when deriving.
419 -- See Note [Generating a correctly typed Rep instance].
420 ; let env = zipTyEnv tyvars inst_args
421 in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys)
422 subst = mkTvSubst in_scope env
423 repTy' = substTy subst repTy
424 tcv' = tyCoVarsOfTypeList inst_ty
425 (tv', cv') = partition isTyVar tcv'
426 tvs' = toposortTyVars tv'
427 cvs' = toposortTyVars cv'
428 axiom = mkSingleCoAxiom Nominal rep_name tvs' cvs'
429 fam_tc inst_tys repTy'
430
431 ; newFamInst SynFamilyInst axiom }
432
433 --------------------------------------------------------------------------------
434 -- Type representation
435 --------------------------------------------------------------------------------
436
437 -- | See documentation of 'argTyFold'; that function uses the fields of this
438 -- type to interpret the structure of a type when that type is considered as an
439 -- argument to a constructor that is being represented with 'Rep1'.
440 data ArgTyAlg a = ArgTyAlg
441 { ata_rec0 :: (Type -> a)
442 , ata_par1 :: a, ata_rec1 :: (Type -> a)
443 , ata_comp :: (Type -> a -> a)
444 }
445
446 -- | @argTyFold@ implements a generalised and safer variant of the @arg@
447 -- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
448 -- is conceptually equivalent to:
449 --
450 -- > arg t = case t of
451 -- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t
452 -- > App f [t'] |
453 -- > representable1 f &&
454 -- > t' == argVar -> Rec1 f
455 -- > App f [t'] |
456 -- > representable1 f &&
457 -- > t' has tyvars -> f :.: (arg t')
458 -- > _ -> Rec0 t
459 --
460 -- where @argVar@ is the last type variable in the data type declaration we are
461 -- finding the representation for.
462 --
463 -- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
464 -- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
465 -- @:.:@.
466 --
467 -- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
468 -- some data types. The problematic case is when @t@ is an application of a
469 -- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
470 -- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
471 -- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
472 -- representable1 checks have been relaxed, and others were moved to
473 -- @canDoGenerics1@.
474 argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
475 argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
476 ata_par1 = mkPar1, ata_rec1 = mkRec1,
477 ata_comp = mkComp}) =
478 -- mkRec0 is the default; use it if there is no interesting structure
479 -- (e.g. occurrences of parameters or recursive occurrences)
480 \t -> maybe (mkRec0 t) id $ go t where
481 go :: Type -> -- type to fold through
482 Maybe a -- the result (e.g. representation type), unless it's trivial
483 go t = isParam `mplus` isApp where
484
485 isParam = do -- handles parameters
486 t' <- getTyVar_maybe t
487 Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
488 else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
489
490 isApp = do -- handles applications
491 (phi, beta) <- tcSplitAppTy_maybe t
492
493 let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
494
495 -- Does it have no interesting structure to represent?
496 if not interesting then Nothing
497 else -- Is the argument the parameter? Special case for mkRec1.
498 if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
499 else mkComp phi `fmap` go beta -- It must be a composition.
500
501
502 tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
503 GenericKind_
504 -- The type to generate representation for
505 -> TyCon
506 -- The kind of the representation type's argument
507 -- See Note [Handling kinds in a Rep instance]
508 -> Kind
509 -- Generated representation0 type
510 -> TcM Type
511 tc_mkRepTy gk_ tycon k =
512 do
513 d1 <- tcLookupTyCon d1TyConName
514 c1 <- tcLookupTyCon c1TyConName
515 s1 <- tcLookupTyCon s1TyConName
516 rec0 <- tcLookupTyCon rec0TyConName
517 rec1 <- tcLookupTyCon rec1TyConName
518 par1 <- tcLookupTyCon par1TyConName
519 u1 <- tcLookupTyCon u1TyConName
520 v1 <- tcLookupTyCon v1TyConName
521 plus <- tcLookupTyCon sumTyConName
522 times <- tcLookupTyCon prodTyConName
523 comp <- tcLookupTyCon compTyConName
524 uAddr <- tcLookupTyCon uAddrTyConName
525 uChar <- tcLookupTyCon uCharTyConName
526 uDouble <- tcLookupTyCon uDoubleTyConName
527 uFloat <- tcLookupTyCon uFloatTyConName
528 uInt <- tcLookupTyCon uIntTyConName
529 uWord <- tcLookupTyCon uWordTyConName
530
531 let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
532
533 md <- tcLookupPromDataCon metaDataDataConName
534 mc <- tcLookupPromDataCon metaConsDataConName
535 ms <- tcLookupPromDataCon metaSelDataConName
536 pPrefix <- tcLookupPromDataCon prefixIDataConName
537 pInfix <- tcLookupPromDataCon infixIDataConName
538 pLA <- tcLookupPromDataCon leftAssociativeDataConName
539 pRA <- tcLookupPromDataCon rightAssociativeDataConName
540 pNA <- tcLookupPromDataCon notAssociativeDataConName
541 pSUpk <- tcLookupPromDataCon sourceUnpackDataConName
542 pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName
543 pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
544 pSLzy <- tcLookupPromDataCon sourceLazyDataConName
545 pSStr <- tcLookupPromDataCon sourceStrictDataConName
546 pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
547 pDLzy <- tcLookupPromDataCon decidedLazyDataConName
548 pDStr <- tcLookupPromDataCon decidedStrictDataConName
549 pDUpk <- tcLookupPromDataCon decidedUnpackDataConName
550
551 fix_env <- getFixityEnv
552
553 let mkSum' a b = mkTyConApp plus [k,a,b]
554 mkProd a b = mkTyConApp times [k,a,b]
555 mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
556 mkRec1 a = mkTyConApp rec1 [k,a]
557 mkPar1 = mkTyConTy par1
558 mkD a = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
559 mkC a = mkTyConApp c1 [ k
560 , metaConsTy a
561 , prod (dataConInstOrigArgTys a
562 . mkTyVarTys . tyConTyVars $ tycon)
563 (dataConSrcBangs a)
564 (dataConImplBangs a)
565 (dataConFieldLabels a)]
566 mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]
567
568 -- Sums and products are done in the same way for both Rep and Rep1
569 sumP [] = mkTyConApp v1 [k]
570 sumP l = foldBal mkSum' . map mkC $ l
571 -- The Bool is True if this constructor has labelled fields
572 prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
573 prod [] _ _ _ = mkTyConApp u1 [k]
574 prod l sb ib fl = foldBal mkProd
575 [ ASSERT(null fl || lengthExceeds fl j)
576 arg t sb' ib' (if null fl
577 then Nothing
578 else Just (fl !! j))
579 | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
580
581 arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
582 arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
583 -- Here we previously used Par0 if t was a type variable, but we
584 -- realized that we can't always guarantee that we are wrapping-up
585 -- all type variables in Par0. So we decided to stop using Par0
586 -- altogether, and use Rec0 all the time.
587 Gen0_ -> mkRec0 t
588 Gen1_ argVar -> argPar argVar t
589 where
590 -- Builds argument representation for Rep1 (more complicated due to
591 -- the presence of composition).
592 argPar argVar = argTyFold argVar $ ArgTyAlg
593 {ata_rec0 = mkRec0, ata_par1 = mkPar1,
594 ata_rec1 = mkRec1, ata_comp = mkComp comp k}
595
596 tyConName_user = case tyConFamInst_maybe tycon of
597 Just (ptycon, _) -> tyConName ptycon
598 Nothing -> tyConName tycon
599
600 dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
601 mdName = mkStrLitTy . moduleNameFS . moduleName
602 . nameModule . tyConName $ tycon
603 pkgName = mkStrLitTy . unitIdFS . moduleUnitId
604 . nameModule . tyConName $ tycon
605 isNT = mkTyConTy $ if isNewTyCon tycon
606 then promotedTrueDataCon
607 else promotedFalseDataCon
608
609 ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
610 ctFix c
611 | dataConIsInfix c
612 = case lookupFixity fix_env (dataConName c) of
613 Fixity _ n InfixL -> buildFix n pLA
614 Fixity _ n InfixR -> buildFix n pRA
615 Fixity _ n InfixN -> buildFix n pNA
616 | otherwise = mkTyConTy pPrefix
617 buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
618 , mkNumLitTy (fromIntegral n)]
619
620 isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
621 then promotedTrueDataCon
622 else promotedFalseDataCon
623
624 selName = mkStrLitTy . flLabel
625
626 mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind]
627 mbSel (Just s) = mkTyConApp promotedJustDataCon
628 [typeSymbolKind, selName s]
629
630 metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT]
631 metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
632 metaSelTy mlbl su ss ib =
633 mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
634 where
635 pSUpkness = mkTyConTy $ case su of
636 SrcUnpack -> pSUpk
637 SrcNoUnpack -> pSNUpk
638 NoSrcUnpack -> pNSUpkness
639
640 pSStrness = mkTyConTy $ case ss of
641 SrcLazy -> pSLzy
642 SrcStrict -> pSStr
643 NoSrcStrict -> pNSStrness
644
645 pDStrness = mkTyConTy $ case ib of
646 HsLazy -> pDLzy
647 HsStrict -> pDStr
648 HsUnpack{} -> pDUpk
649
650 return (mkD tycon)
651
652 mkComp :: TyCon -> Kind -> Type -> Type -> Type
653 mkComp comp k f g
654 | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g]
655 | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g]
656 where
657 -- Which of these is the case?
658 -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
659 -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
660 -- We want to instantiate with k1=k, and k2=*
661 -- Reason for k2=*: see Note [Handling kinds in a Rep instance]
662 -- But we need to know which way round!
663 k1_first = k_first == p_kind_var
664 [k_first,_,_,_,p] = tyConTyVars comp
665 Just p_kind_var = getTyVar_maybe (tyVarKind p)
666
667 -- Given the TyCons for each URec-related type synonym, check to see if the
668 -- given type is an unlifted type that generics understands. If so, return
669 -- its representation type. Otherwise, return Rec0.
670 -- See Note [Generics and unlifted types]
671 mkBoxTy :: TyCon -- UAddr
672 -> TyCon -- UChar
673 -> TyCon -- UDouble
674 -> TyCon -- UFloat
675 -> TyCon -- UInt
676 -> TyCon -- UWord
677 -> TyCon -- Rec0
678 -> Kind -- What to instantiate Rec0's kind variable with
679 -> Type
680 -> Type
681 mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
682 | ty `eqType` addrPrimTy = mkTyConApp uAddr [k]
683 | ty `eqType` charPrimTy = mkTyConApp uChar [k]
684 | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
685 | ty `eqType` floatPrimTy = mkTyConApp uFloat [k]
686 | ty `eqType` intPrimTy = mkTyConApp uInt [k]
687 | ty `eqType` wordPrimTy = mkTyConApp uWord [k]
688 | otherwise = mkTyConApp rec0 [k,ty]
689
690 --------------------------------------------------------------------------------
691 -- Dealing with sums
692 --------------------------------------------------------------------------------
693
694 mkSum :: GenericKind_ -- Generic or Generic1?
695 -> US -- Base for generating unique names
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 _ _ [] = ([from_alt], [to_alt])
702 where
703 from_alt = (x_Pat, nlHsCase x_Expr [])
704 to_alt = (x_Pat, nlHsCase x_Expr [])
705 -- These M1s are meta-information for the datatype
706
707 -- Datatype with at least one constructor
708 mkSum gk_ us datacons =
709 -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
710 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
711 | (d,i) <- zip datacons [1..] ]
712
713 -- Build the sum for a particular constructor
714 mk1Sum :: GenericKind_DC -- Generic or Generic1?
715 -> US -- Base for generating unique names
716 -> Int -- The index of this constructor
717 -> Int -- Total number of constructors
718 -> DataCon -- The data constructor
719 -> (Alt, -- Alternative for the T->Trep "from" function
720 Alt) -- Alternative for the Trep->T "to" function
721 mk1Sum gk_ us i n datacon = (from_alt, to_alt)
722 where
723 gk = forgetArgVar gk_
724
725 -- Existentials already excluded
726 argTys = dataConOrigArgTys datacon
727 n_args = dataConSourceArity datacon
728
729 datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
730 datacon_vars = map fst datacon_varTys
731 us' = us + n_args
732
733 datacon_rdr = getRdrName datacon
734
735 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
736 from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)
737
738 to_alt = ( genLR_P i n (mkProd_P gk us' datacon_varTys)
739 , to_alt_rhs
740 ) -- These M1s are meta-information for the datatype
741 to_alt_rhs = case gk_ of
742 Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
743 Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
744 where
745 argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
746 converter = argTyFold argVar $ ArgTyAlg
747 {ata_rec0 = nlHsVar . unboxRepRDR,
748 ata_par1 = nlHsVar unPar1_RDR,
749 ata_rec1 = const $ nlHsVar unRec1_RDR,
750 ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
751 `nlHsCompose` nlHsVar unComp1_RDR}
752
753
754 -- Generates the L1/R1 sum pattern
755 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
756 genLR_P i n p
757 | n == 0 = error "impossible"
758 | n == 1 = p
759 | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
760 | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
761 where m = div n 2
762
763 -- Generates the L1/R1 sum expression
764 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
765 genLR_E i n e
766 | n == 0 = error "impossible"
767 | n == 1 = e
768 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
769 nlHsPar (genLR_E i (div n 2) e)
770 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp`
771 nlHsPar (genLR_E (i-m) (n-m) e)
772 where m = div n 2
773
774 --------------------------------------------------------------------------------
775 -- Dealing with products
776 --------------------------------------------------------------------------------
777
778 -- Build a product expression
779 mkProd_E :: GenericKind_DC -- Generic or Generic1?
780 -> US -- Base for unique names
781 -> [(RdrName, Type)] -- List of variables matched on the lhs and their types
782 -> LHsExpr RdrName -- Resulting product expression
783 mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
784 mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
785 -- These M1s are meta-information for the constructor
786 where
787 appVars = map (wrapArg_E gk_) varTys
788 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
789
790 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
791 wrapArg_E Gen0_DC (var, ty) = mkM1_E $
792 boxRepRDR ty `nlHsVarApps` [var]
793 -- This M1 is meta-information for the selector
794 wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
795 converter ty `nlHsApp` nlHsVar var
796 -- This M1 is meta-information for the selector
797 where converter = argTyFold argVar $ ArgTyAlg
798 {ata_rec0 = nlHsVar . boxRepRDR,
799 ata_par1 = nlHsVar par1DataCon_RDR,
800 ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
801 ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
802 (nlHsVar fmap_RDR `nlHsApp` cnv)}
803
804 boxRepRDR :: Type -> RdrName
805 boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
806
807 unboxRepRDR :: Type -> RdrName
808 unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
809
810 -- Retrieve the RDRs associated with each URec data family instance
811 -- constructor. See Note [Generics and unlifted types]
812 unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
813 unboxedRepRDRs ty
814 | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR)
815 | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR)
816 | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
817 | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR)
818 | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR)
819 | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR)
820 | otherwise = Nothing
821
822 -- Build a product pattern
823 mkProd_P :: GenericKind -- Gen0 or Gen1
824 -> US -- Base for unique names
825 -> [(RdrName, Type)] -- List of variables to match,
826 -- along with their types
827 -> LPat RdrName -- Resulting product pattern
828 mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
829 mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
830 -- These M1s are meta-information for the constructor
831 where
832 appVars = unzipWith (wrapArg_P gk) varTys
833 prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
834
835 wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
836 wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
837 -- This M1 is meta-information for the selector
838 wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
839
840 mkGenericLocal :: US -> RdrName
841 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
842
843 x_RDR :: RdrName
844 x_RDR = mkVarUnqual (fsLit "x")
845
846 x_Expr :: LHsExpr RdrName
847 x_Expr = nlHsVar x_RDR
848
849 x_Pat :: LPat RdrName
850 x_Pat = nlVarPat x_RDR
851
852 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
853 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
854
855 mkM1_P :: LPat RdrName -> LPat RdrName
856 mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
857
858 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
859 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
860
861 -- | Variant of foldr1 for producing balanced lists
862 foldBal :: (a -> a -> a) -> [a] -> a
863 foldBal op = foldBal' op (error "foldBal: empty list")
864
865 foldBal' :: (a -> a -> a) -> a -> [a] -> a
866 foldBal' _ x [] = x
867 foldBal' _ _ [y] = y
868 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
869 in foldBal' op x a `op` foldBal' op x b
870
871 {-
872 Note [Generics and unlifted types]
873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
874 Normally, all constants are marked with K1/Rec0. The exception to this rule is
875 when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
876 that case, we must use a data family instance of URec (from GHC.Generics) to
877 mark it. As a result, before we can generate K1 or unK1, we must first check
878 to see if the type is actually one of the unlifted types for which URec has a
879 data family instance; if so, we generate that instead.
880
881 See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
882 details on why URec is implemented the way it is.
883
884 Note [Generating a correctly typed Rep instance]
885 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
886 tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
887 Generic(1). That is, it derives the ellipsis in the following:
888
889 instance Generic Foo where
890 type Rep Foo = ...
891
892 However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
893 a Generic(1) instance is being derived, not the fully instantiated type. As a
894 result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
895 the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
896 can cause problems when the instance has instantiated type variables
897 (see Trac #11732). As an example:
898
899 data T a = MkT a
900 deriving instance Generic (T Int)
901 ==>
902 instance Generic (T Int) where
903 type Rep (T Int) = (... (Rec0 a)) -- wrong!
904
905 -XStandaloneDeriving is one way for the type variables to become instantiated.
906 Another way is when Generic1 is being derived for a datatype with a visible
907 kind binder, e.g.,
908
909 data P k (a :: k) = MkP k deriving Generic1
910 ==>
911 instance Generic1 (P *) where
912 type Rep1 (P *) = (... (Rec0 k)) -- wrong!
913
914 See Note [Unify kinds in deriving] in TcDeriv.
915
916 In any such scenario, we must prevent a discrepancy between the LHS and RHS of
917 a Rep(1) instance. To do so, we create a type variable substitution that maps
918 the tyConTyVars of the TyCon to their counterparts in the fully instantiated
919 type. (For example, using T above as example, you'd map a :-> Int.) We then
920 apply the substitution to the RHS before generating the instance.
921
922 Note [Handling kinds in a Rep instance]
923 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
924 Because Generic1 is poly-kinded, the representation types were generalized to
925 be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
926 the kind of the instance being derived to all the representation type
927 constructors. For instance, if you have
928
929 data Empty (a :: k) = Empty deriving Generic1
930
931 Then the generated code is now approximately (with -fprint-explicit-kinds
932 syntax):
933
934 instance Generic1 k (Empty k) where
935 type Rep1 k (Empty k) = U1 k
936
937 Most representation types have only one kind variable, making them easy to deal
938 with. The only non-trivial case is (:.:), which is only used in Generic1
939 instances:
940
941 newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
942 Comp1 { unComp1 :: f (g p) }
943
944 Here, we do something a bit counter-intuitive: we make k1 be the kind of the
945 instance being derived, and we always make k2 be *. Why *? It's because
946 the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
947 for some types x and y. In other words, the second type to which (:.:) is
948 applied always has kind k -> *, for some kind k, so k2 cannot possibly be
949 anything other than * in a generated Generic1 instance.
950
951 Note [Generics compilation speed tricks]
952 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
953 Deriving Generic(1) is known to have a large constant factor during
954 compilation, which contributes to noticeable compilation slowdowns when
955 deriving Generic(1) for large datatypes (see Trac #5642).
956
957 To ease the pain, there is a trick one can play when generating definitions for
958 to(1) and from(1). If you have a datatype like:
959
960 data Letter = A | B | C | D
961
962 then a naïve Generic instance for Letter would be:
963
964 instance Generic Letter where
965 type Rep Letter = D1 ('MetaData ...) ...
966
967 to (M1 (L1 (L1 (M1 U1)))) = A
968 to (M1 (L1 (R1 (M1 U1)))) = B
969 to (M1 (R1 (L1 (M1 U1)))) = C
970 to (M1 (R1 (R1 (M1 U1)))) = D
971
972 from A = M1 (L1 (L1 (M1 U1)))
973 from B = M1 (L1 (R1 (M1 U1)))
974 from C = M1 (R1 (L1 (M1 U1)))
975 from D = M1 (R1 (R1 (M1 U1)))
976
977 Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
978 expression in the 'from' definition, the topmost constructor is M1. This
979 corresponds to the datatype-specific metadata (the D1 in the Rep Letter
980 instance). But this is wasteful from a typechecking perspective, since this
981 definition requires GHC to typecheck an application of M1 in every single case,
982 leading to an O(n) increase in the number of coercions the typechecker has to
983 solve, which in turn increases allocations and degrades compilation speed.
984
985 Luckily, since the topmost M1 has the exact same type across every case, we can
986 factor it out reduce the typechecker's burden:
987
988 instance Generic Letter where
989 type Rep Letter = D1 ('MetaData ...) ...
990
991 to (M1 x) = case x of
992 L1 (L1 (M1 U1)) -> A
993 L1 (R1 (M1 U1)) -> B
994 R1 (L1 (M1 U1)) -> C
995 R1 (R1 (M1 U1)) -> D
996
997 from x = M1 (case x of
998 A -> L1 (L1 (M1 U1))
999 B -> L1 (R1 (M1 U1))
1000 C -> R1 (L1 (M1 U1))
1001 D -> R1 (R1 (M1 U1)))
1002
1003 A simple change, but one that pays off, since it goes turns an O(n) amount of
1004 coercions to an O(1) amount.
1005 -}