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
343 ----------------------------------------------------
344 -- Dealing with products
345 ----------------------------------------------------
346 mk_prod_stuff :: Int -- Base for unique names
347 -> [Id] -- arg-ids; args of the original user-defined constructor
348 -- They are bound enclosing from_rhs
349 -- Please bind these in the to_body_fn
350 -> (Int, -- Depleted unique-name supply
351 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
352 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
353 Id) -- The rep-id; please bind this to the representation
356 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
357 -- \x -> case abc of { a :*: bc ->
358 -- case bc of { b :*: c ->
362 -- We need to use different uqiques in the branches
363 -- because the returned to_body_fns are nested.
364 -- Hence the returned unqique-name supply
366 mk_prod_stuff i [] -- Unit case
368 Var (dataConWrapId genUnitDataCon),
370 mkTemplateLocal i (mkTyConApp genUnitTyCon []))
372 mk_prod_stuff i [arg_var] -- Singleton case
373 = (i, Var arg_var, \x -> x, arg_var)
375 mk_prod_stuff i arg_vars -- Two or more
377 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
378 \x -> Case (Var rep_var) rep_var
379 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
382 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
383 (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
384 (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
385 rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
386 rep_tys = [idType l_rep_var, idType r_rep_var]
389 A little utility function
392 splitInHalf :: [a] -> ([a],[a])
393 splitInHalf list = (left, right)
395 half = length list `div` 2
396 left = take half list
397 right = drop half list
400 %************************************************************************
402 \subsection{Generating the RHS of a generic default method}
404 %************************************************************************
406 Generating the Generic default method. Uses the bimaps to generate the
407 actual method. All of this is rather incomplete, but it would be nice
408 to make even this work. Example
415 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
418 op = <mkGenericRhs op a T>
420 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
422 toOp :: Op Trep -> Op T
423 fromOp :: Op T -> Op Trep
425 (the bimap) and then fill in the RHS with
430 Remember, we're generating a RenamedHsExpr, so the result of all this
431 will be fed to the type checker. So the 'op' on the RHS will be
432 at the representation type for T, Trep.
435 A note about polymorphism. Suppose the class op is polymorphic:
438 op :: forall b. Ord b => a -> b -> b
440 Then we can still generate a bimap with
442 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
444 and fill in the instance decl thus
449 By the time the type checker has done its stuff we'll get
452 op = \b. \dict::Ord b. toOp b (op Trep b dict)
455 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
456 mkGenericRhs sel_id tyvar tycon
457 = HsApp (toEP bimap) (HsVar (idName sel_id))
459 -- Initialising the "Environment" with the from/to functions
460 -- on the datatype (actually tycon) in question
461 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
462 ep = EP (HsVar (idName from)) (HsVar (idName to))
464 -- Takes out the ForAll and the Class restrictions
465 -- in front of the type of the method.
466 (_,_,op_ty) = splitSigmaTy (idType sel_id)
468 -- Do it again! This deals with the case where the method type
469 -- is polymorphic -- see notes above
470 (local_tvs,_,final_ty) = splitSigmaTy op_ty
472 -- Now we probably have a tycon in front
473 -- of us, quite probably a FunTyCon.
474 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
476 type EPEnv = (TyVar, -- The class type variable
477 EP RenamedHsExpr, -- The EP it maps to
478 [TyVar] -- Other in-scope tyvars; they have an identity EP
482 generate_bimap :: EPEnv
485 -- Top level case - splitting the TyCon.
486 generate_bimap env@(tv,ep,local_tvs) ty
487 = case getTyVar_maybe ty of
488 Just tv1 | tv == tv1 -> ep -- The class tyvar
489 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
491 Nothing -> bimapApp env (splitTyConApp_maybe ty)
494 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
495 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
496 bimapApp env (Just (tycon, ty_args))
497 | tycon == funTyCon = bimapArrow arg_eps
498 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
499 | otherwise = -- Otherwise validGenericMethodType will
500 -- have checked that the type is a constant type
501 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
504 arg_eps = map (generate_bimap env) ty_args
505 (_,_,local_tvs) = env
508 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
509 bimapArrow [ep1, ep2]
510 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
511 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
513 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
514 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
518 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
519 toEP = mk_hs_lam [tuple_pat] to_body }
521 names = take (length eps) genericNames
522 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
523 eps_w_names = eps `zip` names
524 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
525 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
528 genericNames :: [Name]
529 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
530 (g1:g2:g3:_) = genericNames
532 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
534 idEP :: EP RenamedHsExpr
535 idEP = EP idexpr idexpr
537 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)