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