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 to_pat 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_pat, 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 InPat 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_pat, 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_pat, 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 (ConPatIn inlDataCon_RDR (PrefixCon [l_to_pat])) l_to_body,
307 mkSimpleHsAlt (ConPatIn inrDataCon_RDR (PrefixCon [r_to_pat])) r_to_body]
310 (l_datacons, r_datacons) = splitInHalf datacons
311 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
312 (r_from_alts, r_to_pat, 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
331 InPat RdrName, -- to_pat:
332 HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation
335 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
337 -- \<body-code> -> case abc of { a :*: bc ->
338 -- case bc of { b :*: c ->
341 -- We need to use different uniques in the branches
342 -- because the returned to_body_fns are nested.
343 -- Hence the returned unqique-name supply
345 mk_prod_stuff us [] -- Unit case
347 HsVar genUnitDataCon_RDR,
348 SigPatIn (VarPat (mkGenericLocal us))
349 (HsTyVar (getRdrName genUnitTyConName)),
350 -- Give a signature to the pattern so we get
351 -- data S a = Nil | S a
352 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
354 -- The (:: Unit) signature ensures that we'll infer the right
355 -- type for toS. If we leave it out, the type is too polymorphic
359 mk_prod_stuff us [arg_var] -- Singleton case
360 = (us, HsVar arg_var, VarPat arg_var, \x -> x)
362 mk_prod_stuff us arg_vars -- Two or more
364 HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs,
366 \x -> HsCase (HsVar to_arg)
367 [mkSimpleHsAlt (ConPatIn crossDataCon_RDR (PrefixCon [l_to_pat, r_to_pat]))
368 (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc)
370 to_arg = mkGenericLocal us
371 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
372 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
373 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
376 splitInHalf :: [a] -> ([a],[a])
377 splitInHalf list = (left, right)
379 half = length list `div` 2
380 left = take half list
381 right = drop half list
383 mkGenericLocal :: US -> RdrName
384 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
389 tc_name = tyConName tycon
390 tc_occ = nameOccName tc_name
391 tc_mod = nameModuleName tc_name
392 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
393 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
396 %************************************************************************
398 \subsection{Generating the RHS of a generic default method}
400 %************************************************************************
402 Generating the Generic default method. Uses the bimaps to generate the
403 actual method. All of this is rather incomplete, but it would be nice
404 to make even this work. Example
411 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
414 op = <mkGenericRhs op a T>
416 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
418 toOp :: Op Trep -> Op T
419 fromOp :: Op T -> Op Trep
421 (the bimap) and then fill in the RHS with
426 Remember, we're generating a RenamedHsExpr, so the result of all this
427 will be fed to the type checker. So the 'op' on the RHS will be
428 at the representation type for T, Trep.
431 A note about polymorphism. Suppose the class op is polymorphic:
434 op :: forall b. Ord b => a -> b -> b
436 Then we can still generate a bimap with
438 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
440 and fill in the instance decl thus
445 By the time the type checker has done its stuff we'll get
448 op = \b. \dict::Ord b. toOp b (op Trep b dict)
451 mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName
452 mkGenericRhs sel_id tyvar tycon
453 = HsApp (toEP bimap) (HsVar (getRdrName sel_id))
455 -- Initialising the "Environment" with the from/to functions
456 -- on the datatype (actually tycon) in question
457 (from_RDR, to_RDR) = mkGenericNames tycon
459 -- Takes out the ForAll and the Class restrictions
460 -- in front of the type of the method.
461 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
463 -- Do it again! This deals with the case where the method type
464 -- is polymorphic -- see notes above
465 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
467 -- Now we probably have a tycon in front
468 -- of us, quite probably a FunTyCon.
469 ep = EP (HsVar from_RDR) (HsVar to_RDR)
470 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
472 type EPEnv = (TyVar, -- The class type variable
473 EP (HsExpr RdrName), -- The EP it maps to
474 [TyVar] -- Other in-scope tyvars; they have an identity EP
478 generate_bimap :: EPEnv
480 -> EP (HsExpr RdrName)
481 -- Top level case - splitting the TyCon.
482 generate_bimap env@(tv,ep,local_tvs) ty
483 = case getTyVar_maybe ty of
484 Just tv1 | tv == tv1 -> ep -- The class tyvar
485 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
487 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
490 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName)
491 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
492 bimapApp env (Just (tycon, ty_args))
493 | tycon == funTyCon = bimapArrow arg_eps
494 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
495 | otherwise = -- Otherwise validGenericMethodType will
496 -- have checked that the type is a constant type
497 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
500 arg_eps = map (generate_bimap env) ty_args
501 (_,_,local_tvs) = env
504 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
505 bimapArrow [ep1, ep2]
506 = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body,
507 toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body }
509 from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR))
510 to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR))
514 = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
515 toEP = mk_hs_lam [tuple_pat] to_body }
517 names = takeList eps gs_RDR
518 tuple_pat = TuplePat (map VarPat names) Boxed
519 eps_w_names = eps `zip` names
520 to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
521 from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
524 a_RDR = mkVarUnqual FSLIT("a")
525 b_RDR = mkVarUnqual FSLIT("b")
526 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
528 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc))
530 idEP :: EP (HsExpr RdrName)
531 idEP = EP idexpr idexpr
533 idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR)