9a1c506b33b18aae1521c3eb9ce5a4385059b6ba
[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 tc_name = tyConName tc
77 ty_rep_name <- newTyConRepName tc_name
78 let 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 (VanillaAlgTyCon ty_rep_name)
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 tyConFamInst_maybe tc of
269 Just (ptc, tys) -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args)))
270 _ -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
271
272 -- Check (d) from Note [Requirements for deriving Generic and Rep].
273 --
274 -- If any of the constructors has an unboxed type as argument,
275 -- then we can't build the embedding-projection pair, because
276 -- it relies on instantiating *polymorphic* sum and product types
277 -- at the argument types of the constructors
278 bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
279 then (NotValid (ppr dc <+> text
280 "must not have exotic unlifted or polymorphic arguments"))
281 else (if (not (isVanillaDataCon dc))
282 then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
283 else IsValid)
284
285 -- Nor can we do the job if it's an existential data constructor,
286 -- Nor if the args are polymorphic types (I don't think)
287 bad_arg_type ty = (isUnLiftedType ty && not (allowedUnliftedTy ty))
288 || not (isTauTy ty)
289
290 allowedUnliftedTy :: Type -> Bool
291 allowedUnliftedTy = isJust . unboxedRepRDRs
292
293 mergeErrors :: [Validity] -> Validity
294 mergeErrors [] = IsValid
295 mergeErrors (NotValid s:t) = case mergeErrors t of
296 IsValid -> NotValid s
297 NotValid s' -> NotValid (s <> text ", and" $$ s')
298 mergeErrors (IsValid : t) = mergeErrors t
299
300 -- A datatype used only inside of canDoGenerics1. It's the result of analysing
301 -- a type term.
302 data Check_for_CanDoGenerics1 = CCDG1
303 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in
304 -- this type?
305 , _ccdg1_errors :: Validity -- errors generated by this type
306 }
307
308 {-
309
310 Note [degenerate use of FFoldType]
311 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
312
313 We use foldDataConArgs here only for its ability to treat tuples
314 specially. foldDataConArgs also tracks covariance (though it assumes all
315 higher-order type parameters are covariant) and has hooks for special handling
316 of functions and polytypes, but we do *not* use those.
317
318 The key issue is that Generic1 deriving currently offers no sophisticated
319 support for functions. For example, we cannot handle
320
321 data F a = F ((a -> Int) -> Int)
322
323 even though a is occurring covariantly.
324
325 In fact, our rule is harsh: a is simply not allowed to occur within the first
326 argument of (->). We treat (->) the same as any other non-tuple tycon.
327
328 Unfortunately, this means we have to track "the parameter occurs in this type"
329 explicitly, even though foldDataConArgs is also doing this internally.
330
331 -}
332
333 -- canDoGenerics1 rep_tc tc_args determines if a Generic1/Rep1 can be derived
334 -- for a type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
335 --
336 -- Checks (a) through (d) from Note [Requirements for deriving Generic and Rep]
337 -- are taken care of by the call to canDoGenerics.
338 --
339 -- It returns Nothing if deriving is possible. It returns (Just reason) if not.
340 canDoGenerics1 :: TyCon -> [Type] -> Validity
341 canDoGenerics1 rep_tc tc_args =
342 canDoGenerics rep_tc tc_args `andValid` additionalChecks
343 where
344 additionalChecks
345 -- check (f) from Note [Requirements for deriving Generic and Rep]
346 | null (tyConTyVars rep_tc) = NotValid $
347 ptext (sLit "Data type") <+> quotes (ppr rep_tc)
348 <+> ptext (sLit "must have some type parameters")
349
350 | otherwise = mergeErrors $ concatMap check_con data_cons
351
352 data_cons = tyConDataCons rep_tc
353 check_con con = case check_vanilla con of
354 j@(NotValid {}) -> [j]
355 IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
356
357 bad :: DataCon -> SDoc -> SDoc
358 bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
359
360 check_vanilla :: DataCon -> Validity
361 check_vanilla con | isVanillaDataCon con = IsValid
362 | otherwise = NotValid (bad con existential)
363
364 bmzero = CCDG1 False IsValid
365 bmbad con s = CCDG1 True $ NotValid $ bad con s
366 bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
367
368 -- check (g) from Note [degenerate use of FFoldType]
369 ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
370 ft_check con = FT
371 { ft_triv = bmzero
372
373 , ft_var = caseVar, ft_co_var = caseVar
374
375 -- (component_0,component_1,...,component_n)
376 , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
377 then bmbad con wrong_arg
378 else foldr bmplus bmzero components
379
380 -- (dom -> rng), where the head of ty is not a tuple tycon
381 , ft_fun = \dom rng -> -- cf #8516
382 if _ccdg1_hasParam dom
383 then bmbad con wrong_arg
384 else bmplus dom rng
385
386 -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
387 -- the parameter of interest does not occur in ty
388 , ft_ty_app = \_ arg -> arg
389
390 , ft_bad_app = bmbad con wrong_arg
391 , ft_forall = \_ body -> body -- polytypes are handled elsewhere
392 }
393 where
394 caseVar = CCDG1 True IsValid
395
396
397 existential = text "must not have existential arguments"
398 wrong_arg = text "applies a type to an argument involving the last parameter"
399 $$ text "but the applied type is not of kind * -> *"
400
401 {-
402 ************************************************************************
403 * *
404 \subsection{Generating the RHS of a generic default method}
405 * *
406 ************************************************************************
407 -}
408
409 type US = Int -- Local unique supply, just a plain Int
410 type Alt = (LPat RdrName, LHsExpr RdrName)
411
412 -- GenericKind serves to mark if a datatype derives Generic (Gen0) or
413 -- Generic1 (Gen1).
414 data GenericKind = Gen0 | Gen1
415
416 -- as above, but with a payload of the TyCon's name for "the" parameter
417 data GenericKind_ = Gen0_ | Gen1_ TyVar
418
419 -- as above, but using a single datacon's name for "the" parameter
420 data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
421
422 forgetArgVar :: GenericKind_DC -> GenericKind
423 forgetArgVar Gen0_DC = Gen0
424 forgetArgVar Gen1_DC{} = Gen1
425
426 -- When working only within a single datacon, "the" parameter's name should
427 -- match that datacon's name for it.
428 gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
429 gk2gkDC Gen0_ _ = Gen0_DC
430 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
431
432
433
434 -- Bindings for the Generic instance
435 mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
436 mkBindsRep gk tycon =
437 unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
438 `unionBags`
439 unitBag (mkRdrFunBind (L loc to01_RDR) to_matches)
440 where
441 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
442 to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
443 loc = srcLocSpan (getSrcLoc tycon)
444 datacons = tyConDataCons tycon
445
446 (from01_RDR, to01_RDR) = case gk of
447 Gen0 -> (from_RDR, to_RDR)
448 Gen1 -> (from1_RDR, to1_RDR)
449
450 -- Recurse over the sum first
451 from_alts, to_alts :: [Alt]
452 (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
453 where gk_ = case gk of
454 Gen0 -> Gen0_
455 Gen1 -> ASSERT(length tyvars >= 1)
456 Gen1_ (last tyvars)
457 where tyvars = tyConTyVars tycon
458
459 --------------------------------------------------------------------------------
460 -- The type synonym instance and synonym
461 -- type instance Rep (D a b) = Rep_D a b
462 -- type Rep_D a b = ...representation type for D ...
463 --------------------------------------------------------------------------------
464
465 tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
466 -> TyCon -- The type to generate representation for
467 -> MetaTyCons -- Metadata datatypes to refer to
468 -> Module -- Used as the location of the new RepTy
469 -> TcM (FamInst) -- Generated representation0 coercion
470 tc_mkRepFamInsts gk tycon metaDts mod =
471 -- Consider the example input tycon `D`, where data D a b = D_ a
472 -- Also consider `R:DInt`, where { data family D x y :: * -> *
473 -- ; data instance D Int a b = D_ a }
474 do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
475 fam_tc <- case gk of
476 Gen0 -> tcLookupTyCon repTyConName
477 Gen1 -> tcLookupTyCon rep1TyConName
478
479 ; let -- `tyvars` = [a,b]
480 (tyvars, gk_) = case gk of
481 Gen0 -> (all_tyvars, Gen0_)
482 Gen1 -> ASSERT(not $ null all_tyvars)
483 (init all_tyvars, Gen1_ $ last all_tyvars)
484 where all_tyvars = tyConTyVars tycon
485
486 tyvar_args = mkTyVarTys tyvars
487
488 appT :: [Type]
489 appT = case tyConFamInst_maybe tycon of
490 -- `appT` = D Int a b (data families case)
491 Just (famtycon, apps) ->
492 -- `fam` = D
493 -- `apps` = [Int, a, b]
494 let allApps = case gk of
495 Gen0 -> apps
496 Gen1 -> ASSERT(not $ null apps)
497 init apps
498 in [mkTyConApp famtycon allApps]
499 -- `appT` = D a b (normal case)
500 Nothing -> [mkTyConApp tycon tyvar_args]
501
502 -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
503 ; repTy <- tc_mkRepTy gk_ tycon metaDts
504
505 -- `rep_name` is a name we generate for the synonym
506 ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
507 in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
508 (nameSrcSpan (tyConName tycon))
509
510 ; let axiom = mkSingleCoAxiom Nominal rep_name tyvars fam_tc appT repTy
511 ; newFamInst SynFamilyInst axiom }
512
513 --------------------------------------------------------------------------------
514 -- Type representation
515 --------------------------------------------------------------------------------
516
517 -- | See documentation of 'argTyFold'; that function uses the fields of this
518 -- type to interpret the structure of a type when that type is considered as an
519 -- argument to a constructor that is being represented with 'Rep1'.
520 data ArgTyAlg a = ArgTyAlg
521 { ata_rec0 :: (Type -> a)
522 , ata_par1 :: a, ata_rec1 :: (Type -> a)
523 , ata_comp :: (Type -> a -> a)
524 }
525
526 -- | @argTyFold@ implements a generalised and safer variant of the @arg@
527 -- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
528 -- is conceptually equivalent to:
529 --
530 -- > arg t = case t of
531 -- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t
532 -- > App f [t'] |
533 -- > representable1 f &&
534 -- > t' == argVar -> Rec1 f
535 -- > App f [t'] |
536 -- > representable1 f &&
537 -- > t' has tyvars -> f :.: (arg t')
538 -- > _ -> Rec0 t
539 --
540 -- where @argVar@ is the last type variable in the data type declaration we are
541 -- finding the representation for.
542 --
543 -- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
544 -- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
545 -- @:.:@.
546 --
547 -- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
548 -- some data types. The problematic case is when @t@ is an application of a
549 -- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
550 -- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
551 -- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
552 -- representable1 checks have been relaxed, and others were moved to
553 -- @canDoGenerics1@.
554 argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
555 argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
556 ata_par1 = mkPar1, ata_rec1 = mkRec1,
557 ata_comp = mkComp}) =
558 -- mkRec0 is the default; use it if there is no interesting structure
559 -- (e.g. occurrences of parameters or recursive occurrences)
560 \t -> maybe (mkRec0 t) id $ go t where
561 go :: Type -> -- type to fold through
562 Maybe a -- the result (e.g. representation type), unless it's trivial
563 go t = isParam `mplus` isApp where
564
565 isParam = do -- handles parameters
566 t' <- getTyVar_maybe t
567 Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
568 else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
569
570 isApp = do -- handles applications
571 (phi, beta) <- tcSplitAppTy_maybe t
572
573 let interesting = argVar `elemVarSet` exactTyVarsOfType beta
574
575 -- Does it have no interesting structure to represent?
576 if not interesting then Nothing
577 else -- Is the argument the parameter? Special case for mkRec1.
578 if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
579 else mkComp phi `fmap` go beta -- It must be a composition.
580
581
582 tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
583 GenericKind_
584 -- The type to generate representation for
585 -> TyCon
586 -- Metadata datatypes to refer to
587 -> MetaTyCons
588 -- Generated representation0 type
589 -> TcM Type
590 tc_mkRepTy gk_ tycon metaDts =
591 do
592 d1 <- tcLookupTyCon d1TyConName
593 c1 <- tcLookupTyCon c1TyConName
594 s1 <- tcLookupTyCon s1TyConName
595 nS1 <- tcLookupTyCon noSelTyConName
596 rec0 <- tcLookupTyCon rec0TyConName
597 rec1 <- tcLookupTyCon rec1TyConName
598 par1 <- tcLookupTyCon par1TyConName
599 u1 <- tcLookupTyCon u1TyConName
600 v1 <- tcLookupTyCon v1TyConName
601 plus <- tcLookupTyCon sumTyConName
602 times <- tcLookupTyCon prodTyConName
603 comp <- tcLookupTyCon compTyConName
604 uAddr <- tcLookupTyCon uAddrTyConName
605 uChar <- tcLookupTyCon uCharTyConName
606 uDouble <- tcLookupTyCon uDoubleTyConName
607 uFloat <- tcLookupTyCon uFloatTyConName
608 uInt <- tcLookupTyCon uIntTyConName
609 uWord <- tcLookupTyCon uWordTyConName
610
611 let mkSum' a b = mkTyConApp plus [a,b]
612 mkProd a b = mkTyConApp times [a,b]
613 mkComp a b = mkTyConApp comp [a,b]
614 mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a
615 mkRec1 a = mkTyConApp rec1 [a]
616 mkPar1 = mkTyConTy par1
617 mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
618 mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon)
619 (null (dataConFieldLabels a))]
620 -- This field has no label
621 mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
622 -- This field has a label
623 mkS False d a = mkTyConApp s1 [d, a]
624
625 -- Sums and products are done in the same way for both Rep and Rep1
626 sumP [] = mkTyConTy v1
627 sumP l = ASSERT(length metaCTyCons == length l)
628 foldBal mkSum' [ mkC i d a
629 | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
630 -- The Bool is True if this constructor has labelled fields
631 prod :: Int -> [Type] -> Bool -> Type
632 prod i [] _ = ASSERT(length metaSTyCons > i)
633 ASSERT(length (metaSTyCons !! i) == 0)
634 mkTyConTy u1
635 prod i l b = ASSERT(length metaSTyCons > i)
636 ASSERT(length l == length (metaSTyCons !! i))
637 foldBal mkProd [ arg d t b
638 | (d,t) <- zip (metaSTyCons !! i) l ]
639
640 arg :: Type -> Type -> Bool -> Type
641 arg d t b = mkS b d $ case gk_ of
642 -- Here we previously used Par0 if t was a type variable, but we
643 -- realized that we can't always guarantee that we are wrapping-up
644 -- all type variables in Par0. So we decided to stop using Par0
645 -- altogether, and use Rec0 all the time.
646 Gen0_ -> mkRec0 t
647 Gen1_ argVar -> argPar argVar t
648 where
649 -- Builds argument represention for Rep1 (more complicated due to
650 -- the presence of composition).
651 argPar argVar = argTyFold argVar $ ArgTyAlg
652 {ata_rec0 = mkRec0, ata_par1 = mkPar1,
653 ata_rec1 = mkRec1, ata_comp = mkComp}
654
655
656 metaDTyCon = mkTyConTy (metaD metaDts)
657 metaCTyCons = map mkTyConTy (metaC metaDts)
658 metaSTyCons = map (map mkTyConTy) (metaS metaDts)
659
660 return (mkD tycon)
661
662 -- Given the TyCons for each URec-related type synonym, check to see if the
663 -- given type is an unlifted type that generics understands. If so, return
664 -- its representation type. Otherwise, return Rec0.
665 -- See Note [Generics and unlifted types]
666 mkBoxTy :: TyCon -- UAddr
667 -> TyCon -- UChar
668 -> TyCon -- UDouble
669 -> TyCon -- UFloat
670 -> TyCon -- UInt
671 -> TyCon -- UWord
672 -> TyCon -- Rec0
673 -> Type
674 -> Type
675 mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty
676 | ty == addrPrimTy = mkTyConTy uAddr
677 | ty == charPrimTy = mkTyConTy uChar
678 | ty == doublePrimTy = mkTyConTy uDouble
679 | ty == floatPrimTy = mkTyConTy uFloat
680 | ty == intPrimTy = mkTyConTy uInt
681 | ty == wordPrimTy = mkTyConTy uWord
682 | otherwise = mkTyConApp rec0 [ty]
683
684 --------------------------------------------------------------------------------
685 -- Meta-information
686 --------------------------------------------------------------------------------
687
688 data MetaTyCons = MetaTyCons { -- One meta datatype per datatype
689 metaD :: TyCon
690 -- One meta datatype per constructor
691 , metaC :: [TyCon]
692 -- One meta datatype per selector per constructor
693 , metaS :: [[TyCon]] }
694
695 instance Outputable MetaTyCons where
696 ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
697
698 metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
699 metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
700
701
702 -- Bindings for Datatype, Constructor, and Selector instances
703 mkBindsMetaD :: FixityEnv -> TyCon
704 -> ( LHsBinds RdrName -- Datatype instance
705 , [LHsBinds RdrName] -- Constructor instances
706 , [[LHsBinds RdrName]]) -- Selector instances
707 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
708 where
709 mkBag l = foldr1 unionBags
710 [ unitBag (mkRdrFunBind (L loc name) matches)
711 | (name, matches) <- l ]
712 dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches)
713 , (moduleName_RDR, moduleName_matches)
714 , (packageName_RDR, pkgName_matches)]
715 ++ ifElseEmpty (isNewTyCon tycon)
716 [ (isNewtypeName_RDR, isNewtype_matches) ] )
717
718 allConBinds = map conBinds datacons
719 conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
720 ++ ifElseEmpty (dataConIsInfix c)
721 [ (conFixity_RDR, conFixity_matches c) ]
722 ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
723 [ (conIsRecord_RDR, conIsRecord_matches c) ]
724 )
725
726 ifElseEmpty p x = if p then x else []
727 fixity c = case lookupFixity fix_env (dataConName c) of
728 Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
729 Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
730 Fixity n InfixN -> buildFix n notAssocDataCon_RDR
731 buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
732 , nlHsIntLit (toInteger n)]
733
734 allSelBinds = map (map selBinds) datasels
735 selBinds s = mkBag [(selName_RDR, selName_matches s)]
736
737 loc = srcLocSpan (getSrcLoc tycon)
738 mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
739 datacons = tyConDataCons tycon
740 datasels = map (map flSelector . dataConFieldLabels) datacons
741
742 tyConName_user = case tyConFamInst_maybe tycon of
743 Just (ptycon, _) -> tyConName ptycon
744 Nothing -> tyConName tycon
745
746 dtName_matches = mkStringLHS . occNameString . nameOccName
747 $ tyConName_user
748 moduleName_matches = mkStringLHS . moduleNameString . moduleName
749 . nameModule . tyConName $ tycon
750 pkgName_matches = mkStringLHS . unitIdString . moduleUnitId
751 . nameModule . tyConName $ tycon
752 isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
753
754 conName_matches c = mkStringLHS . occNameString . nameOccName
755 . dataConName $ c
756 conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
757 conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
758
759 selName_matches s = mkStringLHS (occNameString (nameOccName s))
760
761
762 --------------------------------------------------------------------------------
763 -- Dealing with sums
764 --------------------------------------------------------------------------------
765
766 mkSum :: GenericKind_ -- Generic or Generic1?
767 -> US -- Base for generating unique names
768 -> TyCon -- The type constructor
769 -> [DataCon] -- The data constructors
770 -> ([Alt], -- Alternatives for the T->Trep "from" function
771 [Alt]) -- Alternatives for the Trep->T "to" function
772
773 -- Datatype without any constructors
774 mkSum _ _ tycon [] = ([from_alt], [to_alt])
775 where
776 from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
777 to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
778 -- These M1s are meta-information for the datatype
779 makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
780 tyConStr = occNameString (nameOccName (tyConName tycon))
781 errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
782 errMsgTo = "No values for empty datatype " ++ tyConStr
783
784 -- Datatype with at least one constructor
785 mkSum gk_ us _ datacons =
786 -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
787 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
788 | (d,i) <- zip datacons [1..] ]
789
790 -- Build the sum for a particular constructor
791 mk1Sum :: GenericKind_DC -- Generic or Generic1?
792 -> US -- Base for generating unique names
793 -> Int -- The index of this constructor
794 -> Int -- Total number of constructors
795 -> DataCon -- The data constructor
796 -> (Alt, -- Alternative for the T->Trep "from" function
797 Alt) -- Alternative for the Trep->T "to" function
798 mk1Sum gk_ us i n datacon = (from_alt, to_alt)
799 where
800 gk = forgetArgVar gk_
801
802 -- Existentials already excluded
803 argTys = dataConOrigArgTys datacon
804 n_args = dataConSourceArity datacon
805
806 datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
807 datacon_vars = map fst datacon_varTys
808 us' = us + n_args
809
810 datacon_rdr = getRdrName datacon
811
812 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
813 from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
814
815 to_alt = ( mkM1_P (genLR_P i n (mkProd_P gk us' datacon_varTys))
816 , to_alt_rhs
817 ) -- These M1s are meta-information for the datatype
818 to_alt_rhs = case gk_ of
819 Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
820 Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
821 where
822 argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
823 converter = argTyFold argVar $ ArgTyAlg
824 {ata_rec0 = nlHsVar . unboxRepRDR,
825 ata_par1 = nlHsVar unPar1_RDR,
826 ata_rec1 = const $ nlHsVar unRec1_RDR,
827 ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
828 `nlHsCompose` nlHsVar unComp1_RDR}
829
830
831 -- Generates the L1/R1 sum pattern
832 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
833 genLR_P i n p
834 | n == 0 = error "impossible"
835 | n == 1 = p
836 | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
837 | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
838 where m = div n 2
839
840 -- Generates the L1/R1 sum expression
841 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
842 genLR_E i n e
843 | n == 0 = error "impossible"
844 | n == 1 = e
845 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
846 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
847 where m = div n 2
848
849 --------------------------------------------------------------------------------
850 -- Dealing with products
851 --------------------------------------------------------------------------------
852
853 -- Build a product expression
854 mkProd_E :: GenericKind_DC -- Generic or Generic1?
855 -> US -- Base for unique names
856 -> [(RdrName, Type)] -- List of variables matched on the lhs and their types
857 -> LHsExpr RdrName -- Resulting product expression
858 mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
859 mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
860 -- These M1s are meta-information for the constructor
861 where
862 appVars = map (wrapArg_E gk_) varTys
863 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
864
865 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
866 wrapArg_E Gen0_DC (var, ty) = mkM1_E $
867 boxRepRDR ty `nlHsVarApps` [var]
868 -- This M1 is meta-information for the selector
869 wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
870 converter ty `nlHsApp` nlHsVar var
871 -- This M1 is meta-information for the selector
872 where converter = argTyFold argVar $ ArgTyAlg
873 {ata_rec0 = nlHsVar . boxRepRDR,
874 ata_par1 = nlHsVar par1DataCon_RDR,
875 ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
876 ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
877 (nlHsVar fmap_RDR `nlHsApp` cnv)}
878
879 boxRepRDR :: Type -> RdrName
880 boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
881
882 unboxRepRDR :: Type -> RdrName
883 unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
884
885 -- Retrieve the RDRs associated with each URec data family instance
886 -- constructor. See Note [Generics and unlifted types]
887 unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
888 unboxedRepRDRs ty
889 | ty == addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR)
890 | ty == charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR)
891 | ty == doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
892 | ty == floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR)
893 | ty == intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR)
894 | ty == wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR)
895 | otherwise = Nothing
896
897 -- Build a product pattern
898 mkProd_P :: GenericKind -- Gen0 or Gen1
899 -> US -- Base for unique names
900 -> [(RdrName, Type)] -- List of variables to match,
901 -- along with their types
902 -> LPat RdrName -- Resulting product pattern
903 mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
904 mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
905 -- These M1s are meta-information for the constructor
906 where
907 appVars = unzipWith (wrapArg_P gk) varTys
908 prod a b = prodDataCon_RDR `nlConPat` [a,b]
909
910 wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
911 wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
912 -- This M1 is meta-information for the selector
913 wrapArg_P Gen1 v _ = m1DataCon_RDR `nlConVarPat` [v]
914
915 mkGenericLocal :: US -> RdrName
916 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
917
918 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
919 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
920
921 mkM1_P :: LPat RdrName -> LPat RdrName
922 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
923
924 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
925 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
926
927 -- | Variant of foldr1 for producing balanced lists
928 foldBal :: (a -> a -> a) -> [a] -> a
929 foldBal op = foldBal' op (error "foldBal: empty list")
930
931 foldBal' :: (a -> a -> a) -> a -> [a] -> a
932 foldBal' _ x [] = x
933 foldBal' _ _ [y] = y
934 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
935 in foldBal' op x a `op` foldBal' op x b
936
937 {-
938 Note [Generics and unlifted types]
939 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
940 Normally, all constants are marked with K1/Rec0. The exception to this rule is
941 when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
942 that case, we must use a data family instance of URec (from GHC.Generics) to
943 mark it. As a result, before we can generate K1 or unK1, we must first check
944 to see if the type is actually one of the unlifted types for which URec has a
945 data family instance; if so, we generate that instead.
946
947 See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
948 details on why URec is implemented the way it is.
949 -}