2 module Generics ( mkTyConGenInfo, mkGenericRhs,
3 validGenericInstanceType, validGenericMethodType
7 import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
8 import RnHsSyn ( RenamedHsExpr )
9 import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch )
11 import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
12 mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
13 mkFunTy, funResultTy, isTyVarTy, splitForAllTys,
14 splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
17 import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
19 import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable,
20 tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
22 import Name ( Name, mkSysLocalName )
23 import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
24 mkConApp, Alt, Bind (..), mkTyApps, mkVarApps )
25 import BasicTypes ( RecFlag(..), EP(..), Boxity(..) )
27 import VarSet ( isEmptyVarSet )
28 import Id ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName,
29 mkTemplateLocalsNum, mkVanillaId, mkId
31 import TysWiredIn ( genericTyCons,
32 genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
33 inlDataCon, crossTyCon, crossDataCon
35 import IdInfo ( vanillaIdInfo, setUnfoldingInfo )
36 import CoreUnfold ( mkTopUnfolding )
38 import Unique ( Uniquable(..), mkBuiltinUnique )
39 import SrcLoc ( builtinSrcLoc )
40 import Maybes ( maybeToBool, expectJust )
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 splitTyConApp_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 validGenericMethodType ty = valid ty
204 | isTyVarTy ty = True
205 | not (null arg_tys) = all valid arg_tys && valid res_ty
206 | no_tyvars_in_ty = True
207 | otherwise = isBoxedTupleTyCon tc && all valid tys
209 (arg_tys, res_ty) = splitFunTys ty
210 no_tyvars_in_ty = isEmptyVarSet (tyVarsOfType ty)
211 Just (tc,tys) = splitTyConApp_maybe ty
215 %************************************************************************
217 \subsection{Generating representation types}
219 %************************************************************************
222 mkTyConGenInfo :: DynFlags -> TyCon -> Name -> Name -> Maybe (EP Id)
223 -- mkTyConGenInfo is called twice
224 -- once from TysWiredIn for Tuples
225 -- once the typechecker TcTyDecls
226 -- to generate generic types and conversion functions for all datatypes.
228 -- Must only be called with an algebraic type.
230 -- The two names are the names constructed by the renamer
231 -- for the fromT and toT conversion functions.
233 mkTyConGenInfo dflags tycon from_name to_name
234 | dopt Opt_Generics dflags
237 | null datacons -- Abstractly imported types don't have
238 = Nothing -- to/from operations, (and should not need them)
240 -- If any of the constructor has an unboxed type as argument
241 -- then we can't build the embedding-projection pair, because
242 -- it relies on instantiating *polymorphic* sum and product types
243 -- at the argument types of the constructors
244 | any (any isUnLiftedType . dataConOrigArgTys) datacons
248 = Just (EP { fromEP = mkId from_name from_ty from_id_info,
249 toEP = mkId to_name to_ty to_id_info })
251 tyvars = tyConTyVars tycon -- [a, b, c]
252 datacons = tyConDataConsIfAvailable tycon -- [C, D]
253 tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
254 tyvar_tys = mkTyVarTys tyvars
256 from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
257 to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
259 from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
260 to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
262 (from_fn, to_fn, rep_ty)
264 = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x),
265 Var (dataConWrapId the_datacon),
269 = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts,
270 mkLams tyvars $ Lam rep_var to_inner,
274 x = mkTemplateLocal 1 tycon_ty
276 ----------------------
278 [the_datacon] = datacons
279 newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
281 ----------------------
283 -- Recurse over the sum first
284 -- The "2" is the first free unique
285 (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
289 ----------------------------------------------------
291 ----------------------------------------------------
292 mk_sum_stuff :: Int -- Base for generating unique names
293 -> [TyVar] -- Type variables over which the tycon is abstracted
294 -> [DataCon] -- The data constructors
295 -> ([Alt Id], CoreExpr, Id)
297 -- For example, given
298 -- data T = C | D Int Int Int
300 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
301 -- case cd of { Inl u -> C;
302 -- Inr abc -> case abc of { a :*: bc ->
303 -- case bc of { b :*: c ->
307 mk_sum_stuff i tyvars [datacon]
308 = ([from_alt], to_body_fn app_exp, rep_var)
310 types = dataConOrigArgTys datacon
311 datacon_vars = mkTemplateLocalsNum i types
312 new_i = i + length types
313 app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
314 from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
316 (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
318 mk_sum_stuff i tyvars datacons
319 = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
320 Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
321 (DataAlt inrDataCon, [r_rep_var], r_to_body)],
324 (l_datacons, r_datacons) = splitInHalf datacons
325 (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
326 (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
327 rep_tys = [idType l_rep_var, idType r_rep_var]
328 rep_ty = mkTyConApp plusTyCon rep_tys
329 rep_var = mkTemplateLocal i rep_ty
331 wrap :: DataCon -> [Alt Id] -> [Alt Id]
332 -- Wrap an application of the Inl or Inr constructor round each alternative
334 = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts]
336 datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
339 -- This constructs the c_of datatype from a DataCon and a Type
340 -- The identity function at the moment.
341 cOfConstr :: DataCon -> Type -> Type
345 ----------------------------------------------------
346 -- Dealing with products
347 ----------------------------------------------------
348 mk_prod_stuff :: Int -- Base for unique names
349 -> [Id] -- arg-ids; args of the original user-defined constructor
350 -- They are bound enclosing from_rhs
351 -- Please bind these in the to_body_fn
352 -> (Int, -- Depleted unique-name supply
353 CoreExpr, -- from-rhs: puts together the representation from the arg_ids
354 CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
355 Id) -- The rep-id; please bind this to the representation
358 -- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c),
359 -- \x -> case abc of { a :*: bc ->
360 -- case bc of { b :*: c ->
364 -- We need to use different uqiques in the branches
365 -- because the returned to_body_fns are nested.
366 -- Hence the returned unqique-name supply
368 mk_prod_stuff i [] -- Unit case
370 Var (dataConWrapId genUnitDataCon),
372 mkTemplateLocal i (mkTyConApp genUnitTyCon []))
374 mk_prod_stuff i [arg_var] -- Singleton case
375 = (i, Var arg_var, \x -> x, arg_var)
377 mk_prod_stuff i arg_vars -- Two or more
379 mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
380 \x -> Case (Var rep_var) rep_var
381 [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
384 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
385 (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
386 (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
387 rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
388 rep_tys = [idType l_rep_var, idType r_rep_var]
391 A little utility function
394 splitInHalf :: [a] -> ([a],[a])
395 splitInHalf list = (left, right)
397 half = length list `div` 2
398 left = take half list
399 right = drop half list
402 %************************************************************************
404 \subsection{Generating the RHS of a generic default method}
406 %************************************************************************
408 Generating the Generic default method. Uses the bimaps to generate the
409 actual method. All of this is rather incomplete, but it would be nice
410 to make even this work.
413 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
414 mkGenericRhs sel_id tyvar tycon
415 = HsApp (toEP bimap) (HsVar (idName sel_id))
417 -- Initialising the "Environment" with the from/to functions
418 -- on the datatype (actually tycon) in question
419 Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed
420 ep = EP (HsVar (idName from)) (HsVar (idName to))
422 -- Takes out the ForAll and the Class rstrictions in front of the
423 -- type of the method.
424 (_,_,op_ty) = splitSigmaTy (idType sel_id)
426 -- Now we probably have a tycon in front
427 -- of us, quite probably a FunTyCon.
428 bimap = generate_bimap (tyvar, ep) op_ty
430 -- EP is the environment of to/from bimaps, but as we only have one type
431 -- variable at the moment, there is only one EP.
434 generate_bimap :: (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr
435 -- Top level case - splitting the TyCon.
436 generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep
437 | otherwise = bimapApp (tv,ep) (splitTyConApp_maybe ty)
440 bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
441 bimapApp ep Nothing = panic "TcClassDecl: Type Application!"
442 bimapApp ep (Just (tycon, ty_args))
443 | tycon == funTyCon = bimapArrow arg_eps
444 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
445 | otherwise = -- Otherwise validGenericMethodType will
446 -- have checked that the type is a constant type
447 ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) )
450 arg_eps = map (generate_bimap ep) ty_args
453 bimapArrow [ep1, ep2]
454 = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
455 toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
457 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
458 to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
462 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
463 toEP = mk_hs_lam [tuple_pat] to_body }
465 names = take (length eps) genericNames
466 tuple_pat = TuplePatIn (map VarPatIn names) Boxed
467 eps_w_names = eps `zip` names
468 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
469 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
472 genericNames :: [Name]
473 genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
474 (g1:g2:g3:_) = genericNames
476 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc))
477 idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)