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