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, 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 ( noCafIdInfo, 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 = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
275 `setArityInfo` exprArity from_fn
276 to_id_info = noCafIdInfo `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 the_arg_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 the_arg_ty = head (dataConOrigArgTys the_datacon)
304 -- NB: we use the arg type of the data constructor, rather than
305 -- the representation type of the newtype; in degnerate (recursive)
306 -- cases the rep type might be (), but the arg type is still T:
309 ----------------------
311 -- Recurse over the sum first
312 -- The "2" is the first free unique
313 (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
315 mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
318 ----------------------------------------------------
320 ----------------------------------------------------
321 mk_sum_stuff :: [Unique] -- Base for generating unique names
322 -> [TyVar] -- Type variables over which the tycon is abstracted
323 -> [DataCon] -- The data constructors
324 -> ([Alt Id], CoreExpr, Id)
326 -- For example, given
327 -- data T = C | D Int Int Int
329 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
330 -- case cd of { Inl u -> C;
331 -- Inr abc -> case abc of { a :*: bc ->
332 -- case bc of { b :*: c ->
336 mk_sum_stuff us tyvars [datacon]
337 = ([from_alt], to_body_fn app_exp, rep_var)
339 types = dataConOrigArgTys datacon -- Existentials already excluded
340 datacon_vars = zipWith mkGenericLocal us types
341 us' = dropList types us
343 app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
344 from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
345 -- We are talking about *user* datacons here; hence
349 (_,args',_) = from_alt
350 us'' = dropList args' us' -- Conservative, but safe
352 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
354 mk_sum_stuff (u:us) tyvars datacons
355 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
356 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
357 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
360 (l_datacons, r_datacons) = splitInHalf datacons
361 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
362 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
363 rep_tys = [idType l_rep_var, idType r_rep_var]
364 rep_ty = mkTyConApp plusTyCon rep_tys
365 rep_var = mkGenericLocal u rep_ty
367 wrap :: DataCon -> [Alt Id] -> [Alt Id]
368 -- Wrap an application of the Inl or Inr constructor round each alternative
370 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
372 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
374 ----------------------------------------------------
375 -- Dealing with products
376 ----------------------------------------------------
377 mk_prod_stuff :: [Unique] -- Base for unique names
378 -> [Id] -- arg-ids; args of the original user-defined constructor
379 -- They are bound enclosing from_rhs
380 -- Please bind these in the to_body_fn
381 -> ([Unique], -- Depleted unique-name supply
382 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
383 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
384 Id) -- The rep-id; please bind this to the representation
387 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
388 -- \x -> case abc of { a :*: bc ->
389 -- case bc of { b :*: c ->
393 -- We need to use different uqiques in the branches
394 -- because the returned to_body_fns are nested.
395 -- Hence the returned unqique-name supply
397 mk_prod_stuff (u:us) [] -- Unit case
399 Var (dataConWrapId genUnitDataCon),
401 mkGenericLocal u (mkTyConApp genUnitTyCon []))
403 mk_prod_stuff us [arg_var] -- Singleton case
404 = (us, Var arg_var, \x -> x, arg_var)
406 mk_prod_stuff (u:us) arg_vars -- Two or more
408 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
409 \x -> Case (Var rep_var) rep_var
410 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
413 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
414 (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
415 (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
416 rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
417 rep_tys = [idType l_rep_var, idType r_rep_var]
420 A little utility function
423 splitInHalf :: [a] -> ([a],[a])
424 splitInHalf list = (left, right)
426 half = length list `div` 2
427 left = take half list
428 right = drop half list
430 mkGenericLocal :: Unique -> Type -> Id
431 mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
434 %************************************************************************
436 \subsection{Generating the RHS of a generic default method}
438 %************************************************************************
440 Generating the Generic default method. Uses the bimaps to generate the
441 actual method. All of this is rather incomplete, but it would be nice
442 to make even this work. Example
449 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
452 op = <mkGenericRhs op a T>
454 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
456 toOp :: Op Trep -> Op T
457 fromOp :: Op T -> Op Trep
459 (the bimap) and then fill in the RHS with
464 Remember, we're generating a RenamedHsExpr, so the result of all this
465 will be fed to the type checker. So the 'op' on the RHS will be
466 at the representation type for T, Trep.
469 A note about polymorphism. Suppose the class op is polymorphic:
472 op :: forall b. Ord b => a -> b -> b
474 Then we can still generate a bimap with
476 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
478 and fill in the instance decl thus
483 By the time the type checker has done its stuff we'll get
486 op = \b. \dict::Ord b. toOp b (op Trep b dict)
489 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
490 mkGenericRhs sel_id tyvar tycon
491 = HsApp (toEP bimap) (HsVar (idName sel_id))
493 -- Initialising the "Environment" with the from/to functions
494 -- on the datatype (actually tycon) in question
495 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
496 ep = EP (HsVar (idName from)) (HsVar (idName to))
498 -- Takes out the ForAll and the Class restrictions
499 -- in front of the type of the method.
500 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
502 -- Do it again! This deals with the case where the method type
503 -- is polymorphic -- see notes above
504 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
506 -- Now we probably have a tycon in front
507 -- of us, quite probably a FunTyCon.
508 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
510 type EPEnv = (TyVar, -- The class type variable
511 EP RenamedHsExpr, -- The EP it maps to
512 [TyVar] -- Other in-scope tyvars; they have an identity EP
516 generate_bimap :: EPEnv
519 -- Top level case - splitting the TyCon.
520 generate_bimap env@(tv,ep,local_tvs) ty
521 = case getTyVar_maybe ty of
522 Just tv1 | tv == tv1 -> ep -- The class tyvar
523 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
525 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
528 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
529 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
530 bimapApp env (Just (tycon, ty_args))
531 | tycon == funTyCon = bimapArrow arg_eps
532 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
533 | otherwise = -- Otherwise validGenericMethodType will
534 -- have checked that the type is a constant type
535 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
538 arg_eps = map (generate_bimap env) ty_args
539 (_,_,local_tvs) = env
542 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
543 bimapArrow [ep1, ep2]
544 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
545 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
547 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
548 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
552 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
553 toEP = mk_hs_lam [tuple_pat] to_body }
555 names = takeList eps genericNames
556 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
557 eps_w_names = eps `zip` names
558 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
559 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
562 genericNames :: [Name]
563 genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]
564 (g1:g2:g3:_) = genericNames
566 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
568 idEP :: EP RenamedHsExpr
569 idEP = EP idexpr idexpr
571 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)