649aa5fc991b8d7fbcf18e0b467a0b81256556a2
[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 #-}
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 )
29 import IfaceEnv ( newGlobalBinder )
30 import Name hiding ( varName )
31 import RdrName
32 import BasicTypes
33 import TysWiredIn
34 import PrelNames
35 import InstEnv
36 import TcEnv
37 import MkId
38 import TcRnMonad
39 import HscTypes
40 import ErrUtils( Validity(..), andValid )
41 import BuildTyCl
42 import SrcLoc
43 import Bag
44 import VarSet (elemVarSet)
45 import Outputable
46 import FastString
47 import Util
48
49 import Control.Monad (mplus,forM)
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 -> Module -> TcM (MetaTyCons, BagDerivStuff)
75 genGenericMetaTyCons tc mod =
76 do loc <- getSrcSpanM
77 let
78 tc_name = tyConName tc
79 tc_cons = tyConDataCons tc
80 tc_arits = map dataConSourceArity tc_cons
81
82 tc_occ = nameOccName tc_name
83 d_occ = mkGenD tc_occ
84 c_occ m = mkGenC tc_occ m
85 s_occ m n = mkGenS 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 d_name <- newGlobalBinder mod d_occ loc
95 c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
96 newGlobalBinder mod (c_occ m) loc
97 s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
98 newGlobalBinder mod (s_occ m n) loc
99
100 let metaDTyCon = mkTyCon d_name
101 metaCTyCons = map mkTyCon c_names
102 metaSTyCons = map (map mkTyCon) s_names
103
104 metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
105
106 -- pprTrace "rep0" (ppr rep0_tycon) $
107 (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
108
109 -- both the tycon declarations and related instances
110 metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
111 metaTyConsToDerivStuff tc metaDts =
112 do loc <- getSrcSpanM
113 dflags <- getDynFlags
114 dClas <- tcLookupClass datatypeClassName
115 let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
116 d_dfun_name <- new_dfun_name dClas tc
117 cClas <- tcLookupClass constructorClassName
118 c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
119 sClas <- tcLookupClass selectorClassName
120 s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
121 | _ <- x ]
122 | x <- metaS metaDts ])
123 fix_env <- getFixityEnv
124
125 let
126 (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
127 mk_inst clas tc dfun_name
128 = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
129 OverlapFlag { overlapMode = (NoOverlap "")
130 , isSafeOverlap = safeLanguageOn dflags }
131 [] clas tys
132 where
133 tys = [mkTyConTy tc]
134
135 -- Datatype
136 d_metaTycon = metaD metaDts
137 d_inst = mk_inst dClas d_metaTycon d_dfun_name
138 d_binds = InstBindings { ib_binds = dBinds
139 , ib_tyvars = []
140 , ib_pragmas = []
141 , ib_extensions = []
142 , ib_derived = True }
143 d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
144
145 -- Constructor
146 c_metaTycons = metaC metaDts
147 c_insts = [ mk_inst cClas c ds
148 | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
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_metaTycons = metaS metaDts
160 s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
161 (myZip2 s_metaTycons 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 "must not have unlifted or polymorphic arguments"))
284 else (if (not (isVanillaDataCon dc))
285 then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
286 else IsValid)
287
288 -- Nor can we do the job if it's an existential data constructor,
289 -- Nor if the args are polymorphic types (I don't think)
290 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
291
292 mergeErrors :: [Validity] -> Validity
293 mergeErrors [] = IsValid
294 mergeErrors (NotValid s:t) = case mergeErrors t of
295 IsValid -> NotValid s
296 NotValid s' -> NotValid (s <> text ", and" $$ s')
297 mergeErrors (IsValid : t) = mergeErrors t
298
299 -- A datatype used only inside of canDoGenerics1. It's the result of analysing
300 -- a type term.
301 data Check_for_CanDoGenerics1 = CCDG1
302 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in
303 -- this type?
304 , _ccdg1_errors :: Validity -- errors generated by this type
305 }
306
307 {-
308
309 Note [degenerate use of FFoldType]
310 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
311
312 We use foldDataConArgs here only for its ability to treat tuples
313 specially. foldDataConArgs also tracks covariance (though it assumes all
314 higher-order type parameters are covariant) and has hooks for special handling
315 of functions and polytypes, but we do *not* use those.
316
317 The key issue is that Generic1 deriving currently offers no sophisticated
318 support for functions. For example, we cannot handle
319
320 data F a = F ((a -> Int) -> Int)
321
322 even though a is occurring covariantly.
323
324 In fact, our rule is harsh: a is simply not allowed to occur within the first
325 argument of (->). We treat (->) the same as any other non-tuple tycon.
326
327 Unfortunately, this means we have to track "the parameter occurs in this type"
328 explicitly, even though foldDataConArgs is also doing this internally.
329
330 -}
331
332 -- canDoGenerics1 rep_tc tc_args determines if a Generic1/Rep1 can be derived
333 -- for a type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn).
334 --
335 -- Checks (a) through (d) from Note [Requirements for deriving Generic and Rep]
336 -- are taken care of by the call to canDoGenerics.
337 --
338 -- It returns Nothing if deriving is possible. It returns (Just reason) if not.
339 canDoGenerics1 :: TyCon -> [Type] -> Validity
340 canDoGenerics1 rep_tc tc_args =
341 canDoGenerics rep_tc tc_args `andValid` additionalChecks
342 where
343 additionalChecks
344 -- check (f) from Note [Requirements for deriving Generic and Rep]
345 | null (tyConTyVars rep_tc) = NotValid $
346 ptext (sLit "Data type") <+> quotes (ppr rep_tc)
347 <+> ptext (sLit "must have some type parameters")
348
349 | otherwise = mergeErrors $ concatMap check_con data_cons
350
351 data_cons = tyConDataCons rep_tc
352 check_con con = case check_vanilla con of
353 j@(NotValid {}) -> [j]
354 IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
355
356 bad :: DataCon -> SDoc -> SDoc
357 bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
358
359 check_vanilla :: DataCon -> Validity
360 check_vanilla con | isVanillaDataCon con = IsValid
361 | otherwise = NotValid (bad con existential)
362
363 bmzero = CCDG1 False IsValid
364 bmbad con s = CCDG1 True $ NotValid $ bad con s
365 bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
366
367 -- check (g) from Note [degenerate use of FFoldType]
368 ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
369 ft_check con = FT
370 { ft_triv = bmzero
371
372 , ft_var = caseVar, ft_co_var = caseVar
373
374 -- (component_0,component_1,...,component_n)
375 , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
376 then bmbad con wrong_arg
377 else foldr bmplus bmzero components
378
379 -- (dom -> rng), where the head of ty is not a tuple tycon
380 , ft_fun = \dom rng -> -- cf #8516
381 if _ccdg1_hasParam dom
382 then bmbad con wrong_arg
383 else bmplus dom rng
384
385 -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
386 -- the parameter of interest does not occur in ty
387 , ft_ty_app = \_ arg -> arg
388
389 , ft_bad_app = bmbad con wrong_arg
390 , ft_forall = \_ body -> body -- polytypes are handled elsewhere
391 }
392 where
393 caseVar = CCDG1 True IsValid
394
395
396 existential = text "must not have existential arguments"
397 wrong_arg = text "applies a type to an argument involving the last parameter"
398 $$ text "but the applied type is not of kind * -> *"
399
400 {-
401 ************************************************************************
402 * *
403 \subsection{Generating the RHS of a generic default method}
404 * *
405 ************************************************************************
406 -}
407
408 type US = Int -- Local unique supply, just a plain Int
409 type Alt = (LPat RdrName, LHsExpr RdrName)
410
411 -- GenericKind serves to mark if a datatype derives Generic (Gen0) or
412 -- Generic1 (Gen1).
413 data GenericKind = Gen0 | Gen1
414
415 -- as above, but with a payload of the TyCon's name for "the" parameter
416 data GenericKind_ = Gen0_ | Gen1_ TyVar
417
418 -- as above, but using a single datacon's name for "the" parameter
419 data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
420
421 forgetArgVar :: GenericKind_DC -> GenericKind
422 forgetArgVar Gen0_DC = Gen0
423 forgetArgVar Gen1_DC{} = Gen1
424
425 -- When working only within a single datacon, "the" parameter's name should
426 -- match that datacon's name for it.
427 gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
428 gk2gkDC Gen0_ _ = Gen0_DC
429 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
430
431
432
433 -- Bindings for the Generic instance
434 mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
435 mkBindsRep gk tycon =
436 unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
437 `unionBags`
438 unitBag (mkRdrFunBind (L loc to01_RDR) to_matches)
439 where
440 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
441 to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
442 loc = srcLocSpan (getSrcLoc tycon)
443 datacons = tyConDataCons tycon
444
445 (from01_RDR, to01_RDR) = case gk of
446 Gen0 -> (from_RDR, to_RDR)
447 Gen1 -> (from1_RDR, to1_RDR)
448
449 -- Recurse over the sum first
450 from_alts, to_alts :: [Alt]
451 (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons
452 where gk_ = case gk of
453 Gen0 -> Gen0_
454 Gen1 -> ASSERT(length tyvars >= 1)
455 Gen1_ (last tyvars)
456 where tyvars = tyConTyVars tycon
457
458 --------------------------------------------------------------------------------
459 -- The type synonym instance and synonym
460 -- type instance Rep (D a b) = Rep_D a b
461 -- type Rep_D a b = ...representation type for D ...
462 --------------------------------------------------------------------------------
463
464 tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
465 -> TyCon -- The type to generate representation for
466 -> MetaTyCons -- Metadata datatypes to refer to
467 -> Module -- Used as the location of the new RepTy
468 -> TcM (FamInst) -- Generated representation0 coercion
469 tc_mkRepFamInsts gk tycon metaDts mod =
470 -- Consider the example input tycon `D`, where data D a b = D_ a
471 -- Also consider `R:DInt`, where { data family D x y :: * -> *
472 -- ; data instance D Int a b = D_ a }
473 do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
474 fam_tc <- case gk of
475 Gen0 -> tcLookupTyCon repTyConName
476 Gen1 -> tcLookupTyCon rep1TyConName
477
478 ; let -- `tyvars` = [a,b]
479 (tyvars, gk_) = case gk of
480 Gen0 -> (all_tyvars, Gen0_)
481 Gen1 -> ASSERT(not $ null all_tyvars)
482 (init all_tyvars, Gen1_ $ last all_tyvars)
483 where all_tyvars = tyConTyVars tycon
484
485 tyvar_args = mkTyVarTys tyvars
486
487 appT :: [Type]
488 appT = case tyConFamInst_maybe tycon of
489 -- `appT` = D Int a b (data families case)
490 Just (famtycon, apps) ->
491 -- `fam` = D
492 -- `apps` = [Int, a, b]
493 let allApps = case gk of
494 Gen0 -> apps
495 Gen1 -> ASSERT(not $ null apps)
496 init apps
497 in [mkTyConApp famtycon allApps]
498 -- `appT` = D a b (normal case)
499 Nothing -> [mkTyConApp tycon tyvar_args]
500
501 -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
502 ; repTy <- tc_mkRepTy gk_ tycon metaDts
503
504 -- `rep_name` is a name we generate for the synonym
505 ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
506 in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
507 (nameSrcSpan (tyConName tycon))
508
509 ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy
510 ; newFamInst SynFamilyInst axiom }
511
512 --------------------------------------------------------------------------------
513 -- Type representation
514 --------------------------------------------------------------------------------
515
516 -- | See documentation of 'argTyFold'; that function uses the fields of this
517 -- type to interpret the structure of a type when that type is considered as an
518 -- argument to a constructor that is being represented with 'Rep1'.
519 data ArgTyAlg a = ArgTyAlg
520 { ata_rec0 :: (Type -> a)
521 , ata_par1 :: a, ata_rec1 :: (Type -> a)
522 , ata_comp :: (Type -> a -> a)
523 }
524
525 -- | @argTyFold@ implements a generalised and safer variant of the @arg@
526 -- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
527 -- is conceptually equivalent to:
528 --
529 -- > arg t = case t of
530 -- > _ | isTyVar t -> if (t == argVar) then Par1 else Par0 t
531 -- > App f [t'] |
532 -- > representable1 f &&
533 -- > t' == argVar -> Rec1 f
534 -- > App f [t'] |
535 -- > representable1 f &&
536 -- > t' has tyvars -> f :.: (arg t')
537 -- > _ -> Rec0 t
538 --
539 -- where @argVar@ is the last type variable in the data type declaration we are
540 -- finding the representation for.
541 --
542 -- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
543 -- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
544 -- @:.:@.
545 --
546 -- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
547 -- some data types. The problematic case is when @t@ is an application of a
548 -- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
549 -- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
550 -- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
551 -- representable1 checks have been relaxed, and others were moved to
552 -- @canDoGenerics1@.
553 argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
554 argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
555 ata_par1 = mkPar1, ata_rec1 = mkRec1,
556 ata_comp = mkComp}) =
557 -- mkRec0 is the default; use it if there is no interesting structure
558 -- (e.g. occurrences of parameters or recursive occurrences)
559 \t -> maybe (mkRec0 t) id $ go t where
560 go :: Type -> -- type to fold through
561 Maybe a -- the result (e.g. representation type), unless it's trivial
562 go t = isParam `mplus` isApp where
563
564 isParam = do -- handles parameters
565 t' <- getTyVar_maybe t
566 Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
567 else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
568
569 isApp = do -- handles applications
570 (phi, beta) <- tcSplitAppTy_maybe t
571
572 let interesting = argVar `elemVarSet` exactTyVarsOfType beta
573
574 -- Does it have no interesting structure to represent?
575 if not interesting then Nothing
576 else -- Is the argument the parameter? Special case for mkRec1.
577 if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
578 else mkComp phi `fmap` go beta -- It must be a composition.
579
580
581 tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
582 GenericKind_
583 -- The type to generate representation for
584 -> TyCon
585 -- Metadata datatypes to refer to
586 -> MetaTyCons
587 -- Generated representation0 type
588 -> TcM Type
589 tc_mkRepTy gk_ tycon metaDts =
590 do
591 d1 <- tcLookupTyCon d1TyConName
592 c1 <- tcLookupTyCon c1TyConName
593 s1 <- tcLookupTyCon s1TyConName
594 nS1 <- tcLookupTyCon noSelTyConName
595 rec0 <- tcLookupTyCon rec0TyConName
596 rec1 <- tcLookupTyCon rec1TyConName
597 par1 <- tcLookupTyCon par1TyConName
598 u1 <- tcLookupTyCon u1TyConName
599 v1 <- tcLookupTyCon v1TyConName
600 plus <- tcLookupTyCon sumTyConName
601 times <- tcLookupTyCon prodTyConName
602 comp <- tcLookupTyCon compTyConName
603
604 let mkSum' a b = mkTyConApp plus [a,b]
605 mkProd a b = mkTyConApp times [a,b]
606 mkComp a b = mkTyConApp comp [a,b]
607 mkRec0 a = mkTyConApp rec0 [a]
608 mkRec1 a = mkTyConApp rec1 [a]
609 mkPar1 = mkTyConTy par1
610 mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
611 mkC i d a = mkTyConApp c1 [d, prod i (dataConInstOrigArgTys a $ mkTyVarTys $ tyConTyVars tycon)
612 (null (dataConFieldLabels a))]
613 -- This field has no label
614 mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
615 -- This field has a label
616 mkS False d a = mkTyConApp s1 [d, a]
617
618 -- Sums and products are done in the same way for both Rep and Rep1
619 sumP [] = mkTyConTy v1
620 sumP l = ASSERT(length metaCTyCons == length l)
621 foldBal mkSum' [ mkC i d a
622 | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
623 -- The Bool is True if this constructor has labelled fields
624 prod :: Int -> [Type] -> Bool -> Type
625 prod i [] _ = ASSERT(length metaSTyCons > i)
626 ASSERT(length (metaSTyCons !! i) == 0)
627 mkTyConTy u1
628 prod i l b = ASSERT(length metaSTyCons > i)
629 ASSERT(length l == length (metaSTyCons !! i))
630 foldBal mkProd [ arg d t b
631 | (d,t) <- zip (metaSTyCons !! i) l ]
632
633 arg :: Type -> Type -> Bool -> Type
634 arg d t b = mkS b d $ case gk_ of
635 -- Here we previously used Par0 if t was a type variable, but we
636 -- realized that we can't always guarantee that we are wrapping-up
637 -- all type variables in Par0. So we decided to stop using Par0
638 -- altogether, and use Rec0 all the time.
639 Gen0_ -> mkRec0 t
640 Gen1_ argVar -> argPar argVar t
641 where
642 -- Builds argument represention for Rep1 (more complicated due to
643 -- the presence of composition).
644 argPar argVar = argTyFold argVar $ ArgTyAlg
645 {ata_rec0 = mkRec0, ata_par1 = mkPar1,
646 ata_rec1 = mkRec1, ata_comp = mkComp}
647
648
649 metaDTyCon = mkTyConTy (metaD metaDts)
650 metaCTyCons = map mkTyConTy (metaC metaDts)
651 metaSTyCons = map (map mkTyConTy) (metaS metaDts)
652
653 return (mkD tycon)
654
655 --------------------------------------------------------------------------------
656 -- Meta-information
657 --------------------------------------------------------------------------------
658
659 data MetaTyCons = MetaTyCons { -- One meta datatype per datatype
660 metaD :: TyCon
661 -- One meta datatype per constructor
662 , metaC :: [TyCon]
663 -- One meta datatype per selector per constructor
664 , metaS :: [[TyCon]] }
665
666 instance Outputable MetaTyCons where
667 ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
668
669 metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
670 metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
671
672
673 -- Bindings for Datatype, Constructor, and Selector instances
674 mkBindsMetaD :: FixityEnv -> TyCon
675 -> ( LHsBinds RdrName -- Datatype instance
676 , [LHsBinds RdrName] -- Constructor instances
677 , [[LHsBinds RdrName]]) -- Selector instances
678 mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
679 where
680 mkBag l = foldr1 unionBags
681 [ unitBag (mkRdrFunBind (L loc name) matches)
682 | (name, matches) <- l ]
683 dtBinds = mkBag ( [ (datatypeName_RDR, dtName_matches)
684 , (moduleName_RDR, moduleName_matches)
685 , (packageName_RDR, pkgName_matches)]
686 ++ ifElseEmpty (isNewTyCon tycon)
687 [ (isNewtypeName_RDR, isNewtype_matches) ] )
688
689 allConBinds = map conBinds datacons
690 conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
691 ++ ifElseEmpty (dataConIsInfix c)
692 [ (conFixity_RDR, conFixity_matches c) ]
693 ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
694 [ (conIsRecord_RDR, conIsRecord_matches c) ]
695 )
696
697 ifElseEmpty p x = if p then x else []
698 fixity c = case lookupFixity fix_env (dataConName c) of
699 Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
700 Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
701 Fixity n InfixN -> buildFix n notAssocDataCon_RDR
702 buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
703 , nlHsIntLit (toInteger n)]
704
705 allSelBinds = map (map selBinds) datasels
706 selBinds s = mkBag [(selName_RDR, selName_matches s)]
707
708 loc = srcLocSpan (getSrcLoc tycon)
709 mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
710 datacons = tyConDataCons tycon
711 datasels = map dataConFieldLabels datacons
712
713 tyConName_user = case tyConFamInst_maybe tycon of
714 Just (ptycon, _) -> tyConName ptycon
715 Nothing -> tyConName tycon
716
717 dtName_matches = mkStringLHS . occNameString . nameOccName
718 $ tyConName_user
719 moduleName_matches = mkStringLHS . moduleNameString . moduleName
720 . nameModule . tyConName $ tycon
721 pkgName_matches = mkStringLHS . packageKeyString . modulePackageKey
722 . nameModule . tyConName $ tycon
723 isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
724
725 conName_matches c = mkStringLHS . occNameString . nameOccName
726 . dataConName $ c
727 conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
728 conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
729
730 selName_matches s = mkStringLHS (occNameString (nameOccName s))
731
732
733 --------------------------------------------------------------------------------
734 -- Dealing with sums
735 --------------------------------------------------------------------------------
736
737 mkSum :: GenericKind_ -- Generic or Generic1?
738 -> US -- Base for generating unique names
739 -> TyCon -- The type constructor
740 -> [DataCon] -- The data constructors
741 -> ([Alt], -- Alternatives for the T->Trep "from" function
742 [Alt]) -- Alternatives for the Trep->T "to" function
743
744 -- Datatype without any constructors
745 mkSum _ _ tycon [] = ([from_alt], [to_alt])
746 where
747 from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
748 to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
749 -- These M1s are meta-information for the datatype
750 makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
751 tyConStr = occNameString (nameOccName (tyConName tycon))
752 errMsgFrom = "No generic representation for empty datatype " ++ tyConStr
753 errMsgTo = "No values for empty datatype " ++ tyConStr
754
755 -- Datatype with at least one constructor
756 mkSum gk_ us _ datacons =
757 -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
758 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
759 | (d,i) <- zip datacons [1..] ]
760
761 -- Build the sum for a particular constructor
762 mk1Sum :: GenericKind_DC -- Generic or Generic1?
763 -> US -- Base for generating unique names
764 -> Int -- The index of this constructor
765 -> Int -- Total number of constructors
766 -> DataCon -- The data constructor
767 -> (Alt, -- Alternative for the T->Trep "from" function
768 Alt) -- Alternative for the Trep->T "to" function
769 mk1Sum gk_ us i n datacon = (from_alt, to_alt)
770 where
771 gk = forgetArgVar gk_
772
773 -- Existentials already excluded
774 argTys = dataConOrigArgTys datacon
775 n_args = dataConSourceArity datacon
776
777 datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
778 datacon_vars = map fst datacon_varTys
779 us' = us + n_args
780
781 datacon_rdr = getRdrName datacon
782
783 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
784 from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
785
786 to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
787 -- These M1s are meta-information for the datatype
788 to_alt_rhs = case gk_ of
789 Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
790 Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
791 where
792 argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
793 converter = argTyFold argVar $ ArgTyAlg
794 {ata_rec0 = const $ nlHsVar unK1_RDR,
795 ata_par1 = nlHsVar unPar1_RDR,
796 ata_rec1 = const $ nlHsVar unRec1_RDR,
797 ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
798 `nlHsCompose` nlHsVar unComp1_RDR}
799
800
801
802 -- Generates the L1/R1 sum pattern
803 genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
804 genLR_P i n p
805 | n == 0 = error "impossible"
806 | n == 1 = p
807 | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
808 | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
809 where m = div n 2
810
811 -- Generates the L1/R1 sum expression
812 genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
813 genLR_E i n e
814 | n == 0 = error "impossible"
815 | n == 1 = e
816 | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
817 | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
818 where m = div n 2
819
820 --------------------------------------------------------------------------------
821 -- Dealing with products
822 --------------------------------------------------------------------------------
823
824 -- Build a product expression
825 mkProd_E :: GenericKind_DC -- Generic or Generic1?
826 -> US -- Base for unique names
827 -> [(RdrName, Type)] -- List of variables matched on the lhs and their types
828 -> LHsExpr RdrName -- Resulting product expression
829 mkProd_E _ _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
830 mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
831 -- These M1s are meta-information for the constructor
832 where
833 appVars = map (wrapArg_E gk_) varTys
834 prod a b = prodDataCon_RDR `nlHsApps` [a,b]
835
836 wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
837 wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
838 -- This M1 is meta-information for the selector
839 wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
840 -- This M1 is meta-information for the selector
841 where converter = argTyFold argVar $ ArgTyAlg
842 {ata_rec0 = const $ nlHsVar k1DataCon_RDR,
843 ata_par1 = nlHsVar par1DataCon_RDR,
844 ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
845 ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
846 (nlHsVar fmap_RDR `nlHsApp` cnv)}
847
848
849
850 -- Build a product pattern
851 mkProd_P :: GenericKind -- Gen0 or Gen1
852 -> US -- Base for unique names
853 -> [RdrName] -- List of variables to match
854 -> LPat RdrName -- Resulting product pattern
855 mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
856 mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
857 -- These M1s are meta-information for the constructor
858 where
859 appVars = map (wrapArg_P gk) vars
860 prod a b = prodDataCon_RDR `nlConPat` [a,b]
861
862 wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
863 wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
864 -- This M1 is meta-information for the selector
865 wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
866
867 mkGenericLocal :: US -> RdrName
868 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
869
870 mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
871 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
872
873 mkM1_P :: LPat RdrName -> LPat RdrName
874 mkM1_P p = m1DataCon_RDR `nlConPat` [p]
875
876 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
877 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
878
879 -- | Variant of foldr1 for producing balanced lists
880 foldBal :: (a -> a -> a) -> [a] -> a
881 foldBal op = foldBal' op (error "foldBal: empty list")
882
883 foldBal' :: (a -> a -> a) -> a -> [a] -> a
884 foldBal' _ x [] = x
885 foldBal' _ _ [y] = y
886 foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
887 in foldBal' op x a `op` foldBal' op x b