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, isExistentialDataCon )
18 import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe,
19 tyConGenInfo, isNewTyCon, newTyConRep, 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, mkVanillaGlobal, idType, idName, mkSysLocal )
29 import MkId ( mkReboxingAlt, mkNewTypeBody )
30 import TysWiredIn ( genericTyCons,
31 genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
32 inlDataCon, crossTyCon, crossDataCon
34 import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
35 import CoreUnfold ( mkTopUnfolding )
37 import Maybe ( isNothing )
38 import SrcLoc ( builtinSrcLoc )
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 = mkVanillaGlobal from_name from_ty from_id_info,
265 toEP = mkVanillaGlobal to_name to_ty to_id_info })
267 maybe_datacons = tyConDataCons_maybe tycon
268 Just datacons = maybe_datacons -- [C, D]
270 tyvars = tyConTyVars tycon -- [a, b, c]
271 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
272 tyvar_tys = mkTyVarTys tyvars
274 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
275 `setArityInfo` exprArity from_fn
276 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
277 `setArityInfo` exprArity to_fn
278 -- It's important to set the arity info, so that
279 -- the calling convention (gotten from arity)
282 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
283 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
285 (from_fn, to_fn, rep_ty)
287 = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon newrep_ty (Var x),
288 Var (dataConWrapId the_datacon),
292 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
293 mkLams tyvars $ Lam rep_var to_inner,
297 x = mkGenericLocal u1 tycon_ty
298 (u1 : uniqs) = builtinUniques
300 ----------------------
302 [the_datacon] = datacons
303 (_, newrep_ty) = newTyConRep tycon
305 ----------------------
307 -- Recurse over the sum first
308 -- The "2" is the first free unique
309 (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
311 mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
314 ----------------------------------------------------
316 ----------------------------------------------------
317 mk_sum_stuff :: [Unique] -- Base for generating unique names
318 -> [TyVar] -- Type variables over which the tycon is abstracted
319 -> [DataCon] -- The data constructors
320 -> ([Alt Id], CoreExpr, Id)
322 -- For example, given
323 -- data T = C | D Int Int Int
325 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
326 -- case cd of { Inl u -> C;
327 -- Inr abc -> case abc of { a :*: bc ->
328 -- case bc of { b :*: c ->
332 mk_sum_stuff us tyvars [datacon]
333 = ([from_alt], to_body_fn app_exp, rep_var)
335 types = dataConOrigArgTys datacon -- Existentials already excluded
336 datacon_vars = zipWith mkGenericLocal us types
337 us' = dropList types us
339 app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
340 from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
341 -- We are talking about *user* datacons here; hence
345 (_,args',_) = from_alt
346 us'' = dropList args' us' -- Conservative, but safe
348 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
350 mk_sum_stuff (u:us) tyvars datacons
351 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
352 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
353 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
356 (l_datacons, r_datacons) = splitInHalf datacons
357 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
358 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
359 rep_tys = [idType l_rep_var, idType r_rep_var]
360 rep_ty = mkTyConApp plusTyCon rep_tys
361 rep_var = mkGenericLocal u rep_ty
363 wrap :: DataCon -> [Alt Id] -> [Alt Id]
364 -- Wrap an application of the Inl or Inr constructor round each alternative
366 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
368 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
370 ----------------------------------------------------
371 -- Dealing with products
372 ----------------------------------------------------
373 mk_prod_stuff :: [Unique] -- Base for unique names
374 -> [Id] -- arg-ids; args of the original user-defined constructor
375 -- They are bound enclosing from_rhs
376 -- Please bind these in the to_body_fn
377 -> ([Unique], -- Depleted unique-name supply
378 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
379 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
380 Id) -- The rep-id; please bind this to the representation
383 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
384 -- \x -> case abc of { a :*: bc ->
385 -- case bc of { b :*: c ->
389 -- We need to use different uqiques in the branches
390 -- because the returned to_body_fns are nested.
391 -- Hence the returned unqique-name supply
393 mk_prod_stuff (u:us) [] -- Unit case
395 Var (dataConWrapId genUnitDataCon),
397 mkGenericLocal u (mkTyConApp genUnitTyCon []))
399 mk_prod_stuff us [arg_var] -- Singleton case
400 = (us, Var arg_var, \x -> x, arg_var)
402 mk_prod_stuff (u:us) arg_vars -- Two or more
404 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
405 \x -> Case (Var rep_var) rep_var
406 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
409 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
410 (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
411 (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
412 rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
413 rep_tys = [idType l_rep_var, idType r_rep_var]
416 A little utility function
419 splitInHalf :: [a] -> ([a],[a])
420 splitInHalf list = (left, right)
422 half = length list `div` 2
423 left = take half list
424 right = drop half list
426 mkGenericLocal :: Unique -> Type -> Id
427 mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
430 %************************************************************************
432 \subsection{Generating the RHS of a generic default method}
434 %************************************************************************
436 Generating the Generic default method. Uses the bimaps to generate the
437 actual method. All of this is rather incomplete, but it would be nice
438 to make even this work. Example
445 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
448 op = <mkGenericRhs op a T>
450 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
452 toOp :: Op Trep -> Op T
453 fromOp :: Op T -> Op Trep
455 (the bimap) and then fill in the RHS with
460 Remember, we're generating a RenamedHsExpr, so the result of all this
461 will be fed to the type checker. So the 'op' on the RHS will be
462 at the representation type for T, Trep.
465 A note about polymorphism. Suppose the class op is polymorphic:
468 op :: forall b. Ord b => a -> b -> b
470 Then we can still generate a bimap with
472 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
474 and fill in the instance decl thus
479 By the time the type checker has done its stuff we'll get
482 op = \b. \dict::Ord b. toOp b (op Trep b dict)
485 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
486 mkGenericRhs sel_id tyvar tycon
487 = HsApp (toEP bimap) (HsVar (idName sel_id))
489 -- Initialising the "Environment" with the from/to functions
490 -- on the datatype (actually tycon) in question
491 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
492 ep = EP (HsVar (idName from)) (HsVar (idName to))
494 -- Takes out the ForAll and the Class restrictions
495 -- in front of the type of the method.
496 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
498 -- Do it again! This deals with the case where the method type
499 -- is polymorphic -- see notes above
500 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
502 -- Now we probably have a tycon in front
503 -- of us, quite probably a FunTyCon.
504 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
506 type EPEnv = (TyVar, -- The class type variable
507 EP RenamedHsExpr, -- The EP it maps to
508 [TyVar] -- Other in-scope tyvars; they have an identity EP
512 generate_bimap :: EPEnv
515 -- Top level case - splitting the TyCon.
516 generate_bimap env@(tv,ep,local_tvs) ty
517 = case getTyVar_maybe ty of
518 Just tv1 | tv == tv1 -> ep -- The class tyvar
519 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
521 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
524 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
525 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
526 bimapApp env (Just (tycon, ty_args))
527 | tycon == funTyCon = bimapArrow arg_eps
528 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
529 | otherwise = -- Otherwise validGenericMethodType will
530 -- have checked that the type is a constant type
531 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
534 arg_eps = map (generate_bimap env) ty_args
535 (_,_,local_tvs) = env
538 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
539 bimapArrow [ep1, ep2]
540 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
541 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
543 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
544 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
548 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
549 toEP = mk_hs_lam [tuple_pat] to_body }
551 names = takeList eps genericNames
552 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
553 eps_w_names = eps `zip` names
554 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
555 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
558 genericNames :: [Name]
559 genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]
560 (g1:g2:g3:_) = genericNames
562 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
564 idEP :: EP RenamedHsExpr
565 idEP = EP idexpr idexpr
567 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)