2 module Generics ( mkTyConGenInfo, mkGenericRhs,
3 validGenericInstanceType, validGenericMethodType
7 import RnHsSyn ( RenamedHsExpr )
8 import HsSyn ( HsExpr(..), Pat(..), 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, isExistentialDataCon )
18 import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe,
19 tyConGenInfo, isNewTyCon, isBoxedTupleTyCon
21 import Name ( Name, mkSystemName )
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, mkGlobalId, idType, idName, mkSysLocal )
29 import MkId ( mkReboxingAlt, mkNewTypeBody )
30 import TysWiredIn ( genericTyCons,
31 genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
32 inlDataCon, crossTyCon, crossDataCon
34 import IdInfo ( GlobalIdDetails(..), noCafIdInfo, setUnfoldingInfo, setArityInfo )
35 import CoreUnfold ( mkTopUnfolding )
37 import Maybe ( isNothing )
38 import SrcLoc ( noSrcLoc )
39 import Unique ( Unique, builtinUniques, mkBuiltinUnique )
40 import Util ( takeList, dropList )
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
85 bug #5. [I don't think that this is the case anymore after SPJ's latest
86 changes in that regard. Delete this comment? -=chak/7Jun2]
90 Making generic information to put into a tycon. Constructs the
91 representation type, which, I think, are not used later. Perhaps it is
92 worth removing them from the GI datatype. Although it does get used in
93 the construction of conversion functions (internally).
97 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
101 Defines generic and other type and data constructors.
103 This is sadly incomplete, but will be added to.
106 Bugs & shortcomings of existing implementation:
107 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
109 2. Another pretty big bug I dscovered at the last minute when I was
110 testing the code is that at the moment the type variable of the class
111 is scoped over the entire declaration, including the patterns. For
112 instance, if I have the following code,
116 er {| Plus a b |} (Inl x) (Inl y) = er x y
117 er {| Plus a b |} (Inr x) (Inr y) = er x y
118 er {| Plus a b |} _ _ = False
120 and I print out the types of the generic patterns, I get the
121 following. Note that all the variable names for "a" are the same,
122 while for "b" they are all different.
125 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
126 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
127 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
129 This is a bug as if I change the code to
131 er {| Plus c b |} (Inl x) (Inl y) = er x y
133 all the names come out to be different.
135 Thus, all the types (Plus a b) come out to be different, so I cannot
136 compare them and test whether they are all the same and thus cannot
137 return an error if the type variables are different.
139 Temporary fix/hack. I am not checking for this, I just assume they are
140 the same, see line "check_ty = True" in TcInstDecls. When we resolve
141 the issue with variables, though - I assume that we will make them to
142 be the same in all the type patterns, jus uncomment the check and
143 everything should work smoothly.
145 Hence, I have also left the rather silly construction of:
146 * extracting all the type variables from all the types
147 * putting them *all* into the environment
148 * typechecking all the types
149 * selecting one of them and using it as the instance_ty.
151 (the alternative is to make sure that all the types are the same,
152 taking one, extracting its variables, putting them into the environment,
153 type checking it, using it as the instance_ty)
155 6. What happens if we do not supply all of the generic patterns? At
156 the moment, the compiler crashes with an error message "Non-exhaustive
157 patterns in a generic declaration"
160 What has not been addressed:
161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
163 Contexts. In the generated instance declarations for the 3 primitive
164 type constructors, we need contexts. It is unclear what those should
165 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
167 Type application. We have type application in expressions
168 (essentially) on the lhs of an equation. Do we want to allow it on the
171 Scoping of type variables in a generic definition. At the moment, (see
172 TcInstDecls) we extract the type variables inside the type patterns
173 and add them to the environment. See my bug #2 above. This seems pretty
178 %************************************************************************
180 \subsection{Getting the representation type out}
182 %************************************************************************
185 validGenericInstanceType :: Type -> Bool
186 -- Checks for validity of the type pattern in a generic
187 -- declaration. It's ok to have
189 -- but it's not OK to have
192 validGenericInstanceType inst_ty
193 = case tcSplitTyConApp_maybe inst_ty of
194 Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons
197 validGenericMethodType :: Type -> Bool
198 -- At the moment we only allow method types built from
202 -- * an arbitrary type not involving the class type variables
203 -- e.g. this is ok: forall b. Ord b => [b] -> a
204 -- where a is the class variable
205 validGenericMethodType ty
208 (local_tvs, _, tau) = tcSplitSigmaTy ty
211 | isTyVarTy ty = True
212 | no_tyvars_in_ty = True
213 | otherwise = case tcSplitTyConApp_maybe ty of
214 Just (tc,tys) -> valid_tycon tc && all valid tys
217 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
219 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
220 -- Compare bimapApp, below
224 %************************************************************************
226 \subsection{Generating representation types}
228 %************************************************************************
231 mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
232 -- mkTyConGenInfo is called twice
233 -- once from TysWiredIn for Tuples
234 -- once the typechecker TcTyDecls
235 -- to generate generic types and conversion functions for all datatypes.
237 -- Must only be called with an algebraic type.
239 -- The two names are the names constructed by the renamer
240 -- for the fromT and toT conversion functions.
242 mkTyConGenInfo tycon []
243 = Nothing -- This happens when we deal with the interface-file type
244 -- decl for a module compiled without -fgenerics
246 mkTyConGenInfo tycon [from_name, to_name]
247 | isNothing maybe_datacons -- Abstractly imported types don't have
248 = Nothing -- to/from operations, (and should not need them)
250 -- If any of the constructor has an unboxed type as argument,
251 -- then we can't build the embedding-projection pair, because
252 -- it relies on instantiating *polymorphic* sum and product types
253 -- at the argument types of the constructors
254 -- Nor can we do the job if it's an existential data constructor,
255 | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
259 | null datacons -- There are no constructors;
260 = Nothing -- there are no values of this type
263 = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons
264 Just (EP { fromEP = mk_id from_name from_ty from_id_info,
265 toEP = mk_id to_name to_ty to_id_info })
267 mk_id = mkGlobalId (GenericOpId tycon)
269 maybe_datacons = tyConDataCons_maybe tycon
270 Just datacons = maybe_datacons -- [C, D]
272 tyvars = tyConTyVars tycon -- [a, b, c]
273 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
274 tyvar_tys = mkTyVarTys tyvars
276 from_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
277 `setArityInfo` exprArity from_fn
278 to_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
279 `setArityInfo` exprArity to_fn
280 -- It's important to set the arity info, so that
281 -- the calling convention (gotten from arity)
284 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
285 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
287 (from_fn, to_fn, rep_ty)
289 = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon the_arg_ty (Var x),
290 Var (dataConWrapId the_datacon),
294 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
295 mkLams tyvars $ Lam rep_var to_inner,
299 x = mkGenericLocal u1 tycon_ty
300 (u1 : uniqs) = builtinUniques
302 ----------------------
304 [the_datacon] = datacons
305 the_arg_ty = head (dataConOrigArgTys the_datacon)
306 -- NB: we use the arg type of the data constructor, rather than
307 -- the representation type of the newtype; in degnerate (recursive)
308 -- cases the rep type might be (), but the arg type is still T:
311 ----------------------
313 -- Recurse over the sum first
314 -- The "2" is the first free unique
315 (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
317 mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
320 ----------------------------------------------------
322 ----------------------------------------------------
323 mk_sum_stuff :: [Unique] -- Base for generating unique names
324 -> [TyVar] -- Type variables over which the tycon is abstracted
325 -> [DataCon] -- The data constructors
326 -> ([Alt Id], CoreExpr, Id)
328 -- For example, given
329 -- data T = C | D Int Int Int
331 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
332 -- case cd of { Inl u -> C;
333 -- Inr abc -> case abc of { a :*: bc ->
334 -- case bc of { b :*: c ->
338 mk_sum_stuff us tyvars [datacon]
339 = ([from_alt], to_body_fn app_exp, rep_var)
341 types = dataConOrigArgTys datacon -- Existentials already excluded
342 datacon_vars = zipWith mkGenericLocal us types
343 us' = dropList types us
345 app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
346 from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
347 -- We are talking about *user* datacons here; hence
351 (_,args',_) = from_alt
352 us'' = dropList args' us' -- Conservative, but safe
354 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
356 mk_sum_stuff (u:us) tyvars datacons
357 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
358 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
359 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
362 (l_datacons, r_datacons) = splitInHalf datacons
363 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
364 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
365 rep_tys = [idType l_rep_var, idType r_rep_var]
366 rep_ty = mkTyConApp plusTyCon rep_tys
367 rep_var = mkGenericLocal u rep_ty
369 wrap :: DataCon -> [Alt Id] -> [Alt Id]
370 -- Wrap an application of the Inl or Inr constructor round each alternative
372 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
374 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
376 ----------------------------------------------------
377 -- Dealing with products
378 ----------------------------------------------------
379 mk_prod_stuff :: [Unique] -- Base for unique names
380 -> [Id] -- arg-ids; args of the original user-defined constructor
381 -- They are bound enclosing from_rhs
382 -- Please bind these in the to_body_fn
383 -> ([Unique], -- Depleted unique-name supply
384 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
385 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
386 Id) -- The rep-id; please bind this to the representation
389 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
390 -- \x -> case abc of { a :*: bc ->
391 -- case bc of { b :*: c ->
395 -- We need to use different uqiques in the branches
396 -- because the returned to_body_fns are nested.
397 -- Hence the returned unqique-name supply
399 mk_prod_stuff (u:us) [] -- Unit case
401 Var (dataConWrapId genUnitDataCon),
403 mkGenericLocal u (mkTyConApp genUnitTyCon []))
405 mk_prod_stuff us [arg_var] -- Singleton case
406 = (us, Var arg_var, \x -> x, arg_var)
408 mk_prod_stuff (u:us) arg_vars -- Two or more
410 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
411 \x -> Case (Var rep_var) rep_var
412 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
415 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
416 (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
417 (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
418 rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
419 rep_tys = [idType l_rep_var, idType r_rep_var]
422 A little utility function
425 splitInHalf :: [a] -> ([a],[a])
426 splitInHalf list = (left, right)
428 half = length list `div` 2
429 left = take half list
430 right = drop half list
432 mkGenericLocal :: Unique -> Type -> Id
433 mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
436 %************************************************************************
438 \subsection{Generating the RHS of a generic default method}
440 %************************************************************************
442 Generating the Generic default method. Uses the bimaps to generate the
443 actual method. All of this is rather incomplete, but it would be nice
444 to make even this work. Example
451 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
454 op = <mkGenericRhs op a T>
456 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
458 toOp :: Op Trep -> Op T
459 fromOp :: Op T -> Op Trep
461 (the bimap) and then fill in the RHS with
466 Remember, we're generating a RenamedHsExpr, so the result of all this
467 will be fed to the type checker. So the 'op' on the RHS will be
468 at the representation type for T, Trep.
471 A note about polymorphism. Suppose the class op is polymorphic:
474 op :: forall b. Ord b => a -> b -> b
476 Then we can still generate a bimap with
478 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
480 and fill in the instance decl thus
485 By the time the type checker has done its stuff we'll get
488 op = \b. \dict::Ord b. toOp b (op Trep b dict)
491 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
492 mkGenericRhs sel_id tyvar tycon
493 = HsApp (toEP bimap) (HsVar (idName sel_id))
495 -- Initialising the "Environment" with the from/to functions
496 -- on the datatype (actually tycon) in question
497 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
498 ep = EP (HsVar (idName from)) (HsVar (idName to))
500 -- Takes out the ForAll and the Class restrictions
501 -- in front of the type of the method.
502 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
504 -- Do it again! This deals with the case where the method type
505 -- is polymorphic -- see notes above
506 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
508 -- Now we probably have a tycon in front
509 -- of us, quite probably a FunTyCon.
510 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
512 type EPEnv = (TyVar, -- The class type variable
513 EP RenamedHsExpr, -- The EP it maps to
514 [TyVar] -- Other in-scope tyvars; they have an identity EP
518 generate_bimap :: EPEnv
521 -- Top level case - splitting the TyCon.
522 generate_bimap env@(tv,ep,local_tvs) ty
523 = case getTyVar_maybe ty of
524 Just tv1 | tv == tv1 -> ep -- The class tyvar
525 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
527 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
530 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
531 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
532 bimapApp env (Just (tycon, ty_args))
533 | tycon == funTyCon = bimapArrow arg_eps
534 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
535 | otherwise = -- Otherwise validGenericMethodType will
536 -- have checked that the type is a constant type
537 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
540 arg_eps = map (generate_bimap env) ty_args
541 (_,_,local_tvs) = env
544 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
545 bimapArrow [ep1, ep2]
546 = EP { fromEP = mk_hs_lam [VarPat g1, VarPat g2] from_body,
547 toEP = mk_hs_lam [VarPat g1, VarPat g2] to_body }
549 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
550 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
554 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
555 toEP = mk_hs_lam [tuple_pat] to_body }
557 names = takeList eps genericNames
558 tuple_pat = TuplePat (map VarPat names) Boxed
559 eps_w_names = eps `zip` names
560 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
561 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
564 genericNames :: [Name]
565 genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]
566 (g1:g2:g3:_) = genericNames
568 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType noSrcLoc))
570 idEP :: EP RenamedHsExpr
571 idEP = EP idexpr idexpr
573 idexpr = mk_hs_lam [VarPat g3] (HsVar g3)