2 module Generics ( mkTyConGenInfo, mkGenericRhs,
3 validGenericInstanceType, validGenericMethodType
7 import RnHsSyn ( RenamedHsExpr )
8 import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
10 import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
11 mkTyVarTys, mkForAllTys, mkTyConApp,
12 mkFunTy, isTyVarTy, getTyVar_maybe,
13 splitSigmaTy, splitTyConApp_maybe, funTyCon
16 import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
18 import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable,
19 tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
21 import Name ( Name, mkSysLocalName )
22 import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
23 mkConApp, Alt, mkTyApps, mkVarApps )
24 import BasicTypes ( EP(..), Boxity(..) )
26 import VarSet ( varSetElems )
27 import Id ( Id, mkVanillaGlobal, idType, idName,
28 mkTemplateLocal, mkTemplateLocalsNum
30 import TysWiredIn ( genericTyCons,
31 genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
32 inlDataCon, crossTyCon, crossDataCon
34 import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo )
35 import CoreUnfold ( mkTopUnfolding )
37 import Unique ( mkBuiltinUnique )
38 import SrcLoc ( builtinSrcLoc )
39 import Maybes ( expectJust )
42 #include "HsVersions.h"
45 Roadmap of what's where in the Generics work.
46 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
52 Checks that HsNumTy has a "1" in it.
54 TcInstDcls.mkGenericInstance:
55 Checks for invalid type patterns, such as f {| Int |}
58 Checks for a method type that is too complicated;
59 e.g. has for-alls or lists in it
60 We could lift this restriction
62 TcClassDecl.mkDefMethRhs
63 Checks that the instance type is simple, in an instance decl
64 where we let the compiler fill in a generic method.
65 e.g. instance C (T Int)
66 is not valid if C has generic methods.
68 TcClassDecl.checkGenericClassIsUnary
69 Checks that we don't have generic methods in a multi-parameter class
71 TcClassDecl.checkDefaultBinds
72 Checks that all the equations for a method in a class decl
73 are generic, or all are non-generic
77 Checking that the type constructors which are present in Generic
78 patterns (not Unit, this is done differently) is done in mk_inst_info
79 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
80 HsOpTy is tied to Generic definitions which is not a very good design
81 feature, indeed a bug. However, the check is easy to move from
82 tcHsType back to mk_inst_info and everything will be fine. Also see
87 Making generic information to put into a tycon. Constructs the
88 representation type, which, I think, are not used later. Perhaps it is
89 worth removing them from the GI datatype. Although it does get used in
90 the construction of conversion functions (internally).
94 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
98 Defines generic and other type and data constructors.
100 This is sadly incomplete, but will be added to.
103 Bugs & shortcomings of existing implementation:
104 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
106 2. Another pretty big bug I dscovered at the last minute when I was
107 testing the code is that at the moment the type variable of the class
108 is scoped over the entire declaration, including the patterns. For
109 instance, if I have the following code,
113 er {| Plus a b |} (Inl x) (Inl y) = er x y
114 er {| Plus a b |} (Inr x) (Inr y) = er x y
115 er {| Plus a b |} _ _ = False
117 and I print out the types of the generic patterns, I get the
118 following. Note that all the variable names for "a" are the same,
119 while for "b" they are all different.
122 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
123 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
124 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
126 This is a bug as if I change the code to
128 er {| Plus c b |} (Inl x) (Inl y) = er x y
130 all the names come out to be different.
132 Thus, all the types (Plus a b) come out to be different, so I cannot
133 compare them and test whether they are all the same and thus cannot
134 return an error if the type variables are different.
136 Temporary fix/hack. I am not checking for this, I just assume they are
137 the same, see line "check_ty = True" in TcInstDecls. When we resolve
138 the issue with variables, though - I assume that we will make them to
139 be the same in all the type patterns, jus uncomment the check and
140 everything should work smoothly.
142 Hence, I have also left the rather silly construction of:
143 * extracting all the type variables from all the types
144 * putting them *all* into the environment
145 * typechecking all the types
146 * selecting one of them and using it as the instance_ty.
148 (the alternative is to make sure that all the types are the same,
149 taking one, extracting its variables, putting them into the environment,
150 type checking it, using it as the instance_ty)
152 6. What happens if we do not supply all of the generic patterns? At
153 the moment, the compiler crashes with an error message "Non-exhaustive
154 patterns in a generic declaration"
157 What has not been addressed:
158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
160 Contexts. In the generated instance declarations for the 3 primitive
161 type constructors, we need contexts. It is unclear what those should
162 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
164 Type application. We have type application in expressions
165 (essentially) on the lhs of an equation. Do we want to allow it on the
168 Scoping of type variables in a generic definition. At the moment, (see
169 TcInstDecls) we extract the type variables inside the type patterns
170 and add them to the environment. See my bug #2 above. This seems pretty
175 %************************************************************************
177 \subsection{Getting the representation type out}
179 %************************************************************************
182 validGenericInstanceType :: Type -> Bool
183 -- Checks for validity of the type pattern in a generic
184 -- declaration. It's ok to have
186 -- but it's not OK to have
189 validGenericInstanceType inst_ty
190 = case splitTyConApp_maybe inst_ty of
191 Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
194 validGenericMethodType :: Type -> Bool
195 -- At the moment we only allow method types built from
199 -- * an arbitrary type not involving the class type variables
200 -- e.g. this is ok: forall b. Ord b => [b] -> a
201 -- where a is the class variable
202 validGenericMethodType ty
205 (local_tvs, _, tau) = splitSigmaTy ty
208 | isTyVarTy ty = True
209 | no_tyvars_in_ty = True
210 | otherwise = case splitTyConApp_maybe ty of
211 Just (tc,tys) -> valid_tycon tc && all valid tys
214 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
216 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
217 -- Compare bimapApp, below
221 %************************************************************************
223 \subsection{Generating representation types}
225 %************************************************************************
228 mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
229 -- mkTyConGenInfo is called twice
230 -- once from TysWiredIn for Tuples
231 -- once the typechecker TcTyDecls
232 -- to generate generic types and conversion functions for all datatypes.
234 -- Must only be called with an algebraic type.
236 -- The two names are the names constructed by the renamer
237 -- for the fromT and toT conversion functions.
239 mkTyConGenInfo tycon [from_name, to_name]
240 | null datacons -- Abstractly imported types don't have
241 = Nothing -- to/from operations, (and should not need them)
243 -- If any of the constructor has an unboxed type as argument,
244 -- then we can't build the embedding-projection pair, because
245 -- it relies on instantiating *polymorphic* sum and product types
246 -- at the argument types of the constructors
247 -- Nor can we do the job if it's an existential data constructor,
248 | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
253 = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
254 toEP = mkVanillaGlobal to_name to_ty to_id_info })
256 tyvars = tyConTyVars tycon -- [a, b, c]
257 datacons = tyConDataConsIfAvailable tycon -- [C, D]
258 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
259 tyvar_tys = mkTyVarTys tyvars
261 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
262 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
264 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
265 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
267 (from_fn, to_fn, rep_ty)
269 = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x),
270 Var (dataConWrapId the_datacon),
274 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
275 mkLams tyvars $ Lam rep_var to_inner,
279 x = mkTemplateLocal 1 tycon_ty
281 ----------------------
283 [the_datacon] = datacons
284 newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
286 ----------------------
288 -- Recurse over the sum first
289 -- The "2" is the first free unique
290 (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
294 ----------------------------------------------------
296 ----------------------------------------------------
297 mk_sum_stuff :: Int -- Base for generating unique names
298 -> [TyVar] -- Type variables over which the tycon is abstracted
299 -> [DataCon] -- The data constructors
300 -> ([Alt Id], CoreExpr, Id)
302 -- For example, given
303 -- data T = C | D Int Int Int
305 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
306 -- case cd of { Inl u -> C;
307 -- Inr abc -> case abc of { a :*: bc ->
308 -- case bc of { b :*: c ->
312 mk_sum_stuff i tyvars [datacon]
313 = ([from_alt], to_body_fn app_exp, rep_var)
315 types = dataConOrigArgTys datacon
316 datacon_vars = mkTemplateLocalsNum i types
317 new_i = i + length types
318 app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
319 from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
321 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
323 mk_sum_stuff i tyvars datacons
324 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
325 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
326 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
329 (l_datacons, r_datacons) = splitInHalf datacons
330 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
331 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
332 rep_tys = [idType l_rep_var, idType r_rep_var]
333 rep_ty = mkTyConApp plusTyCon rep_tys
334 rep_var = mkTemplateLocal i rep_ty
336 wrap :: DataCon -> [Alt Id] -> [Alt Id]
337 -- Wrap an application of the Inl or Inr constructor round each alternative
339 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
341 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
344 -- This constructs the c_of datatype from a DataCon and a Type
345 -- The identity function at the moment.
346 cOfConstr :: DataCon -> Type -> Type
350 ----------------------------------------------------
351 -- Dealing with products
352 ----------------------------------------------------
353 mk_prod_stuff :: Int -- Base for unique names
354 -> [Id] -- arg-ids; args of the original user-defined constructor
355 -- They are bound enclosing from_rhs
356 -- Please bind these in the to_body_fn
357 -> (Int, -- Depleted unique-name supply
358 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
359 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
360 Id) -- The rep-id; please bind this to the representation
363 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
364 -- \x -> case abc of { a :*: bc ->
365 -- case bc of { b :*: c ->
369 -- We need to use different uqiques in the branches
370 -- because the returned to_body_fns are nested.
371 -- Hence the returned unqique-name supply
373 mk_prod_stuff i [] -- Unit case
375 Var (dataConWrapId genUnitDataCon),
377 mkTemplateLocal i (mkTyConApp genUnitTyCon []))
379 mk_prod_stuff i [arg_var] -- Singleton case
380 = (i, Var arg_var, \x -> x, arg_var)
382 mk_prod_stuff i arg_vars -- Two or more
384 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
385 \x -> Case (Var rep_var) rep_var
386 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
389 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
390 (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
391 (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
392 rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
393 rep_tys = [idType l_rep_var, idType r_rep_var]
396 A little utility function
399 splitInHalf :: [a] -> ([a],[a])
400 splitInHalf list = (left, right)
402 half = length list `div` 2
403 left = take half list
404 right = drop half list
407 %************************************************************************
409 \subsection{Generating the RHS of a generic default method}
411 %************************************************************************
413 Generating the Generic default method. Uses the bimaps to generate the
414 actual method. All of this is rather incomplete, but it would be nice
415 to make even this work. Example
422 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
425 op = <mkGenericRhs op a T>
427 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
429 toOp :: Op Trep -> Op T
430 fromOp :: Op T -> Op Trep
432 (the bimap) and then fill in the RHS with
437 Remember, we're generating a RenamedHsExpr, so the result of all this
438 will be fed to the type checker. So the 'op' on the RHS will be
439 at the representation type for T, Trep.
442 A note about polymorphism. Suppose the class op is polymorphic:
445 op :: forall b. Ord b => a -> b -> b
447 Then we can still generate a bimap with
449 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
451 and fill in the instance decl thus
456 By the time the type checker has done its stuff we'll get
459 op = \b. \dict::Ord b. toOp b (op Trep b dict)
462 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
463 mkGenericRhs sel_id tyvar tycon
464 = HsApp (toEP bimap) (HsVar (idName sel_id))
466 -- Initialising the "Environment" with the from/to functions
467 -- on the datatype (actually tycon) in question
468 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
469 ep = EP (HsVar (idName from)) (HsVar (idName to))
471 -- Takes out the ForAll and the Class restrictions
472 -- in front of the type of the method.
473 (_,_,op_ty) = splitSigmaTy (idType sel_id)
475 -- Do it again! This deals with the case where the method type
476 -- is polymorphic -- see notes above
477 (local_tvs,_,final_ty) = splitSigmaTy op_ty
479 -- Now we probably have a tycon in front
480 -- of us, quite probably a FunTyCon.
481 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
483 type EPEnv = (TyVar, -- The class type variable
484 EP RenamedHsExpr, -- The EP it maps to
485 [TyVar] -- Other in-scope tyvars; they have an identity EP
489 generate_bimap :: EPEnv
492 -- Top level case - splitting the TyCon.
493 generate_bimap env@(tv,ep,local_tvs) ty
494 = case getTyVar_maybe ty of
495 Just tv1 | tv == tv1 -> ep -- The class tyvar
496 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
498 Nothing -> bimapApp env (splitTyConApp_maybe ty)
501 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
502 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
503 bimapApp env (Just (tycon, ty_args))
504 | tycon == funTyCon = bimapArrow arg_eps
505 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
506 | otherwise = -- Otherwise validGenericMethodType will
507 -- have checked that the type is a constant type
508 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
511 arg_eps = map (generate_bimap env) ty_args
512 (_,_,local_tvs) = env
515 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
516 bimapArrow [ep1, ep2]
517 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
518 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
520 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
521 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
525 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
526 toEP = mk_hs_lam [tuple_pat] to_body }
528 names = take (length eps) genericNames
529 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
530 eps_w_names = eps `zip` names
531 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
532 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
535 genericNames :: [Name]
536 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
537 (g1:g2:g3:_) = genericNames
539 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
541 idEP :: EP RenamedHsExpr
542 idEP = EP idexpr idexpr
544 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)