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, tyConDataCons_maybe,
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 Maybe ( isNothing )
39 import SrcLoc ( builtinSrcLoc )
40 import Unique ( mkBuiltinUnique )
41 import Util ( takeList )
44 #include "HsVersions.h"
47 Roadmap of what's where in the Generics work.
48 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
54 Checks that HsNumTy has a "1" in it.
56 TcInstDcls.mkGenericInstance:
57 Checks for invalid type patterns, such as f {| Int |}
60 Checks for a method type that is too complicated;
61 e.g. has for-alls or lists in it
62 We could lift this restriction
64 TcClassDecl.mkDefMethRhs
65 Checks that the instance type is simple, in an instance decl
66 where we let the compiler fill in a generic method.
67 e.g. instance C (T Int)
68 is not valid if C has generic methods.
70 TcClassDecl.checkGenericClassIsUnary
71 Checks that we don't have generic methods in a multi-parameter class
73 TcClassDecl.checkDefaultBinds
74 Checks that all the equations for a method in a class decl
75 are generic, or all are non-generic
79 Checking that the type constructors which are present in Generic
80 patterns (not Unit, this is done differently) is done in mk_inst_info
81 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
82 HsOpTy is tied to Generic definitions which is not a very good design
83 feature, indeed a bug. However, the check is easy to move from
84 tcHsType back to mk_inst_info and everything will be fine. Also see
89 Making generic information to put into a tycon. Constructs the
90 representation type, which, I think, are not used later. Perhaps it is
91 worth removing them from the GI datatype. Although it does get used in
92 the construction of conversion functions (internally).
96 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
100 Defines generic and other type and data constructors.
102 This is sadly incomplete, but will be added to.
105 Bugs & shortcomings of existing implementation:
106 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
108 2. Another pretty big bug I dscovered at the last minute when I was
109 testing the code is that at the moment the type variable of the class
110 is scoped over the entire declaration, including the patterns. For
111 instance, if I have the following code,
115 er {| Plus a b |} (Inl x) (Inl y) = er x y
116 er {| Plus a b |} (Inr x) (Inr y) = er x y
117 er {| Plus a b |} _ _ = False
119 and I print out the types of the generic patterns, I get the
120 following. Note that all the variable names for "a" are the same,
121 while for "b" they are all different.
124 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
125 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
126 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
128 This is a bug as if I change the code to
130 er {| Plus c b |} (Inl x) (Inl y) = er x y
132 all the names come out to be different.
134 Thus, all the types (Plus a b) come out to be different, so I cannot
135 compare them and test whether they are all the same and thus cannot
136 return an error if the type variables are different.
138 Temporary fix/hack. I am not checking for this, I just assume they are
139 the same, see line "check_ty = True" in TcInstDecls. When we resolve
140 the issue with variables, though - I assume that we will make them to
141 be the same in all the type patterns, jus uncomment the check and
142 everything should work smoothly.
144 Hence, I have also left the rather silly construction of:
145 * extracting all the type variables from all the types
146 * putting them *all* into the environment
147 * typechecking all the types
148 * selecting one of them and using it as the instance_ty.
150 (the alternative is to make sure that all the types are the same,
151 taking one, extracting its variables, putting them into the environment,
152 type checking it, using it as the instance_ty)
154 6. What happens if we do not supply all of the generic patterns? At
155 the moment, the compiler crashes with an error message "Non-exhaustive
156 patterns in a generic declaration"
159 What has not been addressed:
160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
162 Contexts. In the generated instance declarations for the 3 primitive
163 type constructors, we need contexts. It is unclear what those should
164 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
166 Type application. We have type application in expressions
167 (essentially) on the lhs of an equation. Do we want to allow it on the
170 Scoping of type variables in a generic definition. At the moment, (see
171 TcInstDecls) we extract the type variables inside the type patterns
172 and add them to the environment. See my bug #2 above. This seems pretty
177 %************************************************************************
179 \subsection{Getting the representation type out}
181 %************************************************************************
184 validGenericInstanceType :: Type -> Bool
185 -- Checks for validity of the type pattern in a generic
186 -- declaration. It's ok to have
188 -- but it's not OK to have
191 validGenericInstanceType inst_ty
192 = case tcSplitTyConApp_maybe inst_ty of
193 Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
196 validGenericMethodType :: Type -> Bool
197 -- At the moment we only allow method types built from
201 -- * an arbitrary type not involving the class type variables
202 -- e.g. this is ok: forall b. Ord b => [b] -> a
203 -- where a is the class variable
204 validGenericMethodType ty
207 (local_tvs, _, tau) = tcSplitSigmaTy ty
210 | isTyVarTy ty = True
211 | no_tyvars_in_ty = True
212 | otherwise = case tcSplitTyConApp_maybe ty of
213 Just (tc,tys) -> valid_tycon tc && all valid tys
216 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
218 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
219 -- Compare bimapApp, below
223 %************************************************************************
225 \subsection{Generating representation types}
227 %************************************************************************
230 mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
231 -- mkTyConGenInfo is called twice
232 -- once from TysWiredIn for Tuples
233 -- once the typechecker TcTyDecls
234 -- to generate generic types and conversion functions for all datatypes.
236 -- Must only be called with an algebraic type.
238 -- The two names are the names constructed by the renamer
239 -- for the fromT and toT conversion functions.
241 mkTyConGenInfo tycon [from_name, to_name]
242 | isNothing maybe_datacons -- Abstractly imported types don't have
243 = Nothing -- to/from operations, (and should not need them)
245 -- If any of the constructor has an unboxed type as argument,
246 -- then we can't build the embedding-projection pair, because
247 -- it relies on instantiating *polymorphic* sum and product types
248 -- at the argument types of the constructors
249 -- Nor can we do the job if it's an existential data constructor,
250 | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
255 = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
256 toEP = mkVanillaGlobal to_name to_ty to_id_info })
258 maybe_datacons = tyConDataCons_maybe tycon
259 Just datacons = maybe_datacons -- [C, D]
261 tyvars = tyConTyVars tycon -- [a, b, c]
262 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
263 tyvar_tys = mkTyVarTys tyvars
265 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
266 `setArityInfo` exprArity from_fn
267 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
268 `setArityInfo` exprArity to_fn
269 -- It's important to set the arity info, so that
270 -- the calling convention (gotten from arity)
273 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
274 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
276 (from_fn, to_fn, rep_ty)
278 = ( mkLams tyvars $ Lam x $ Var x,
279 Var (dataConWrapId the_datacon),
283 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
284 mkLams tyvars $ Lam rep_var to_inner,
288 x = mkTemplateLocal 1 tycon_ty
290 ----------------------
292 [the_datacon] = datacons
293 (_, newrep_ty) = newTyConRep tycon
295 ----------------------
297 -- Recurse over the sum first
298 -- The "2" is the first free unique
299 (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
303 ----------------------------------------------------
305 ----------------------------------------------------
306 mk_sum_stuff :: Int -- Base for generating unique names
307 -> [TyVar] -- Type variables over which the tycon is abstracted
308 -> [DataCon] -- The data constructors
309 -> ([Alt Id], CoreExpr, Id)
311 -- For example, given
312 -- data T = C | D Int Int Int
314 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
315 -- case cd of { Inl u -> C;
316 -- Inr abc -> case abc of { a :*: bc ->
317 -- case bc of { b :*: c ->
321 mk_sum_stuff i tyvars [datacon]
322 = ([from_alt], to_body_fn app_exp, rep_var)
324 types = dataConOrigArgTys datacon
325 datacon_vars = mkTemplateLocalsNum i types
326 new_i = i + length types
327 app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
328 from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
330 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
332 mk_sum_stuff i tyvars datacons
333 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
334 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
335 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
338 (l_datacons, r_datacons) = splitInHalf datacons
339 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
340 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
341 rep_tys = [idType l_rep_var, idType r_rep_var]
342 rep_ty = mkTyConApp plusTyCon rep_tys
343 rep_var = mkTemplateLocal i rep_ty
345 wrap :: DataCon -> [Alt Id] -> [Alt Id]
346 -- Wrap an application of the Inl or Inr constructor round each alternative
348 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
350 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
352 ----------------------------------------------------
353 -- Dealing with products
354 ----------------------------------------------------
355 mk_prod_stuff :: Int -- Base for unique names
356 -> [Id] -- arg-ids; args of the original user-defined constructor
357 -- They are bound enclosing from_rhs
358 -- Please bind these in the to_body_fn
359 -> (Int, -- Depleted unique-name supply
360 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
361 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
362 Id) -- The rep-id; please bind this to the representation
365 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
366 -- \x -> case abc of { a :*: bc ->
367 -- case bc of { b :*: c ->
371 -- We need to use different uqiques in the branches
372 -- because the returned to_body_fns are nested.
373 -- Hence the returned unqique-name supply
375 mk_prod_stuff i [] -- Unit case
377 Var (dataConWrapId genUnitDataCon),
379 mkTemplateLocal i (mkTyConApp genUnitTyCon []))
381 mk_prod_stuff i [arg_var] -- Singleton case
382 = (i, Var arg_var, \x -> x, arg_var)
384 mk_prod_stuff i arg_vars -- Two or more
386 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
387 \x -> Case (Var rep_var) rep_var
388 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
391 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
392 (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
393 (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
394 rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
395 rep_tys = [idType l_rep_var, idType r_rep_var]
398 A little utility function
401 splitInHalf :: [a] -> ([a],[a])
402 splitInHalf list = (left, right)
404 half = length list `div` 2
405 left = take half list
406 right = drop half list
409 %************************************************************************
411 \subsection{Generating the RHS of a generic default method}
413 %************************************************************************
415 Generating the Generic default method. Uses the bimaps to generate the
416 actual method. All of this is rather incomplete, but it would be nice
417 to make even this work. Example
424 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
427 op = <mkGenericRhs op a T>
429 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
431 toOp :: Op Trep -> Op T
432 fromOp :: Op T -> Op Trep
434 (the bimap) and then fill in the RHS with
439 Remember, we're generating a RenamedHsExpr, so the result of all this
440 will be fed to the type checker. So the 'op' on the RHS will be
441 at the representation type for T, Trep.
444 A note about polymorphism. Suppose the class op is polymorphic:
447 op :: forall b. Ord b => a -> b -> b
449 Then we can still generate a bimap with
451 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
453 and fill in the instance decl thus
458 By the time the type checker has done its stuff we'll get
461 op = \b. \dict::Ord b. toOp b (op Trep b dict)
464 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
465 mkGenericRhs sel_id tyvar tycon
466 = HsApp (toEP bimap) (HsVar (idName sel_id))
468 -- Initialising the "Environment" with the from/to functions
469 -- on the datatype (actually tycon) in question
470 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
471 ep = EP (HsVar (idName from)) (HsVar (idName to))
473 -- Takes out the ForAll and the Class restrictions
474 -- in front of the type of the method.
475 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
477 -- Do it again! This deals with the case where the method type
478 -- is polymorphic -- see notes above
479 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
481 -- Now we probably have a tycon in front
482 -- of us, quite probably a FunTyCon.
483 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
485 type EPEnv = (TyVar, -- The class type variable
486 EP RenamedHsExpr, -- The EP it maps to
487 [TyVar] -- Other in-scope tyvars; they have an identity EP
491 generate_bimap :: EPEnv
494 -- Top level case - splitting the TyCon.
495 generate_bimap env@(tv,ep,local_tvs) ty
496 = case getTyVar_maybe ty of
497 Just tv1 | tv == tv1 -> ep -- The class tyvar
498 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
500 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
503 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
504 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
505 bimapApp env (Just (tycon, ty_args))
506 | tycon == funTyCon = bimapArrow arg_eps
507 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
508 | otherwise = -- Otherwise validGenericMethodType will
509 -- have checked that the type is a constant type
510 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
513 arg_eps = map (generate_bimap env) ty_args
514 (_,_,local_tvs) = env
517 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
518 bimapArrow [ep1, ep2]
519 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
520 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
522 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
523 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
527 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
528 toEP = mk_hs_lam [tuple_pat] to_body }
530 names = takeList eps genericNames
531 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
532 eps_w_names = eps `zip` names
533 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
534 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
537 genericNames :: [Name]
538 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
539 (g1:g2:g3:_) = genericNames
541 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
543 idEP :: EP RenamedHsExpr
544 idEP = EP idexpr idexpr
546 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)