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