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 )
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 []
241 = Nothing -- This happens when we deal with the interface-file type
242 -- decl for a module compiled without -fgenerics
244 mkTyConGenInfo tycon [from_name, to_name]
245 | isNothing maybe_datacons -- Abstractly imported types don't have
246 = Nothing -- to/from operations, (and should not need them)
248 -- If any of the constructor has an unboxed type as argument,
249 -- then we can't build the embedding-projection pair, because
250 -- it relies on instantiating *polymorphic* sum and product types
251 -- at the argument types of the constructors
252 -- Nor can we do the job if it's an existential data constructor,
253 | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
257 | null datacons -- There are no constructors;
258 = Nothing -- there are no values of this type
261 = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons
262 Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
263 toEP = mkVanillaGlobal to_name to_ty to_id_info })
265 maybe_datacons = tyConDataCons_maybe tycon
266 Just datacons = maybe_datacons -- [C, D]
268 tyvars = tyConTyVars tycon -- [a, b, c]
269 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
270 tyvar_tys = mkTyVarTys tyvars
272 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
273 `setArityInfo` exprArity from_fn
274 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
275 `setArityInfo` exprArity to_fn
276 -- It's important to set the arity info, so that
277 -- the calling convention (gotten from arity)
280 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
281 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
283 (from_fn, to_fn, rep_ty)
285 = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon newrep_ty (Var x),
286 Var (dataConWrapId the_datacon),
290 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
291 mkLams tyvars $ Lam rep_var to_inner,
295 x = mkGenericLocal u1 tycon_ty
296 (u1 : uniqs) = builtinUniques
298 ----------------------
300 [the_datacon] = datacons
301 (_, newrep_ty) = newTyConRep tycon
303 ----------------------
305 -- Recurse over the sum first
306 -- The "2" is the first free unique
307 (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
309 mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
312 ----------------------------------------------------
314 ----------------------------------------------------
315 mk_sum_stuff :: [Unique] -- Base for generating unique names
316 -> [TyVar] -- Type variables over which the tycon is abstracted
317 -> [DataCon] -- The data constructors
318 -> ([Alt Id], CoreExpr, Id)
320 -- For example, given
321 -- data T = C | D Int Int Int
323 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
324 -- case cd of { Inl u -> C;
325 -- Inr abc -> case abc of { a :*: bc ->
326 -- case bc of { b :*: c ->
330 mk_sum_stuff us tyvars [datacon]
331 = ([from_alt], to_body_fn app_exp, rep_var)
333 types = dataConOrigArgTys datacon -- Existentials already excluded
334 datacon_vars = zipWith mkGenericLocal us types
335 us' = dropList types us
337 app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
338 from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
339 -- We are talking about *user* datacons here; hence
343 (_,args',_) = from_alt
344 us'' = dropList args' us' -- Conservative, but safe
346 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
348 mk_sum_stuff (u:us) tyvars datacons
349 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
350 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
351 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
354 (l_datacons, r_datacons) = splitInHalf datacons
355 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
356 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
357 rep_tys = [idType l_rep_var, idType r_rep_var]
358 rep_ty = mkTyConApp plusTyCon rep_tys
359 rep_var = mkGenericLocal u rep_ty
361 wrap :: DataCon -> [Alt Id] -> [Alt Id]
362 -- Wrap an application of the Inl or Inr constructor round each alternative
364 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
366 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
368 ----------------------------------------------------
369 -- Dealing with products
370 ----------------------------------------------------
371 mk_prod_stuff :: [Unique] -- Base for unique names
372 -> [Id] -- arg-ids; args of the original user-defined constructor
373 -- They are bound enclosing from_rhs
374 -- Please bind these in the to_body_fn
375 -> ([Unique], -- Depleted unique-name supply
376 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
377 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
378 Id) -- The rep-id; please bind this to the representation
381 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
382 -- \x -> case abc of { a :*: bc ->
383 -- case bc of { b :*: c ->
387 -- We need to use different uqiques in the branches
388 -- because the returned to_body_fns are nested.
389 -- Hence the returned unqique-name supply
391 mk_prod_stuff (u:us) [] -- Unit case
393 Var (dataConWrapId genUnitDataCon),
395 mkGenericLocal u (mkTyConApp genUnitTyCon []))
397 mk_prod_stuff us [arg_var] -- Singleton case
398 = (us, Var arg_var, \x -> x, arg_var)
400 mk_prod_stuff (u:us) arg_vars -- Two or more
402 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
403 \x -> Case (Var rep_var) rep_var
404 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
407 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
408 (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
409 (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
410 rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
411 rep_tys = [idType l_rep_var, idType r_rep_var]
414 A little utility function
417 splitInHalf :: [a] -> ([a],[a])
418 splitInHalf list = (left, right)
420 half = length list `div` 2
421 left = take half list
422 right = drop half list
424 mkGenericLocal :: Unique -> Type -> Id
425 mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
428 %************************************************************************
430 \subsection{Generating the RHS of a generic default method}
432 %************************************************************************
434 Generating the Generic default method. Uses the bimaps to generate the
435 actual method. All of this is rather incomplete, but it would be nice
436 to make even this work. Example
443 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
446 op = <mkGenericRhs op a T>
448 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
450 toOp :: Op Trep -> Op T
451 fromOp :: Op T -> Op Trep
453 (the bimap) and then fill in the RHS with
458 Remember, we're generating a RenamedHsExpr, so the result of all this
459 will be fed to the type checker. So the 'op' on the RHS will be
460 at the representation type for T, Trep.
463 A note about polymorphism. Suppose the class op is polymorphic:
466 op :: forall b. Ord b => a -> b -> b
468 Then we can still generate a bimap with
470 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
472 and fill in the instance decl thus
477 By the time the type checker has done its stuff we'll get
480 op = \b. \dict::Ord b. toOp b (op Trep b dict)
483 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
484 mkGenericRhs sel_id tyvar tycon
485 = HsApp (toEP bimap) (HsVar (idName sel_id))
487 -- Initialising the "Environment" with the from/to functions
488 -- on the datatype (actually tycon) in question
489 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
490 ep = EP (HsVar (idName from)) (HsVar (idName to))
492 -- Takes out the ForAll and the Class restrictions
493 -- in front of the type of the method.
494 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
496 -- Do it again! This deals with the case where the method type
497 -- is polymorphic -- see notes above
498 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
500 -- Now we probably have a tycon in front
501 -- of us, quite probably a FunTyCon.
502 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
504 type EPEnv = (TyVar, -- The class type variable
505 EP RenamedHsExpr, -- The EP it maps to
506 [TyVar] -- Other in-scope tyvars; they have an identity EP
510 generate_bimap :: EPEnv
513 -- Top level case - splitting the TyCon.
514 generate_bimap env@(tv,ep,local_tvs) ty
515 = case getTyVar_maybe ty of
516 Just tv1 | tv == tv1 -> ep -- The class tyvar
517 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
519 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
522 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
523 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
524 bimapApp env (Just (tycon, ty_args))
525 | tycon == funTyCon = bimapArrow arg_eps
526 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
527 | otherwise = -- Otherwise validGenericMethodType will
528 -- have checked that the type is a constant type
529 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
532 arg_eps = map (generate_bimap env) ty_args
533 (_,_,local_tvs) = env
536 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
537 bimapArrow [ep1, ep2]
538 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
539 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
541 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
542 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
546 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
547 toEP = mk_hs_lam [tuple_pat] to_body }
549 names = takeList eps genericNames
550 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
551 eps_w_names = eps `zip` names
552 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
553 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
556 genericNames :: [Name]
557 genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
558 (g1:g2:g3:_) = genericNames
560 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
562 idEP :: EP RenamedHsExpr
563 idEP = EP idexpr idexpr
565 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)