Clarify Note [Kind coercions in Unify]
[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 DataCon
21 import DynFlags ( DynFlags, GeneralFlag(Opt_PrintExplicitKinds), gopt )
22 import TyCon
23 import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
24 import FamInst
25 import Module ( Module, moduleName, moduleNameFS
26 , moduleUnitId, unitIdFS )
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 VarSet (elemVarSet)
41 import Outputable
42 import FastString
43 import Util
44
45 import Control.Monad (mplus)
46 import Data.List (zip4)
47 import Data.Maybe (isJust)
48
49 #include "HsVersions.h"
50
51 {-
52 ************************************************************************
53 * *
54 \subsection{Bindings for the new generic deriving mechanism}
55 * *
56 ************************************************************************
57
58 For the generic representation we need to generate:
59 \begin{itemize}
60 \item A Generic instance
61 \item A Rep type instance
62 \item Many auxiliary datatypes and instances for them (for the meta-information)
63 \end{itemize}
64 -}
65
66 gen_Generic_binds :: GenericKind -> TyCon -> Module
67 -> TcM (LHsBinds RdrName, FamInst)
68 gen_Generic_binds gk tc mod = do
69 repTyInsts <- tc_mkRepFamInsts gk tc mod
70 return (mkBindsRep gk tc, repTyInsts)
71
72 {-
73 ************************************************************************
74 * *
75 \subsection{Generating representation types}
76 * *
77 ************************************************************************
78 -}
79
80 get_gen1_constrained_tys :: TyVar -> Type -> [Type]
81 -- called by TcDeriv.inferConstraints; generates a list of types, each of which
82 -- must be a Functor in order for the Generic1 instance to work.
83 get_gen1_constrained_tys argVar
84 = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
85 , ata_par1 = [], ata_rec1 = const []
86 , ata_comp = (:) }
87
88 {-
89
90 Note [Requirements for deriving Generic and Rep]
91 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
92
93 In the following, T, Tfun, and Targ are "meta-variables" ranging over type
94 expressions.
95
96 (Generic T) and (Rep T) are derivable for some type expression T if the
97 following constraints are satisfied.
98
99 (a) T = (D v1 ... vn) with free variables v1, v2, ..., vn where n >= 0 v1
100 ... vn are distinct type variables. Cf #5939.
101
102 (b) D is a type constructor *value*. In other words, D is either a type
103 constructor or it is equivalent to the head of a data family instance (up to
104 alpha-renaming).
105
106 (c) D cannot have a "stupid context".
107
108 (d) The right-hand side of D cannot include unboxed types, existential types,
109 or universally quantified types.
110
111 (e) T :: *.
112
113 (Generic1 T) and (Rep1 T) are derivable for some type expression T if the
114 following constraints are satisfied.
115
116 (a),(b),(c),(d) As above.
117
118 (f) T must expect arguments, and its last parameter must have kind *.
119
120 We use `a' to denote the parameter of D that corresponds to the last
121 parameter of T.
122
123 (g) For any type-level application (Tfun Targ) in the right-hand side of D
124 where the head of Tfun is not a tuple constructor:
125
126 (b1) `a' must not occur in Tfun.
127
128 (b2) If `a' occurs in Targ, then Tfun :: * -> *.
129
130 -}
131
132 canDoGenerics :: DynFlags -> TyCon -> [Type] -> Validity
133 -- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a
134 -- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
135 --
136 -- Check (b) from Note [Requirements for deriving Generic and Rep] is taken
137 -- care of because canDoGenerics is applied to rep tycons.
138 --
139 -- It returns Nothing if deriving is possible. It returns (Just reason) if not.
140 canDoGenerics dflags tc tc_args
141 = mergeErrors (
142 -- Check (c) from Note [Requirements for deriving Generic and Rep].
143 (if (not (null (tyConStupidTheta tc)))
144 then (NotValid (tc_name <+> text "must not have a datatype context"))
145 else IsValid) :
146 -- Check (a) from Note [Requirements for deriving Generic and Rep].
147 --
148 -- Data family indices can be instantiated; the `tc_args` here are
149 -- the representation tycon args
150 --
151 -- NB: Use user_tc here. In the case of a data *instance*, the
152 -- user_tc is the family tc, which has the right visibility settings.
153 -- (For a normal datatype, user_tc == tc.) Getting this wrong
154 -- led to #11357.
155 (if (all isTyVarTy (filterOutInvisibleTypes user_tc tc_args))
156 then IsValid
157 else NotValid (tc_name <+> text "must not be instantiated;" <+>
158 text "try deriving `" <> tc_name <+> tc_tys <>
159 text "' instead"))
160 -- See comment below
161 : (map bad_con (tyConDataCons tc)))
162 where
163 -- The tc can be a representation tycon. When we want to display it to the
164 -- user (in an error message) we should print its parent
165 (user_tc, tc_name, tc_tys) = case tyConFamInst_maybe tc of
166 Just (ptc, tys) -> (ptc, ppr ptc, hsep (map ppr (filter_kinds $ tys ++ drop (length tys) tc_args)))
167 _ -> (tc, ppr tc, hsep (map ppr (filter_kinds $ mkTyVarTys $ tyConTyVars tc)))
168
169 filter_kinds | gopt Opt_PrintExplicitKinds dflags
170 = id
171 | otherwise
172 = filterOutInvisibleTypes user_tc
173
174 -- Check (d) from Note [Requirements for deriving Generic and Rep].
175 --
176 -- If any of the constructors has an unboxed type as argument,
177 -- then we can't build the embedding-projection pair, because
178 -- it relies on instantiating *polymorphic* sum and product types
179 -- at the argument types of the constructors
180 bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
181 then (NotValid (ppr dc <+> text
182 "must not have exotic unlifted or polymorphic arguments"))
183 else (if (not (isVanillaDataCon dc))
184 then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
185 else IsValid)
186
187 -- Nor can we do the job if it's an existential data constructor,
188 -- Nor if the args are polymorphic types (I don't think)
189 bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))
190 || not (isTauTy ty)
191
192 allowedUnliftedTy :: Type -> Bool
193 allowedUnliftedTy = isJust . unboxedRepRDRs
194
195 mergeErrors :: [Validity] -> Validity
196 mergeErrors [] = IsValid
197 mergeErrors (NotValid s:t) = case mergeErrors t of
198 IsValid -> NotValid s
199 NotValid s' -> NotValid (s <> text ", and" $$ s')
200 mergeErrors (IsValid : t) = mergeErrors t
201
202 -- A datatype used only inside of canDoGenerics1. It's the result of analysing
203 -- a type term.
204 data Check_for_CanDoGenerics1 = CCDG1
205 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in
206 -- this type?
207 , _ccdg1_errors :: Validity -- errors generated by this type
208 }
209
210 {-
211
212 Note [degenerate use of FFoldType]
213 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
214
215 We use foldDataConArgs here only for its ability to treat tuples
216 specially. foldDataConArgs also tracks covariance (though it assumes all
217 higher-order type parameters are covariant) and has hooks for special handling
218 of functions and polytypes, but we do *not* use those.
219
220 The key issue is that Generic1 deriving currently offers no sophisticated
221 support for functions. For example, we cannot handle
222
223 data F a = F ((a -> Int) -> Int)
224
225 even though a is occurring covariantly.
226
227 In fact, our rule is harsh: a is simply not allowed to occur within the first
228 argument of (->). We treat (->) the same as any other non-tuple tycon.
229
230 Unfortunately, this means we have to track "the parameter occurs in this type"
231 explicitly, even though foldDataConArgs is also doing this internally.
232
233 -}
234
235 -- canDoGenerics1 rep_tc tc_args determines if a Generic1/Rep1 can be derived
236 -- for a type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
237 --
238 -- Checks (a) through (d) from Note [Requirements for deriving Generic and Rep]
239 -- are taken care of by the call to canDoGenerics.
240 --
241 -- It returns Nothing if deriving is possible. It returns (Just reason) if not.
242 canDoGenerics1 :: DynFlags -> TyCon -> [Type] -> Validity
243 canDoGenerics1 dflags rep_tc tc_args =
244 canDoGenerics dflags rep_tc tc_args `andValid` additionalChecks
245 where
246 additionalChecks
247 -- check (f) from Note [Requirements for deriving Generic and Rep]
248 | null (tyConTyVars rep_tc) = NotValid $
249 text "Data type" <+> quotes (ppr rep_tc)
250 <+> text "must have some type parameters"
251
252 | otherwise = mergeErrors $ concatMap check_con data_cons
253
254 data_cons = tyConDataCons rep_tc
255 check_con con = case check_vanilla con of
256 j@(NotValid {}) -> [j]
257 IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
258
259 bad :: DataCon -> SDoc -> SDoc
260 bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg
261
262 check_vanilla :: DataCon -> Validity
263 check_vanilla con | isVanillaDataCon con = IsValid
264 | otherwise = NotValid (bad con existential)
265
266 bmzero = CCDG1 False IsValid
267 bmbad con s = CCDG1 True $ NotValid $ bad con s
268 bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
269
270 -- check (g) from Note [degenerate use of FFoldType]
271 ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
272 ft_check con = FT
273 { ft_triv = bmzero
274
275 , ft_var = caseVar, ft_co_var = caseVar
276
277 -- (component_0,component_1,...,component_n)
278 , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
279 then bmbad con wrong_arg
280 else foldr bmplus bmzero components
281
282 -- (dom -> rng), where the head of ty is not a tuple tycon
283 , ft_fun = \dom rng -> -- cf #8516
284 if _ccdg1_hasParam dom
285 then bmbad con wrong_arg
286 else bmplus dom rng
287
288 -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
289 -- the parameter of interest does not occur in ty
290 , ft_ty_app = \_ arg -> arg
291
292 , ft_bad_app = bmbad con wrong_arg
293 , ft_forall = \_ body -> body -- polytypes are handled elsewhere
294 }
295 where
296 caseVar = CCDG1 True IsValid
297
298
299 existential = text "must not have existential arguments"
300 wrong_arg = text "applies a type to an argument involving the last parameter"
301 $$ text "but the applied type is not of kind * -> *"
302
303 {-
304 ************************************************************************
305 * *
306 \subsection{Generating the RHS of a generic default method}
307 * *
308 ************************************************************************
309 -}
310
311 type US = Int -- Local unique supply, just a plain Int
312 type Alt = (LPat RdrName, LHsExpr RdrName)
313
314 -- GenericKind serves to mark if a datatype derives Generic (Gen0) or
315 -- Generic1 (Gen1).
316 data GenericKind = Gen0 | Gen1
317
318 -- as above, but with a payload of the TyCon's name for "the" parameter
319 data GenericKind_ = Gen0_ | Gen1_ TyVar
320
321 -- as above, but using a single datacon's name for "the" parameter
322 data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
323
324 forgetArgVar :: GenericKind_DC -> GenericKind
325 forgetArgVar Gen0_DC = Gen0
326 forgetArgVar Gen1_DC{} = Gen1
327
328 -- When working only within a single datacon, "the" parameter's name should
329 -- match that datacon's name for it.
330 gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
331 gk2gkDC Gen0_ _ = Gen0_DC
332 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
333
334
335 -- Bindings for the Generic instance
336 mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
337 mkBindsRep gk tycon =
338 unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
339 `unionBags`
340 unitBag (mkRdrFunBind (L loc to01_RDR) to_matches)
341 where
342 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
343 to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
344 loc = srcLocSpan (getSrcLoc tycon)
345 datacons = tyConDataCons tycon
346
347 (from01_RDR, to01_RDR) = case gk of
348 Gen0 -> (from_RDR, to_RDR)
349 Gen1 -> (from1_RDR, to1_RDR)
350
351 -- Recurse over the sum first
352 from_alts, to_alts :: [Alt]
353 (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
354 where gk_ = case gk of
355 Gen0 -> Gen0_
356 Gen1 -> ASSERT(length tyvars >= 1)
357 Gen1_ (last tyvars)
358 where tyvars = tyConTyVars tycon
359
360 --------------------------------------------------------------------------------
361 -- The type synonym instance and synonym
362 -- type instance Rep (D a b) = Rep_D a b
363 -- type Rep_D a b = ...representation type for D ...
364 --------------------------------------------------------------------------------
365
366 tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
367 -> TyCon -- The type to generate representation for
368 -> Module -- Used as the location of the new RepTy
369 -> TcM (FamInst) -- Generated representation0 coercion
370 tc_mkRepFamInsts gk tycon mod =
371 -- Consider the example input tycon `D`, where data D a b = D_ a
372 -- Also consider `R:DInt`, where { data family D x y :: * -> *
373 -- ; data instance D Int a b = D_ a }
374 do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
375 fam_tc <- case gk of
376 Gen0 -> tcLookupTyCon repTyConName
377 Gen1 -> tcLookupTyCon rep1TyConName
378
379 ; let -- `tyvars` = [a,b]
380 (tyvars, gk_) = case gk of
381 Gen0 -> (all_tyvars, Gen0_)
382 Gen1 -> ASSERT(not $ null all_tyvars)
383 (init all_tyvars, Gen1_ $ last all_tyvars)
384 where all_tyvars = tyConTyVars tycon
385
386 tyvar_args = mkTyVarTys tyvars
387
388 appT :: [Type]
389 appT = case tyConFamInst_maybe tycon of
390 -- `appT` = D Int a b (data families case)
391 Just (famtycon, apps) ->
392 -- `fam` = D
393 -- `apps` = [Int, a, b]
394 let allApps = case gk of
395 Gen0 -> apps
396 Gen1 -> ASSERT(not $ null apps)
397 init apps
398 in [mkTyConApp famtycon allApps]
399 -- `appT` = D a b (normal case)
400 Nothing -> [mkTyConApp tycon tyvar_args]
401
402 -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
403 ; repTy <- tc_mkRepTy gk_ tycon
404
405 -- `rep_name` is a name we generate for the synonym
406 ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
407 in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
408 (nameSrcSpan (tyConName tycon))
409
410 ; let axiom = mkSingleCoAxiom Nominal rep_name tyvars [] fam_tc appT repTy
411 ; newFamInst SynFamilyInst axiom }
412
413 --------------------------------------------------------------------------------
414 -- Type representation
415 --------------------------------------------------------------------------------
416
417 -- | See documentation of 'argTyFold'; that function uses the fields of this
418 -- type to interpret the structure of a type when that type is considered as an
419 -- argument to a constructor that is being represented with 'Rep1'.
420 data ArgTyAlg a = ArgTyAlg
421 { ata_rec0 :: (Type -> a)
422 , ata_par1 :: a, ata_rec1 :: (Type -> a)
423 , ata_comp :: (Type -> a -> a)
424 }
425
426 -- | @argTyFold@ implements a generalised and safer variant of the @arg@
427 -- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
428 -- is conceptually equivalent to:
429 --
430 -- > arg t = case t of
431 -- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t
432 -- > App f [t'] |
433 -- > representable1 f &&
434 -- > t' == argVar -> Rec1 f
435 -- > App f [t'] |
436 -- > representable1 f &&
437 -- > t' has tyvars -> f :.: (arg t')
438 -- > _ -> Rec0 t
439 --
440 -- where @argVar@ is the last type variable in the data type declaration we are
441 -- finding the representation for.
442 --
443 -- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
444 -- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
445 -- @:.:@.
446 --
447 -- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
448 -- some data types. The problematic case is when @t@ is an application of a
449 -- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
450 -- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
451 -- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
452 -- representable1 checks have been relaxed, and others were moved to
453 -- @canDoGenerics1@.
454 argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
455 argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
456 ata_par1 = mkPar1, ata_rec1 = mkRec1,
457 ata_comp = mkComp}) =
458 -- mkRec0 is the default; use it if there is no interesting structure
459 -- (e.g. occurrences of parameters or recursive occurrences)
460 \t -> maybe (mkRec0 t) id $ go t where
461 go :: Type -> -- type to fold through
462 Maybe a -- the result (e.g. representation type), unless it's trivial
463 go t = isParam `mplus` isApp where
464
465 isParam = do -- handles parameters
466 t' <- getTyVar_maybe t
467 Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
468 else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
469
470 isApp = do -- handles applications
471 (phi, beta) <- tcSplitAppTy_maybe t
472
473 let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
474
475 -- Does it have no interesting structure to represent?
476 if not interesting then Nothing
477 else -- Is the argument the parameter? Special case for mkRec1.
478 if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
479 else mkComp phi `fmap` go beta -- It must be a composition.
480
481
482 tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
483 GenericKind_
484 -- The type to generate representation for
485 -> TyCon
486 -- Generated representation0 type
487 -> TcM Type
488 tc_mkRepTy gk_ tycon =
489 do
490 d1 <- tcLookupTyCon d1TyConName
491 c1 <- tcLookupTyCon c1TyConName
492 s1 <- tcLookupTyCon s1TyConName
493 rec0 <- tcLookupTyCon rec0TyConName
494 rec1 <- tcLookupTyCon rec1TyConName
495 par1 <- tcLookupTyCon par1TyConName
496 u1 <- tcLookupTyCon u1TyConName
497 v1 <- tcLookupTyCon v1TyConName
498 plus <- tcLookupTyCon sumTyConName
499 times <- tcLookupTyCon prodTyConName
500 comp <- tcLookupTyCon compTyConName
501 uAddr <- tcLookupTyCon uAddrTyConName
502 uChar <- tcLookupTyCon uCharTyConName
503 uDouble <- tcLookupTyCon uDoubleTyConName
504 uFloat <- tcLookupTyCon uFloatTyConName
505 uInt <- tcLookupTyCon uIntTyConName
506 uWord <- tcLookupTyCon uWordTyConName
507
508 let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
509
510 md <- tcLookupPromDataCon metaDataDataConName
511 mc <- tcLookupPromDataCon metaConsDataConName
512 ms <- tcLookupPromDataCon metaSelDataConName
513 pPrefix <- tcLookupPromDataCon prefixIDataConName
514 pInfix <- tcLookupPromDataCon infixIDataConName
515 pLA <- tcLookupPromDataCon leftAssociativeDataConName
516 pRA <- tcLookupPromDataCon rightAssociativeDataConName
517 pNA <- tcLookupPromDataCon notAssociativeDataConName
518 pSUpk <- tcLookupPromDataCon sourceUnpackDataConName
519 pSNUpk <- tcLookupPromDataCon sourceNoUnpackDataConName
520 pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
521 pSLzy <- tcLookupPromDataCon sourceLazyDataConName
522 pSStr <- tcLookupPromDataCon sourceStrictDataConName
523 pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
524 pDLzy <- tcLookupPromDataCon decidedLazyDataConName
525 pDStr <- tcLookupPromDataCon decidedStrictDataConName
526 pDUpk <- tcLookupPromDataCon decidedUnpackDataConName
527
528 fix_env <- getFixityEnv
529
530 let mkSum' a b = mkTyConApp plus [a,b]
531 mkProd a b = mkTyConApp times [a,b]
532 mkComp a b = mkTyConApp comp [a,b]
533 mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a
534 mkRec1 a = mkTyConApp rec1 [a]
535 mkPar1 = mkTyConTy par1
536 mkD a = mkTyConApp d1 [ metaDataTy, sumP (tyConDataCons a) ]
537 mkC a = mkTyConApp c1 [ metaConsTy a
538 , prod (dataConInstOrigArgTys a
539 . mkTyVarTys . tyConTyVars $ tycon)
540 (dataConSrcBangs a)
541 (dataConImplBangs a)
542 (dataConFieldLabels a)]
543 mkS mlbl su ss ib a = mkTyConApp s1 [metaSelTy mlbl su ss ib, a]
544
545 -- Sums and products are done in the same way for both Rep and Rep1
546 sumP [] = mkTyConTy v1
547 sumP l = foldBal mkSum' . map mkC $ l
548 -- The Bool is True if this constructor has labelled fields
549 prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
550 prod [] _ _ _ = mkTyConTy u1
551 prod l sb ib fl = foldBal mkProd
552 [ ASSERT(null fl || length fl > j)
553 arg t sb' ib' (if null fl
554 then Nothing
555 else Just (fl !! j))
556 | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
557
558 arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
559 arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
560 -- Here we previously used Par0 if t was a type variable, but we
561 -- realized that we can't always guarantee that we are wrapping-up
562 -- all type variables in Par0. So we decided to stop using Par0
563 -- altogether, and use Rec0 all the time.
564 Gen0_ -> mkRec0 t
565 Gen1_ argVar -> argPar argVar t
566 where
567 -- Builds argument representation for Rep1 (more complicated due to
568 -- the presence of composition).
569 argPar argVar = argTyFold argVar $ ArgTyAlg
570 {ata_rec0 = mkRec0, ata_par1 = mkPar1,
571 ata_rec1 = mkRec1, ata_comp = mkComp}
572
573 tyConName_user = case tyConFamInst_maybe tycon of
574 Just (ptycon, _) -> tyConName ptycon
575 Nothing -> tyConName tycon
576
577 dtName = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
578 mdName = mkStrLitTy . moduleNameFS . moduleName
579 . nameModule . tyConName $ tycon
580 pkgName = mkStrLitTy . unitIdFS . moduleUnitId
581 . nameModule . tyConName $ tycon
582 isNT = mkTyConTy $ if isNewTyCon tycon
583 then promotedTrueDataCon
584 else promotedFalseDataCon
585
586 ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
587 ctFix c
588 | dataConIsInfix c
589 = case lookupFixity fix_env (dataConName c) of
590 Fixity _ n InfixL -> buildFix n pLA
591 Fixity _ n InfixR -> buildFix n pRA
592 Fixity _ n InfixN -> buildFix n pNA
593 | otherwise = mkTyConTy pPrefix
594 buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
595 , mkNumLitTy (fromIntegral n)]
596
597 isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0
598 then promotedTrueDataCon
599 else promotedFalseDataCon
600
601 selName = mkStrLitTy . flLabel
602
603 mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind]
604 mbSel (Just s) = mkTyConApp promotedJustDataCon
605 [typeSymbolKind, selName s]
606
607 metaDataTy = mkTyConApp md [dtName, mdName, pkgName, isNT]
608 metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
609 metaSelTy mlbl su ss ib =
610 mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
611 where
612 pSUpkness = mkTyConTy $ case su of
613 SrcUnpack -> pSUpk
614 SrcNoUnpack -> pSNUpk
615 NoSrcUnpack -> pNSUpkness
616
617 pSStrness = mkTyConTy $ case ss of
618 SrcLazy -> pSLzy
619 SrcStrict -> pSStr
620 NoSrcStrict -> pNSStrness
621
622 pDStrness = mkTyConTy $ case ib of
623 HsLazy -> pDLzy
624 HsStrict -> pDStr
625 HsUnpack{} -> pDUpk
626
627 return (mkD tycon)
628
629 -- Given the TyCons for each URec-related type synonym, check to see if the
630 -- given type is an unlifted type that generics understands. If so, return
631 -- its representation type. Otherwise, return Rec0.
632 -- See Note [Generics and unlifted types]
633 mkBoxTy :: TyCon -- UAddr
634 -> TyCon -- UChar
635 -> TyCon -- UDouble
636 -> TyCon -- UFloat
637 -> TyCon -- UInt
638 -> TyCon -- UWord
639 -> TyCon -- Rec0
640 -> Type
641 -> Type
642 mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty
643 | ty `eqType` addrPrimTy = mkTyConTy uAddr
644 | ty `eqType` charPrimTy = mkTyConTy uChar
645 | ty `eqType` doublePrimTy = mkTyConTy uDouble
646 | ty `eqType` floatPrimTy = mkTyConTy uFloat
647 | ty `eqType` intPrimTy = mkTyConTy uInt
648 | ty `eqType` wordPrimTy = mkTyConTy uWord
649 | otherwise = mkTyConApp rec0 [ty]
650
651 --------------------------------------------------------------------------------
652 -- Dealing with sums
653 --------------------------------------------------------------------------------
654
655 mkSum :: GenericKind_ -- Generic or Generic1?
656 -> US -- Base for generating unique names
657 -> TyCon -- The type constructor
658 -> [DataCon] -- The data constructors
659 -> ([Alt], -- Alternatives for the T->Trep "from" function
660 [Alt]) -- Alternatives for the Trep->T "to" function
661
662 -- Datatype without any constructors
663 mkSum _ _ tycon [] = ([from_alt], [to_alt])
664 where
665 from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
666 to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
667 -- These M1s are meta-information for the datatype
668 makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
669 tyConStr = occNameString (nameOccName (tyConName tycon))
670 errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
671 errMsgTo = "No values for empty datatype " ++ tyConStr
672
673 -- Datatype with at least one constructor
674 mkSum gk_ us _ datacons =
675 -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
676 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
677 | (d,i) <- zip datacons [1..] ]
678
679 -- Build the sum for a particular constructor
680 mk1Sum :: GenericKind_DC -- Generic or Generic1?
681 -> US -- Base for generating unique names
682 -> Int -- The index of this constructor
683 -> Int -- Total number of constructors
684 -> DataCon -- The data constructor
685 -> (Alt, -- Alternative for the T->Trep "from" function
686 Alt) -- Alternative for the Trep->T "to" function
687 mk1Sum gk_ us i n datacon = (from_alt, to_alt)
688 where
689 gk = forgetArgVar gk_
690
691 -- Existentials already excluded
692 argTys = dataConOrigArgTys datacon
693 n_args = dataConSourceArity datacon
694
695 datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
696 datacon_vars = map fst datacon_varTys
697 us' = us + n_args
698
699 datacon_rdr = getRdrName datacon
700
701 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
702 from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
703
704 to_alt = ( mkM1_P (genLR_P i n (mkProd_P gk us' datacon_varTys))
705 , to_alt_rhs
706 ) -- These M1s are meta-information for the datatype
707 to_alt_rhs = case gk_ of
708 Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
709 Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
710 where
711 argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
712 converter = argTyFold argVar $ ArgTyAlg
713 {ata_rec0 = nlHsVar . unboxRepRDR,
714 ata_par1 = nlHsVar unPar1_RDR,
715 ata_rec1 = const $ nlHsVar unRec1_RDR,
716 ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
717 `nlHsCompose` nlHsVar unComp1_RDR}
718
719
720 -- Generates the L1/R1 sum pattern
721 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
722 genLR_P i n p
723 | n == 0 = error "impossible"
724 | n == 1 = p
725 | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
726 | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
727 where m = div n 2
728
729 -- Generates the L1/R1 sum expression
730 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
731 genLR_E i n e
732 | n == 0 = error "impossible"
733 | n == 1 = e
734 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
735 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
736 where m = div n 2
737
738 --------------------------------------------------------------------------------
739 -- Dealing with products
740 --------------------------------------------------------------------------------
741
742 -- Build a product expression
743 mkProd_E :: GenericKind_DC -- Generic or Generic1?
744 -> US -- Base for unique names
745 -> [(RdrName, Type)] -- List of variables matched on the lhs and their types
746 -> LHsExpr RdrName -- Resulting product expression
747 mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
748 mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
749 -- These M1s are meta-information for the constructor
750 where
751 appVars = map (wrapArg_E gk_) varTys
752 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
753
754 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
755 wrapArg_E Gen0_DC (var, ty) = mkM1_E $
756 boxRepRDR ty `nlHsVarApps` [var]
757 -- This M1 is meta-information for the selector
758 wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
759 converter ty `nlHsApp` nlHsVar var
760 -- This M1 is meta-information for the selector
761 where converter = argTyFold argVar $ ArgTyAlg
762 {ata_rec0 = nlHsVar . boxRepRDR,
763 ata_par1 = nlHsVar par1DataCon_RDR,
764 ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
765 ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
766 (nlHsVar fmap_RDR `nlHsApp` cnv)}
767
768 boxRepRDR :: Type -> RdrName
769 boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
770
771 unboxRepRDR :: Type -> RdrName
772 unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
773
774 -- Retrieve the RDRs associated with each URec data family instance
775 -- constructor. See Note [Generics and unlifted types]
776 unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
777 unboxedRepRDRs ty
778 | ty `eqType` addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR)
779 | ty `eqType` charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR)
780 | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
781 | ty `eqType` floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR)
782 | ty `eqType` intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR)
783 | ty `eqType` wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR)
784 | otherwise = Nothing
785
786 -- Build a product pattern
787 mkProd_P :: GenericKind -- Gen0 or Gen1
788 -> US -- Base for unique names
789 -> [(RdrName, Type)] -- List of variables to match,
790 -- along with their types
791 -> LPat RdrName -- Resulting product pattern
792 mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
793 mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
794 -- These M1s are meta-information for the constructor
795 where
796 appVars = unzipWith (wrapArg_P gk) varTys
797 prod a b = prodDataCon_RDR `nlConPat` [a,b]
798
799 wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
800 wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
801 -- This M1 is meta-information for the selector
802 wrapArg_P Gen1 v _ = m1DataCon_RDR `nlConVarPat` [v]
803
804 mkGenericLocal :: US -> RdrName
805 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
806
807 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
808 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
809
810 mkM1_P :: LPat RdrName -> LPat RdrName
811 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
812
813 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
814 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
815
816 -- | Variant of foldr1 for producing balanced lists
817 foldBal :: (a -> a -> a) -> [a] -> a
818 foldBal op = foldBal' op (error "foldBal: empty list")
819
820 foldBal' :: (a -> a -> a) -> a -> [a] -> a
821 foldBal' _ x [] = x
822 foldBal' _ _ [y] = y
823 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
824 in foldBal' op x a `op` foldBal' op x b
825
826 {-
827 Note [Generics and unlifted types]
828 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
829 Normally, all constants are marked with K1/Rec0. The exception to this rule is
830 when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
831 that case, we must use a data family instance of URec (from GHC.Generics) to
832 mark it. As a result, before we can generate K1 or unK1, we must first check
833 to see if the type is actually one of the unlifted types for which URec has a
834 data family instance; if so, we generate that instead.
835
836 See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
837 details on why URec is implemented the way it is.
838 -}