2 module Generics ( mkTyConGenInfo, mkGenericRhs,
3 validGenericInstanceType, validGenericMethodType
7 import RnHsSyn ( RenamedHsExpr )
8 import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
10 import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
11 mkTyVarTys, mkForAllTys, mkTyConApp,
12 mkFunTy, isTyVarTy, getTyVar_maybe,
15 import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
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(..),
23 mkConApp, Alt, mkTyApps, mkVarApps )
24 import CoreUtils ( exprArity )
25 import BasicTypes ( EP(..), Boxity(..) )
27 import VarSet ( varSetElems )
28 import Id ( Id, mkVanillaGlobal, idType, idName,
29 mkTemplateLocal, mkTemplateLocalsNum
31 import TysWiredIn ( genericTyCons,
32 genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
33 inlDataCon, crossTyCon, crossDataCon
35 import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
36 import CoreUnfold ( mkTopUnfolding )
38 import SrcLoc ( builtinSrcLoc )
39 import Unique ( mkBuiltinUnique )
40 import Util ( takeList )
43 #include "HsVersions.h"
46 Roadmap of what's where in the Generics work.
47 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
53 Checks that HsNumTy has a "1" in it.
55 TcInstDcls.mkGenericInstance:
56 Checks for invalid type patterns, such as f {| Int |}
59 Checks for a method type that is too complicated;
60 e.g. has for-alls or lists in it
61 We could lift this restriction
63 TcClassDecl.mkDefMethRhs
64 Checks that the instance type is simple, in an instance decl
65 where we let the compiler fill in a generic method.
66 e.g. instance C (T Int)
67 is not valid if C has generic methods.
69 TcClassDecl.checkGenericClassIsUnary
70 Checks that we don't have generic methods in a multi-parameter class
72 TcClassDecl.checkDefaultBinds
73 Checks that all the equations for a method in a class decl
74 are generic, or all are non-generic
78 Checking that the type constructors which are present in Generic
79 patterns (not Unit, this is done differently) is done in mk_inst_info
80 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
81 HsOpTy is tied to Generic definitions which is not a very good design
82 feature, indeed a bug. However, the check is easy to move from
83 tcHsType back to mk_inst_info and everything will be fine. Also see
88 Making generic information to put into a tycon. Constructs the
89 representation type, which, I think, are not used later. Perhaps it is
90 worth removing them from the GI datatype. Although it does get used in
91 the construction of conversion functions (internally).
95 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
99 Defines generic and other type and data constructors.
101 This is sadly incomplete, but will be added to.
104 Bugs & shortcomings of existing implementation:
105 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107 2. Another pretty big bug I dscovered at the last minute when I was
108 testing the code is that at the moment the type variable of the class
109 is scoped over the entire declaration, including the patterns. For
110 instance, if I have the following code,
114 er {| Plus a b |} (Inl x) (Inl y) = er x y
115 er {| Plus a b |} (Inr x) (Inr y) = er x y
116 er {| Plus a b |} _ _ = False
118 and I print out the types of the generic patterns, I get the
119 following. Note that all the variable names for "a" are the same,
120 while for "b" they are all different.
123 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
124 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
125 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
127 This is a bug as if I change the code to
129 er {| Plus c b |} (Inl x) (Inl y) = er x y
131 all the names come out to be different.
133 Thus, all the types (Plus a b) come out to be different, so I cannot
134 compare them and test whether they are all the same and thus cannot
135 return an error if the type variables are different.
137 Temporary fix/hack. I am not checking for this, I just assume they are
138 the same, see line "check_ty = True" in TcInstDecls. When we resolve
139 the issue with variables, though - I assume that we will make them to
140 be the same in all the type patterns, jus uncomment the check and
141 everything should work smoothly.
143 Hence, I have also left the rather silly construction of:
144 * extracting all the type variables from all the types
145 * putting them *all* into the environment
146 * typechecking all the types
147 * selecting one of them and using it as the instance_ty.
149 (the alternative is to make sure that all the types are the same,
150 taking one, extracting its variables, putting them into the environment,
151 type checking it, using it as the instance_ty)
153 6. What happens if we do not supply all of the generic patterns? At
154 the moment, the compiler crashes with an error message "Non-exhaustive
155 patterns in a generic declaration"
158 What has not been addressed:
159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
161 Contexts. In the generated instance declarations for the 3 primitive
162 type constructors, we need contexts. It is unclear what those should
163 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
165 Type application. We have type application in expressions
166 (essentially) on the lhs of an equation. Do we want to allow it on the
169 Scoping of type variables in a generic definition. At the moment, (see
170 TcInstDecls) we extract the type variables inside the type patterns
171 and add them to the environment. See my bug #2 above. This seems pretty
176 %************************************************************************
178 \subsection{Getting the representation type out}
180 %************************************************************************
183 validGenericInstanceType :: Type -> Bool
184 -- Checks for validity of the type pattern in a generic
185 -- declaration. It's ok to have
187 -- but it's not OK to have
190 validGenericInstanceType inst_ty
191 = case tcSplitTyConApp_maybe inst_ty of
192 Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
195 validGenericMethodType :: Type -> Bool
196 -- At the moment we only allow method types built from
200 -- * an arbitrary type not involving the class type variables
201 -- e.g. this is ok: forall b. Ord b => [b] -> a
202 -- where a is the class variable
203 validGenericMethodType ty
206 (local_tvs, _, tau) = tcSplitSigmaTy ty
209 | isTyVarTy ty = True
210 | no_tyvars_in_ty = True
211 | otherwise = case tcSplitTyConApp_maybe ty of
212 Just (tc,tys) -> valid_tycon tc && all valid tys
215 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
217 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
218 -- Compare bimapApp, below
222 %************************************************************************
224 \subsection{Generating representation types}
226 %************************************************************************
229 mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
230 -- mkTyConGenInfo is called twice
231 -- once from TysWiredIn for Tuples
232 -- once the typechecker TcTyDecls
233 -- to generate generic types and conversion functions for all datatypes.
235 -- Must only be called with an algebraic type.
237 -- The two names are the names constructed by the renamer
238 -- for the fromT and toT conversion functions.
240 mkTyConGenInfo tycon [from_name, to_name]
241 | null datacons -- Abstractly imported types don't have
242 = Nothing -- to/from operations, (and should not need them)
244 -- If any of the constructor has an unboxed type as argument,
245 -- then we can't build the embedding-projection pair, because
246 -- it relies on instantiating *polymorphic* sum and product types
247 -- at the argument types of the constructors
248 -- Nor can we do the job if it's an existential data constructor,
249 | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
254 = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
255 toEP = mkVanillaGlobal to_name to_ty to_id_info })
257 tyvars = tyConTyVars tycon -- [a, b, c]
258 datacons = tyConDataConsIfAvailable tycon -- [C, D]
259 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
260 tyvar_tys = mkTyVarTys tyvars
262 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
263 `setArityInfo` exprArity from_fn
264 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
265 `setArityInfo` exprArity to_fn
266 -- It's important to set the arity info, so that
267 -- the calling convention (gotten from arity)
270 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
271 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
273 (from_fn, to_fn, rep_ty)
275 = ( mkLams tyvars $ Lam x $ Var x,
276 Var (dataConWrapId the_datacon),
280 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
281 mkLams tyvars $ Lam rep_var to_inner,
285 x = mkTemplateLocal 1 tycon_ty
287 ----------------------
289 [the_datacon] = datacons
290 (_, newrep_ty) = newTyConRep tycon
292 ----------------------
294 -- Recurse over the sum first
295 -- The "2" is the first free unique
296 (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
300 ----------------------------------------------------
302 ----------------------------------------------------
303 mk_sum_stuff :: Int -- Base for generating unique names
304 -> [TyVar] -- Type variables over which the tycon is abstracted
305 -> [DataCon] -- The data constructors
306 -> ([Alt Id], CoreExpr, Id)
308 -- For example, given
309 -- data T = C | D Int Int Int
311 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
312 -- case cd of { Inl u -> C;
313 -- Inr abc -> case abc of { a :*: bc ->
314 -- case bc of { b :*: c ->
318 mk_sum_stuff i tyvars [datacon]
319 = ([from_alt], to_body_fn app_exp, rep_var)
321 types = dataConOrigArgTys datacon
322 datacon_vars = mkTemplateLocalsNum i types
323 new_i = i + length types
324 app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
325 from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
327 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
329 mk_sum_stuff i tyvars datacons
330 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
331 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
332 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
335 (l_datacons, r_datacons) = splitInHalf datacons
336 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
337 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
338 rep_tys = [idType l_rep_var, idType r_rep_var]
339 rep_ty = mkTyConApp plusTyCon rep_tys
340 rep_var = mkTemplateLocal i rep_ty
342 wrap :: DataCon -> [Alt Id] -> [Alt Id]
343 -- Wrap an application of the Inl or Inr constructor round each alternative
345 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
347 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
349 ----------------------------------------------------
350 -- Dealing with products
351 ----------------------------------------------------
352 mk_prod_stuff :: Int -- Base for unique names
353 -> [Id] -- arg-ids; args of the original user-defined constructor
354 -- They are bound enclosing from_rhs
355 -- Please bind these in the to_body_fn
356 -> (Int, -- Depleted unique-name supply
357 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
358 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
359 Id) -- The rep-id; please bind this to the representation
362 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
363 -- \x -> case abc of { a :*: bc ->
364 -- case bc of { b :*: c ->
368 -- We need to use different uqiques in the branches
369 -- because the returned to_body_fns are nested.
370 -- Hence the returned unqique-name supply
372 mk_prod_stuff i [] -- Unit case
374 Var (dataConWrapId genUnitDataCon),
376 mkTemplateLocal i (mkTyConApp genUnitTyCon []))
378 mk_prod_stuff i [arg_var] -- Singleton case
379 = (i, Var arg_var, \x -> x, arg_var)
381 mk_prod_stuff i arg_vars -- Two or more
383 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
384 \x -> Case (Var rep_var) rep_var
385 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
388 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
389 (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
390 (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
391 rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
392 rep_tys = [idType l_rep_var, idType r_rep_var]
395 A little utility function
398 splitInHalf :: [a] -> ([a],[a])
399 splitInHalf list = (left, right)
401 half = length list `div` 2
402 left = take half list
403 right = drop half list
406 %************************************************************************
408 \subsection{Generating the RHS of a generic default method}
410 %************************************************************************
412 Generating the Generic default method. Uses the bimaps to generate the
413 actual method. All of this is rather incomplete, but it would be nice
414 to make even this work. Example
421 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
424 op = <mkGenericRhs op a T>
426 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
428 toOp :: Op Trep -> Op T
429 fromOp :: Op T -> Op Trep
431 (the bimap) and then fill in the RHS with
436 Remember, we're generating a RenamedHsExpr, so the result of all this
437 will be fed to the type checker. So the 'op' on the RHS will be
438 at the representation type for T, Trep.
441 A note about polymorphism. Suppose the class op is polymorphic:
444 op :: forall b. Ord b => a -> b -> b
446 Then we can still generate a bimap with
448 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
450 and fill in the instance decl thus
455 By the time the type checker has done its stuff we'll get
458 op = \b. \dict::Ord b. toOp b (op Trep b dict)
461 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
462 mkGenericRhs sel_id tyvar tycon
463 = HsApp (toEP bimap) (HsVar (idName sel_id))
465 -- Initialising the "Environment" with the from/to functions
466 -- on the datatype (actually tycon) in question
467 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
468 ep = EP (HsVar (idName from)) (HsVar (idName to))
470 -- Takes out the ForAll and the Class restrictions
471 -- in front of the type of the method.
472 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
474 -- Do it again! This deals with the case where the method type
475 -- is polymorphic -- see notes above
476 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
478 -- Now we probably have a tycon in front
479 -- of us, quite probably a FunTyCon.
480 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
482 type EPEnv = (TyVar, -- The class type variable
483 EP RenamedHsExpr, -- The EP it maps to
484 [TyVar] -- Other in-scope tyvars; they have an identity EP
488 generate_bimap :: EPEnv
491 -- Top level case - splitting the TyCon.
492 generate_bimap env@(tv,ep,local_tvs) ty
493 = case getTyVar_maybe ty of
494 Just tv1 | tv == tv1 -> ep -- The class tyvar
495 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
497 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
500 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
501 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
502 bimapApp env (Just (tycon, ty_args))
503 | tycon == funTyCon = bimapArrow arg_eps
504 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
505 | otherwise = -- Otherwise validGenericMethodType will
506 -- have checked that the type is a constant type
507 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
510 arg_eps = map (generate_bimap env) ty_args
511 (_,_,local_tvs) = env
514 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
515 bimapArrow [ep1, ep2]
516 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
517 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
519 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
520 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
524 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
525 toEP = mk_hs_lam [tuple_pat] to_body }
527 names = takeList eps genericNames
528 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
529 eps_w_names = eps `zip` names
530 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
531 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
534 genericNames :: [Name]
535 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
536 (g1:g2:g3:_) = genericNames
538 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
540 idEP :: EP RenamedHsExpr
541 idEP = EP idexpr idexpr
543 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)