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