2 module Generics ( canDoGenerics, mkGenericBinds,
4 validGenericInstanceType, validGenericMethodType
9 import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
10 isTyVarTy, getTyVar_maybe, funTyCon
12 import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy )
13 import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon,
16 import TyCon ( TyCon, tyConName, tyConDataCons,
17 tyConHasGenerics, isBoxedTupleTyCon
19 import Name ( nameModuleName, nameOccName, getSrcLoc )
20 import OccName ( mkGenOcc1, mkGenOcc2 )
21 import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig )
22 import BasicTypes ( EP(..), Boxity(..) )
24 import VarSet ( varSetElems )
25 import Id ( Id, idType )
28 import SrcLoc ( generatedSrcLoc )
29 import Util ( takeList )
33 #include "HsVersions.h"
36 Roadmap of what's where in the Generics work.
37 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
43 Checks that HsNumTy has a "1" in it.
45 TcInstDcls.mkGenericInstance:
46 Checks for invalid type patterns, such as f {| Int |}
49 Checks for a method type that is too complicated;
50 e.g. has for-alls or lists in it
51 We could lift this restriction
53 TcClassDecl.mkDefMethRhs
54 Checks that the instance type is simple, in an instance decl
55 where we let the compiler fill in a generic method.
56 e.g. instance C (T Int)
57 is not valid if C has generic methods.
59 TcClassDecl.checkGenericClassIsUnary
60 Checks that we don't have generic methods in a multi-parameter class
62 TcClassDecl.checkDefaultBinds
63 Checks that all the equations for a method in a class decl
64 are generic, or all are non-generic
68 Checking that the type constructors which are present in Generic
69 patterns (not Unit, this is done differently) is done in mk_inst_info
70 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
71 HsOpTy is tied to Generic definitions which is not a very good design
72 feature, indeed a bug. However, the check is easy to move from
73 tcHsType back to mk_inst_info and everything will be fine. Also see
74 bug #5. [I don't think that this is the case anymore after SPJ's latest
75 changes in that regard. Delete this comment? -=chak/7Jun2]
79 Making generic information to put into a tycon. Constructs the
80 representation type, which, I think, are not used later. Perhaps it is
81 worth removing them from the GI datatype. Although it does get used in
82 the construction of conversion functions (internally).
86 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
90 Defines generic and other type and data constructors.
92 This is sadly incomplete, but will be added to.
95 Bugs & shortcomings of existing implementation:
96 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
98 2. Another pretty big bug I dscovered at the last minute when I was
99 testing the code is that at the moment the type variable of the class
100 is scoped over the entire declaration, including the patterns. For
101 instance, if I have the following code,
105 er {| Plus a b |} (Inl x) (Inl y) = er x y
106 er {| Plus a b |} (Inr x) (Inr y) = er x y
107 er {| Plus a b |} _ _ = False
109 and I print out the types of the generic patterns, I get the
110 following. Note that all the variable names for "a" are the same,
111 while for "b" they are all different.
114 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
115 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
116 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
118 This is a bug as if I change the code to
120 er {| Plus c b |} (Inl x) (Inl y) = er x y
122 all the names come out to be different.
124 Thus, all the types (Plus a b) come out to be different, so I cannot
125 compare them and test whether they are all the same and thus cannot
126 return an error if the type variables are different.
128 Temporary fix/hack. I am not checking for this, I just assume they are
129 the same, see line "check_ty = True" in TcInstDecls. When we resolve
130 the issue with variables, though - I assume that we will make them to
131 be the same in all the type patterns, jus uncomment the check and
132 everything should work smoothly.
134 Hence, I have also left the rather silly construction of:
135 * extracting all the type variables from all the types
136 * putting them *all* into the environment
137 * typechecking all the types
138 * selecting one of them and using it as the instance_ty.
140 (the alternative is to make sure that all the types are the same,
141 taking one, extracting its variables, putting them into the environment,
142 type checking it, using it as the instance_ty)
144 6. What happens if we do not supply all of the generic patterns? At
145 the moment, the compiler crashes with an error message "Non-exhaustive
146 patterns in a generic declaration"
149 What has not been addressed:
150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
152 Contexts. In the generated instance declarations for the 3 primitive
153 type constructors, we need contexts. It is unclear what those should
154 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
156 Type application. We have type application in expressions
157 (essentially) on the lhs of an equation. Do we want to allow it on the
160 Scoping of type variables in a generic definition. At the moment, (see
161 TcInstDecls) we extract the type variables inside the type patterns
162 and add them to the environment. See my bug #2 above. This seems pretty
167 %************************************************************************
169 \subsection{Getting the representation type out}
171 %************************************************************************
174 validGenericInstanceType :: Type -> Bool
175 -- Checks for validity of the type pattern in a generic
176 -- declaration. It's ok to have
178 -- but it's not OK to have
181 validGenericInstanceType inst_ty
182 = case tcSplitTyConApp_maybe inst_ty of
183 Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
186 validGenericMethodType :: Type -> Bool
187 -- At the moment we only allow method types built from
191 -- * an arbitrary type not involving the class type variables
192 -- e.g. this is ok: forall b. Ord b => [b] -> a
193 -- where a is the class variable
194 validGenericMethodType ty
197 (local_tvs, _, tau) = tcSplitSigmaTy ty
200 | isTyVarTy ty = True
201 | no_tyvars_in_ty = True
202 | otherwise = case tcSplitTyConApp_maybe ty of
203 Just (tc,tys) -> valid_tycon tc && all valid tys
206 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
208 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
209 -- Compare bimapApp, below
213 %************************************************************************
215 \subsection{Generating representation types}
217 %************************************************************************
220 canDoGenerics :: [DataCon] -> Bool
221 -- Called on source-code data types, to see if we should generate
222 -- generic functions for them. (This info is recorded in the interface file for
223 -- imported data types.)
225 canDoGenerics data_cons
226 = not (any bad_con data_cons) -- See comment below
227 && not (null data_cons) -- No values of the type
229 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc
230 -- If any of the constructor has an unboxed type as argument,
231 -- then we can't build the embedding-projection pair, because
232 -- it relies on instantiating *polymorphic* sum and product types
233 -- at the argument types of the constructors
235 -- Nor can we do the job if it's an existential data constructor,
237 -- Nor if the args are polymorphic types (I don't think)
238 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
241 %************************************************************************
243 \subsection{Generating the RHS of a generic default method}
245 %************************************************************************
248 type US = Int -- Local unique supply, just a plain Int
249 type FromAlt = (Pat RdrName, HsExpr RdrName)
251 mkGenericBinds :: [TyCon] -> MonoBinds RdrName
252 mkGenericBinds tcs = andMonoBindList [ mkTyConGenBinds tc
253 | tc <- tcs, tyConHasGenerics tc]
255 mkTyConGenBinds :: TyCon -> MonoBinds RdrName
256 mkTyConGenBinds tycon
257 = FunMonoBind from_RDR False {- Not infix -}
258 [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
261 FunMonoBind to_RDR False
262 [mkSimpleHsAlt (VarPat to_arg) to_body] loc
264 loc = getSrcLoc tycon
265 datacons = tyConDataCons tycon
266 (from_RDR, to_RDR) = mkGenericNames tycon
268 -- Recurse over the sum first
269 from_alts :: [FromAlt]
270 (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons
271 init_us = 1::Int -- Unique supply
273 ----------------------------------------------------
275 ----------------------------------------------------
277 mk_sum_stuff :: US -- Base for generating unique names
278 -> [DataCon] -- The data constructors
279 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
280 RdrName, HsExpr RdrName) -- Arg and body of the Trep->T "to" function
282 -- For example, given
283 -- data T = C | D Int Int Int
285 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
286 -- case cd of { Inl u -> C;
287 -- Inr abc -> case abc of { a :*: bc ->
288 -- case bc of { b :*: c ->
292 mk_sum_stuff us [datacon]
293 = ([from_alt], to_arg, to_body_fn app_exp)
295 n_args = dataConSourceArity datacon -- Existentials already excluded
297 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
300 datacon_rdr = getRdrName datacon
301 app_exp = mkHsVarApps datacon_rdr datacon_vars
302 from_alt = (mkConPat datacon_rdr datacon_vars, from_alt_rhs)
304 (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars
306 mk_sum_stuff us datacons
307 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
309 HsCase (HsVar to_arg)
310 [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body,
311 mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body]
314 (l_datacons, r_datacons) = splitInHalf datacons
315 (l_from_alts, l_to_arg, l_to_body) = mk_sum_stuff us' l_datacons
316 (r_from_alts, r_to_arg, r_to_body) = mk_sum_stuff us' r_datacons
318 to_arg = mkGenericLocal us
321 wrap :: RdrName -> [FromAlt] -> [FromAlt]
322 -- Wrap an application of the Inl or Inr constructor round each alternative
323 wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts]
326 ----------------------------------------------------
327 -- Dealing with products
328 ----------------------------------------------------
329 mk_prod_stuff :: US -- Base for unique names
330 -> [RdrName] -- arg-ids; args of the original user-defined constructor
331 -- They are bound enclosing from_rhs
332 -- Please bind these in the to_body_fn
333 -> (US, -- Depleted unique-name supply
334 HsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
336 HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation
339 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
340 -- \x -> case abc of { a :*: bc ->
341 -- case bc of { b :*: c ->
344 -- We need to use different uniques in the branches
345 -- because the returned to_body_fns are nested.
346 -- Hence the returned unqique-name supply
348 mk_prod_stuff us [] -- Unit case
350 HsVar genUnitDataCon_RDR,
354 mk_prod_stuff us [arg_var] -- Singleton case
355 = (us, HsVar arg_var, arg_var, \x -> x)
357 mk_prod_stuff us arg_vars -- Two or more
359 HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs,
361 \x -> HsCase (HsVar to_arg)
362 [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg])
363 (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc)
365 to_arg = mkGenericLocal us
366 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
367 (us', l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
368 (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
371 splitInHalf :: [a] -> ([a],[a])
372 splitInHalf list = (left, right)
374 half = length list `div` 2
375 left = take half list
376 right = drop half list
378 mkGenericLocal :: US -> RdrName
379 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
384 tc_name = tyConName tycon
385 tc_occ = nameOccName tc_name
386 tc_mod = nameModuleName tc_name
387 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
388 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
391 %************************************************************************
393 \subsection{Generating the RHS of a generic default method}
395 %************************************************************************
397 Generating the Generic default method. Uses the bimaps to generate the
398 actual method. All of this is rather incomplete, but it would be nice
399 to make even this work. Example
406 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
409 op = <mkGenericRhs op a T>
411 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
413 toOp :: Op Trep -> Op T
414 fromOp :: Op T -> Op Trep
416 (the bimap) and then fill in the RHS with
421 Remember, we're generating a RenamedHsExpr, so the result of all this
422 will be fed to the type checker. So the 'op' on the RHS will be
423 at the representation type for T, Trep.
426 A note about polymorphism. Suppose the class op is polymorphic:
429 op :: forall b. Ord b => a -> b -> b
431 Then we can still generate a bimap with
433 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
435 and fill in the instance decl thus
440 By the time the type checker has done its stuff we'll get
443 op = \b. \dict::Ord b. toOp b (op Trep b dict)
446 mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName
447 mkGenericRhs sel_id tyvar tycon
448 = HsApp (toEP bimap) (HsVar (getRdrName sel_id))
450 -- Initialising the "Environment" with the from/to functions
451 -- on the datatype (actually tycon) in question
452 (from_RDR, to_RDR) = mkGenericNames tycon
454 -- Takes out the ForAll and the Class restrictions
455 -- in front of the type of the method.
456 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
458 -- Do it again! This deals with the case where the method type
459 -- is polymorphic -- see notes above
460 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
462 -- Now we probably have a tycon in front
463 -- of us, quite probably a FunTyCon.
464 ep = EP (HsVar from_RDR) (HsVar to_RDR)
465 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
467 type EPEnv = (TyVar, -- The class type variable
468 EP (HsExpr RdrName), -- The EP it maps to
469 [TyVar] -- Other in-scope tyvars; they have an identity EP
473 generate_bimap :: EPEnv
475 -> EP (HsExpr RdrName)
476 -- Top level case - splitting the TyCon.
477 generate_bimap env@(tv,ep,local_tvs) ty
478 = case getTyVar_maybe ty of
479 Just tv1 | tv == tv1 -> ep -- The class tyvar
480 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
482 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
485 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName)
486 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
487 bimapApp env (Just (tycon, ty_args))
488 | tycon == funTyCon = bimapArrow arg_eps
489 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
490 | otherwise = -- Otherwise validGenericMethodType will
491 -- have checked that the type is a constant type
492 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
495 arg_eps = map (generate_bimap env) ty_args
496 (_,_,local_tvs) = env
499 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
500 bimapArrow [ep1, ep2]
501 = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body,
502 toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body }
504 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR))
505 to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR))
509 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
510 toEP = mk_hs_lam [tuple_pat] to_body }
512 names = takeList eps gs_RDR
513 tuple_pat = TuplePat (map VarPat names) Boxed
514 eps_w_names = eps `zip` names
515 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
516 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
519 a_RDR = mkVarUnqual FSLIT("a")
520 b_RDR = mkVarUnqual FSLIT("b")
521 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
523 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc))
525 idEP :: EP (HsExpr RdrName)
526 idEP = EP idexpr idexpr
528 idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR)