2 module Generics ( canDoGenerics, mkTyConGenericBinds,
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 mkTyConGenericBinds :: TyCon -> MonoBinds RdrName
252 mkTyConGenericBinds tycon
253 = FunMonoBind from_RDR False {- Not infix -}
254 [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
257 FunMonoBind to_RDR False
258 [mkSimpleHsAlt (VarPat to_arg) to_body] loc
260 loc = getSrcLoc tycon
261 datacons = tyConDataCons tycon
262 (from_RDR, to_RDR) = mkGenericNames tycon
264 -- Recurse over the sum first
265 from_alts :: [FromAlt]
266 (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons
267 init_us = 1::Int -- Unique supply
269 ----------------------------------------------------
271 ----------------------------------------------------
273 mk_sum_stuff :: US -- Base for generating unique names
274 -> [DataCon] -- The data constructors
275 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
276 RdrName, HsExpr RdrName) -- Arg and body of the Trep->T "to" function
278 -- For example, given
279 -- data T = C | D Int Int Int
281 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
282 -- case cd of { Inl u -> C;
283 -- Inr abc -> case abc of { a :*: bc ->
284 -- case bc of { b :*: c ->
288 mk_sum_stuff us [datacon]
289 = ([from_alt], to_arg, to_body_fn app_exp)
291 n_args = dataConSourceArity datacon -- Existentials already excluded
293 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
296 datacon_rdr = getRdrName datacon
297 app_exp = mkHsVarApps datacon_rdr datacon_vars
298 from_alt = (mkConPat datacon_rdr datacon_vars, from_alt_rhs)
300 (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars
302 mk_sum_stuff us datacons
303 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
305 HsCase (HsVar to_arg)
306 [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body,
307 mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body]
310 (l_datacons, r_datacons) = splitInHalf datacons
311 (l_from_alts, l_to_arg, l_to_body) = mk_sum_stuff us' l_datacons
312 (r_from_alts, r_to_arg, r_to_body) = mk_sum_stuff us' r_datacons
314 to_arg = mkGenericLocal us
317 wrap :: RdrName -> [FromAlt] -> [FromAlt]
318 -- Wrap an application of the Inl or Inr constructor round each alternative
319 wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts]
322 ----------------------------------------------------
323 -- Dealing with products
324 ----------------------------------------------------
325 mk_prod_stuff :: US -- Base for unique names
326 -> [RdrName] -- arg-ids; args of the original user-defined constructor
327 -- They are bound enclosing from_rhs
328 -- Please bind these in the to_body_fn
329 -> (US, -- Depleted unique-name supply
330 HsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
332 HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation
335 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
336 -- \x -> case abc of { a :*: bc ->
337 -- case bc of { b :*: c ->
340 -- We need to use different uniques in the branches
341 -- because the returned to_body_fns are nested.
342 -- Hence the returned unqique-name supply
344 mk_prod_stuff us [] -- Unit case
346 HsVar genUnitDataCon_RDR,
350 mk_prod_stuff us [arg_var] -- Singleton case
351 = (us, HsVar arg_var, arg_var, \x -> x)
353 mk_prod_stuff us arg_vars -- Two or more
355 HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs,
357 \x -> HsCase (HsVar to_arg)
358 [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg])
359 (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc)
361 to_arg = mkGenericLocal us
362 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
363 (us', l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
364 (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
367 splitInHalf :: [a] -> ([a],[a])
368 splitInHalf list = (left, right)
370 half = length list `div` 2
371 left = take half list
372 right = drop half list
374 mkGenericLocal :: US -> RdrName
375 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
380 tc_name = tyConName tycon
381 tc_occ = nameOccName tc_name
382 tc_mod = nameModuleName tc_name
383 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
384 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
387 %************************************************************************
389 \subsection{Generating the RHS of a generic default method}
391 %************************************************************************
393 Generating the Generic default method. Uses the bimaps to generate the
394 actual method. All of this is rather incomplete, but it would be nice
395 to make even this work. Example
402 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
405 op = <mkGenericRhs op a T>
407 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
409 toOp :: Op Trep -> Op T
410 fromOp :: Op T -> Op Trep
412 (the bimap) and then fill in the RHS with
417 Remember, we're generating a RenamedHsExpr, so the result of all this
418 will be fed to the type checker. So the 'op' on the RHS will be
419 at the representation type for T, Trep.
422 A note about polymorphism. Suppose the class op is polymorphic:
425 op :: forall b. Ord b => a -> b -> b
427 Then we can still generate a bimap with
429 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
431 and fill in the instance decl thus
436 By the time the type checker has done its stuff we'll get
439 op = \b. \dict::Ord b. toOp b (op Trep b dict)
442 mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName
443 mkGenericRhs sel_id tyvar tycon
444 = HsApp (toEP bimap) (HsVar (getRdrName sel_id))
446 -- Initialising the "Environment" with the from/to functions
447 -- on the datatype (actually tycon) in question
448 (from_RDR, to_RDR) = mkGenericNames tycon
450 -- Takes out the ForAll and the Class restrictions
451 -- in front of the type of the method.
452 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
454 -- Do it again! This deals with the case where the method type
455 -- is polymorphic -- see notes above
456 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
458 -- Now we probably have a tycon in front
459 -- of us, quite probably a FunTyCon.
460 ep = EP (HsVar from_RDR) (HsVar to_RDR)
461 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
463 type EPEnv = (TyVar, -- The class type variable
464 EP (HsExpr RdrName), -- The EP it maps to
465 [TyVar] -- Other in-scope tyvars; they have an identity EP
469 generate_bimap :: EPEnv
471 -> EP (HsExpr RdrName)
472 -- Top level case - splitting the TyCon.
473 generate_bimap env@(tv,ep,local_tvs) ty
474 = case getTyVar_maybe ty of
475 Just tv1 | tv == tv1 -> ep -- The class tyvar
476 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
478 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
481 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName)
482 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
483 bimapApp env (Just (tycon, ty_args))
484 | tycon == funTyCon = bimapArrow arg_eps
485 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
486 | otherwise = -- Otherwise validGenericMethodType will
487 -- have checked that the type is a constant type
488 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
491 arg_eps = map (generate_bimap env) ty_args
492 (_,_,local_tvs) = env
495 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
496 bimapArrow [ep1, ep2]
497 = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body,
498 toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body }
500 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR))
501 to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR))
505 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
506 toEP = mk_hs_lam [tuple_pat] to_body }
508 names = takeList eps gs_RDR
509 tuple_pat = TuplePat (map VarPat names) Boxed
510 eps_w_names = eps `zip` names
511 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
512 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
515 a_RDR = mkVarUnqual FSLIT("a")
516 b_RDR = mkVarUnqual FSLIT("b")
517 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
519 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc))
521 idEP :: EP (HsExpr RdrName)
522 idEP = EP idexpr idexpr
524 idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR)