2 module Generics ( mkTyConGenInfo, mkGenericRhs,
3 validGenericInstanceType, validGenericMethodType
7 import RnHsSyn ( RenamedHsExpr )
8 import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
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 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 )
41 #include "HsVersions.h"
44 Roadmap of what's where in the Generics work.
45 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
51 Checks that HsNumTy has a "1" in it.
53 TcInstDcls.mkGenericInstance:
54 Checks for invalid type patterns, such as f {| Int |}
57 Checks for a method type that is too complicated;
58 e.g. has for-alls or lists in it
59 We could lift this restriction
61 TcClassDecl.mkDefMethRhs
62 Checks that the instance type is simple, in an instance decl
63 where we let the compiler fill in a generic method.
64 e.g. instance C (T Int)
65 is not valid if C has generic methods.
67 TcClassDecl.checkGenericClassIsUnary
68 Checks that we don't have generic methods in a multi-parameter class
70 TcClassDecl.checkDefaultBinds
71 Checks that all the equations for a method in a class decl
72 are generic, or all are non-generic
76 Checking that the type constructors which are present in Generic
77 patterns (not Unit, this is done differently) is done in mk_inst_info
78 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
79 HsOpTy is tied to Generic definitions which is not a very good design
80 feature, indeed a bug. However, the check is easy to move from
81 tcHsType back to mk_inst_info and everything will be fine. Also see
86 Making generic information to put into a tycon. Constructs the
87 representation type, which, I think, are not used later. Perhaps it is
88 worth removing them from the GI datatype. Although it does get used in
89 the construction of conversion functions (internally).
93 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
97 Defines generic and other type and data constructors.
99 This is sadly incomplete, but will be added to.
102 Bugs & shortcomings of existing implementation:
103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
105 2. Another pretty big bug I dscovered at the last minute when I was
106 testing the code is that at the moment the type variable of the class
107 is scoped over the entire declaration, including the patterns. For
108 instance, if I have the following code,
112 er {| Plus a b |} (Inl x) (Inl y) = er x y
113 er {| Plus a b |} (Inr x) (Inr y) = er x y
114 er {| Plus a b |} _ _ = False
116 and I print out the types of the generic patterns, I get the
117 following. Note that all the variable names for "a" are the same,
118 while for "b" they are all different.
121 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
122 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
123 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
125 This is a bug as if I change the code to
127 er {| Plus c b |} (Inl x) (Inl y) = er x y
129 all the names come out to be different.
131 Thus, all the types (Plus a b) come out to be different, so I cannot
132 compare them and test whether they are all the same and thus cannot
133 return an error if the type variables are different.
135 Temporary fix/hack. I am not checking for this, I just assume they are
136 the same, see line "check_ty = True" in TcInstDecls. When we resolve
137 the issue with variables, though - I assume that we will make them to
138 be the same in all the type patterns, jus uncomment the check and
139 everything should work smoothly.
141 Hence, I have also left the rather silly construction of:
142 * extracting all the type variables from all the types
143 * putting them *all* into the environment
144 * typechecking all the types
145 * selecting one of them and using it as the instance_ty.
147 (the alternative is to make sure that all the types are the same,
148 taking one, extracting its variables, putting them into the environment,
149 type checking it, using it as the instance_ty)
151 6. What happens if we do not supply all of the generic patterns? At
152 the moment, the compiler crashes with an error message "Non-exhaustive
153 patterns in a generic declaration"
156 What has not been addressed:
157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
159 Contexts. In the generated instance declarations for the 3 primitive
160 type constructors, we need contexts. It is unclear what those should
161 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
163 Type application. We have type application in expressions
164 (essentially) on the lhs of an equation. Do we want to allow it on the
167 Scoping of type variables in a generic definition. At the moment, (see
168 TcInstDecls) we extract the type variables inside the type patterns
169 and add them to the environment. See my bug #2 above. This seems pretty
174 %************************************************************************
176 \subsection{Getting the representation type out}
178 %************************************************************************
181 validGenericInstanceType :: Type -> Bool
182 -- Checks for validity of the type pattern in a generic
183 -- declaration. It's ok to have
185 -- but it's not OK to have
188 validGenericInstanceType inst_ty
189 = case tcSplitTyConApp_maybe inst_ty of
190 Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
193 validGenericMethodType :: Type -> Bool
194 -- At the moment we only allow method types built from
198 -- * an arbitrary type not involving the class type variables
199 -- e.g. this is ok: forall b. Ord b => [b] -> a
200 -- where a is the class variable
201 validGenericMethodType ty
204 (local_tvs, _, tau) = tcSplitSigmaTy ty
207 | isTyVarTy ty = True
208 | no_tyvars_in_ty = True
209 | otherwise = case tcSplitTyConApp_maybe ty of
210 Just (tc,tys) -> valid_tycon tc && all valid tys
213 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
215 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
216 -- Compare bimapApp, below
220 %************************************************************************
222 \subsection{Generating representation types}
224 %************************************************************************
227 mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
228 -- mkTyConGenInfo is called twice
229 -- once from TysWiredIn for Tuples
230 -- once the typechecker TcTyDecls
231 -- to generate generic types and conversion functions for all datatypes.
233 -- Must only be called with an algebraic type.
235 -- The two names are the names constructed by the renamer
236 -- for the fromT and toT conversion functions.
238 mkTyConGenInfo tycon [from_name, to_name]
239 | null datacons -- Abstractly imported types don't have
240 = Nothing -- to/from operations, (and should not need them)
242 -- If any of the constructor has an unboxed type as argument,
243 -- then we can't build the embedding-projection pair, because
244 -- it relies on instantiating *polymorphic* sum and product types
245 -- at the argument types of the constructors
246 -- Nor can we do the job if it's an existential data constructor,
247 | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
252 = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
253 toEP = mkVanillaGlobal to_name to_ty to_id_info })
255 tyvars = tyConTyVars tycon -- [a, b, c]
256 datacons = tyConDataConsIfAvailable tycon -- [C, D]
257 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
258 tyvar_tys = mkTyVarTys tyvars
260 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
261 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
263 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
264 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
266 (from_fn, to_fn, rep_ty)
268 = ( mkLams tyvars $ Lam x $ Var x,
269 Var (dataConWrapId the_datacon),
273 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
274 mkLams tyvars $ Lam rep_var to_inner,
278 x = mkTemplateLocal 1 tycon_ty
280 ----------------------
282 [the_datacon] = datacons
283 (_, newrep_ty) = newTyConRep tycon
285 ----------------------
287 -- Recurse over the sum first
288 -- The "2" is the first free unique
289 (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
293 ----------------------------------------------------
295 ----------------------------------------------------
296 mk_sum_stuff :: Int -- Base for generating unique names
297 -> [TyVar] -- Type variables over which the tycon is abstracted
298 -> [DataCon] -- The data constructors
299 -> ([Alt Id], CoreExpr, Id)
301 -- For example, given
302 -- data T = C | D Int Int Int
304 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
305 -- case cd of { Inl u -> C;
306 -- Inr abc -> case abc of { a :*: bc ->
307 -- case bc of { b :*: c ->
311 mk_sum_stuff i tyvars [datacon]
312 = ([from_alt], to_body_fn app_exp, rep_var)
314 types = dataConOrigArgTys datacon
315 datacon_vars = mkTemplateLocalsNum i types
316 new_i = i + length types
317 app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
318 from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
320 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
322 mk_sum_stuff i tyvars datacons
323 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
324 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
325 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
328 (l_datacons, r_datacons) = splitInHalf datacons
329 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
330 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
331 rep_tys = [idType l_rep_var, idType r_rep_var]
332 rep_ty = mkTyConApp plusTyCon rep_tys
333 rep_var = mkTemplateLocal i rep_ty
335 wrap :: DataCon -> [Alt Id] -> [Alt Id]
336 -- Wrap an application of the Inl or Inr constructor round each alternative
338 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
340 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
342 ----------------------------------------------------
343 -- Dealing with products
344 ----------------------------------------------------
345 mk_prod_stuff :: Int -- Base for unique names
346 -> [Id] -- arg-ids; args of the original user-defined constructor
347 -- They are bound enclosing from_rhs
348 -- Please bind these in the to_body_fn
349 -> (Int, -- Depleted unique-name supply
350 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
351 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
352 Id) -- The rep-id; please bind this to the representation
355 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
356 -- \x -> case abc of { a :*: bc ->
357 -- case bc of { b :*: c ->
361 -- We need to use different uqiques in the branches
362 -- because the returned to_body_fns are nested.
363 -- Hence the returned unqique-name supply
365 mk_prod_stuff i [] -- Unit case
367 Var (dataConWrapId genUnitDataCon),
369 mkTemplateLocal i (mkTyConApp genUnitTyCon []))
371 mk_prod_stuff i [arg_var] -- Singleton case
372 = (i, Var arg_var, \x -> x, arg_var)
374 mk_prod_stuff i arg_vars -- Two or more
376 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
377 \x -> Case (Var rep_var) rep_var
378 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
381 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
382 (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
383 (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
384 rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
385 rep_tys = [idType l_rep_var, idType r_rep_var]
388 A little utility function
391 splitInHalf :: [a] -> ([a],[a])
392 splitInHalf list = (left, right)
394 half = length list `div` 2
395 left = take half list
396 right = drop half list
399 %************************************************************************
401 \subsection{Generating the RHS of a generic default method}
403 %************************************************************************
405 Generating the Generic default method. Uses the bimaps to generate the
406 actual method. All of this is rather incomplete, but it would be nice
407 to make even this work. Example
414 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
417 op = <mkGenericRhs op a T>
419 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
421 toOp :: Op Trep -> Op T
422 fromOp :: Op T -> Op Trep
424 (the bimap) and then fill in the RHS with
429 Remember, we're generating a RenamedHsExpr, so the result of all this
430 will be fed to the type checker. So the 'op' on the RHS will be
431 at the representation type for T, Trep.
434 A note about polymorphism. Suppose the class op is polymorphic:
437 op :: forall b. Ord b => a -> b -> b
439 Then we can still generate a bimap with
441 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
443 and fill in the instance decl thus
448 By the time the type checker has done its stuff we'll get
451 op = \b. \dict::Ord b. toOp b (op Trep b dict)
454 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
455 mkGenericRhs sel_id tyvar tycon
456 = HsApp (toEP bimap) (HsVar (idName sel_id))
458 -- Initialising the "Environment" with the from/to functions
459 -- on the datatype (actually tycon) in question
460 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
461 ep = EP (HsVar (idName from)) (HsVar (idName to))
463 -- Takes out the ForAll and the Class restrictions
464 -- in front of the type of the method.
465 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
467 -- Do it again! This deals with the case where the method type
468 -- is polymorphic -- see notes above
469 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
471 -- Now we probably have a tycon in front
472 -- of us, quite probably a FunTyCon.
473 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
475 type EPEnv = (TyVar, -- The class type variable
476 EP RenamedHsExpr, -- The EP it maps to
477 [TyVar] -- Other in-scope tyvars; they have an identity EP
481 generate_bimap :: EPEnv
484 -- Top level case - splitting the TyCon.
485 generate_bimap env@(tv,ep,local_tvs) ty
486 = case getTyVar_maybe ty of
487 Just tv1 | tv == tv1 -> ep -- The class tyvar
488 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
490 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
493 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
494 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
495 bimapApp env (Just (tycon, ty_args))
496 | tycon == funTyCon = bimapArrow arg_eps
497 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
498 | otherwise = -- Otherwise validGenericMethodType will
499 -- have checked that the type is a constant type
500 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
503 arg_eps = map (generate_bimap env) ty_args
504 (_,_,local_tvs) = env
507 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
508 bimapArrow [ep1, ep2]
509 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
510 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
512 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
513 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
517 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
518 toEP = mk_hs_lam [tuple_pat] to_body }
520 names = take (length eps) genericNames
521 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
522 eps_w_names = eps `zip` names
523 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
524 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
527 genericNames :: [Name]
528 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
529 (g1:g2:g3:_) = genericNames
531 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
533 idEP :: EP RenamedHsExpr
534 idEP = EP idexpr idexpr
536 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)