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
258 = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
259 toEP = mkVanillaGlobal to_name to_ty to_id_info })
261 maybe_datacons = tyConDataCons_maybe tycon
262 Just datacons = maybe_datacons -- [C, D]
264 tyvars = tyConTyVars tycon -- [a, b, c]
265 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
266 tyvar_tys = mkTyVarTys tyvars
268 from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
269 `setArityInfo` exprArity from_fn
270 to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
271 `setArityInfo` exprArity to_fn
272 -- It's important to set the arity info, so that
273 -- the calling convention (gotten from arity)
276 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
277 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
279 (from_fn, to_fn, rep_ty)
281 = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon newrep_ty (Var x),
282 Var (dataConWrapId the_datacon),
286 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
287 mkLams tyvars $ Lam rep_var to_inner,
291 x = mkGenericLocal u1 tycon_ty
292 (u1 : uniqs) = builtinUniques
294 ----------------------
296 [the_datacon] = datacons
297 (_, newrep_ty) = newTyConRep tycon
299 ----------------------
301 -- Recurse over the sum first
302 -- The "2" is the first free unique
303 (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
305 mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
308 ----------------------------------------------------
310 ----------------------------------------------------
311 mk_sum_stuff :: [Unique] -- Base for generating unique names
312 -> [TyVar] -- Type variables over which the tycon is abstracted
313 -> [DataCon] -- The data constructors
314 -> ([Alt Id], CoreExpr, Id)
316 -- For example, given
317 -- data T = C | D Int Int Int
319 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
320 -- case cd of { Inl u -> C;
321 -- Inr abc -> case abc of { a :*: bc ->
322 -- case bc of { b :*: c ->
326 mk_sum_stuff us tyvars [datacon]
327 = ([from_alt], to_body_fn app_exp, rep_var)
329 types = dataConOrigArgTys datacon -- Existentials already excluded
330 datacon_vars = zipWith mkGenericLocal us types
331 us' = dropList types us
333 app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
334 from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
335 -- We are talking about *user* datacons here; hence
339 (_,args',_) = from_alt
340 us'' = dropList args' us' -- Conservative, but safe
342 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
344 mk_sum_stuff (u:us) tyvars datacons
345 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
346 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
347 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
350 (l_datacons, r_datacons) = splitInHalf datacons
351 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
352 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
353 rep_tys = [idType l_rep_var, idType r_rep_var]
354 rep_ty = mkTyConApp plusTyCon rep_tys
355 rep_var = mkGenericLocal u rep_ty
357 wrap :: DataCon -> [Alt Id] -> [Alt Id]
358 -- Wrap an application of the Inl or Inr constructor round each alternative
360 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
362 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
364 ----------------------------------------------------
365 -- Dealing with products
366 ----------------------------------------------------
367 mk_prod_stuff :: [Unique] -- Base for unique names
368 -> [Id] -- arg-ids; args of the original user-defined constructor
369 -- They are bound enclosing from_rhs
370 -- Please bind these in the to_body_fn
371 -> ([Unique], -- Depleted unique-name supply
372 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
373 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
374 Id) -- The rep-id; please bind this to the representation
377 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
378 -- \x -> case abc of { a :*: bc ->
379 -- case bc of { b :*: c ->
383 -- We need to use different uqiques in the branches
384 -- because the returned to_body_fns are nested.
385 -- Hence the returned unqique-name supply
387 mk_prod_stuff (u:us) [] -- Unit case
389 Var (dataConWrapId genUnitDataCon),
391 mkGenericLocal u (mkTyConApp genUnitTyCon []))
393 mk_prod_stuff us [arg_var] -- Singleton case
394 = (us, Var arg_var, \x -> x, arg_var)
396 mk_prod_stuff (u:us) arg_vars -- Two or more
398 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
399 \x -> Case (Var rep_var) rep_var
400 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
403 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
404 (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
405 (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
406 rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
407 rep_tys = [idType l_rep_var, idType r_rep_var]
410 A little utility function
413 splitInHalf :: [a] -> ([a],[a])
414 splitInHalf list = (left, right)
416 half = length list `div` 2
417 left = take half list
418 right = drop half list
420 mkGenericLocal :: Unique -> Type -> Id
421 mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
424 %************************************************************************
426 \subsection{Generating the RHS of a generic default method}
428 %************************************************************************
430 Generating the Generic default method. Uses the bimaps to generate the
431 actual method. All of this is rather incomplete, but it would be nice
432 to make even this work. Example
439 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
442 op = <mkGenericRhs op a T>
444 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
446 toOp :: Op Trep -> Op T
447 fromOp :: Op T -> Op Trep
449 (the bimap) and then fill in the RHS with
454 Remember, we're generating a RenamedHsExpr, so the result of all this
455 will be fed to the type checker. So the 'op' on the RHS will be
456 at the representation type for T, Trep.
459 A note about polymorphism. Suppose the class op is polymorphic:
462 op :: forall b. Ord b => a -> b -> b
464 Then we can still generate a bimap with
466 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
468 and fill in the instance decl thus
473 By the time the type checker has done its stuff we'll get
476 op = \b. \dict::Ord b. toOp b (op Trep b dict)
479 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
480 mkGenericRhs sel_id tyvar tycon
481 = HsApp (toEP bimap) (HsVar (idName sel_id))
483 -- Initialising the "Environment" with the from/to functions
484 -- on the datatype (actually tycon) in question
485 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
486 ep = EP (HsVar (idName from)) (HsVar (idName to))
488 -- Takes out the ForAll and the Class restrictions
489 -- in front of the type of the method.
490 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
492 -- Do it again! This deals with the case where the method type
493 -- is polymorphic -- see notes above
494 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
496 -- Now we probably have a tycon in front
497 -- of us, quite probably a FunTyCon.
498 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
500 type EPEnv = (TyVar, -- The class type variable
501 EP RenamedHsExpr, -- The EP it maps to
502 [TyVar] -- Other in-scope tyvars; they have an identity EP
506 generate_bimap :: EPEnv
509 -- Top level case - splitting the TyCon.
510 generate_bimap env@(tv,ep,local_tvs) ty
511 = case getTyVar_maybe ty of
512 Just tv1 | tv == tv1 -> ep -- The class tyvar
513 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
515 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
518 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
519 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
520 bimapApp env (Just (tycon, ty_args))
521 | tycon == funTyCon = bimapArrow arg_eps
522 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
523 | otherwise = -- Otherwise validGenericMethodType will
524 -- have checked that the type is a constant type
525 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
528 arg_eps = map (generate_bimap env) ty_args
529 (_,_,local_tvs) = env
532 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
533 bimapArrow [ep1, ep2]
534 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
535 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
537 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
538 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
542 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
543 toEP = mk_hs_lam [tuple_pat] to_body }
545 names = takeList eps genericNames
546 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
547 eps_w_names = eps `zip` names
548 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
549 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
552 genericNames :: [Name]
553 genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
554 (g1:g2:g3:_) = genericNames
556 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
558 idEP :: EP RenamedHsExpr
559 idEP = EP idexpr idexpr
561 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)