2 module Generics ( canDoGenerics, mkTyConGenericBinds,
4 validGenericInstanceType, validGenericMethodType
9 import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
10 isTyVarTy, getTyVar_maybe, funTyCon
12 import TcHsSyn ( mkSimpleHsAlt )
13 import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy )
14 import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon,
17 import TyCon ( TyCon, tyConName, tyConDataCons,
20 import Name ( nameModuleName, nameOccName, getSrcLoc )
21 import OccName ( mkGenOcc1, mkGenOcc2 )
22 import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig )
23 import BasicTypes ( EP(..), Boxity(..) )
25 import VarSet ( varSetElems )
26 import Id ( Id, idType )
29 import SrcLoc ( srcLocSpan, noLoc, Located(..) )
30 import Util ( takeList )
35 #include "HsVersions.h"
38 Roadmap of what's where in the Generics work.
39 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
45 Checks that HsNumTy has a "1" in it.
47 TcInstDcls.mkGenericInstance:
48 Checks for invalid type patterns, such as f {| Int |}
51 Checks for a method type that is too complicated;
52 e.g. has for-alls or lists in it
53 We could lift this restriction
55 TcClassDecl.mkDefMethRhs
56 Checks that the instance type is simple, in an instance decl
57 where we let the compiler fill in a generic method.
58 e.g. instance C (T Int)
59 is not valid if C has generic methods.
61 TcClassDecl.checkGenericClassIsUnary
62 Checks that we don't have generic methods in a multi-parameter class
64 TcClassDecl.checkDefaultBinds
65 Checks that all the equations for a method in a class decl
66 are generic, or all are non-generic
70 Checking that the type constructors which are present in Generic
71 patterns (not Unit, this is done differently) is done in mk_inst_info
72 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
73 HsOpTy is tied to Generic definitions which is not a very good design
74 feature, indeed a bug. However, the check is easy to move from
75 tcHsType back to mk_inst_info and everything will be fine. Also see
76 bug #5. [I don't think that this is the case anymore after SPJ's latest
77 changes in that regard. Delete this comment? -=chak/7Jun2]
81 Making generic information to put into a tycon. Constructs the
82 representation type, which, I think, are not used later. Perhaps it is
83 worth removing them from the GI datatype. Although it does get used in
84 the construction of conversion functions (internally).
88 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
92 Defines generic and other type and data constructors.
94 This is sadly incomplete, but will be added to.
97 Bugs & shortcomings of existing implementation:
98 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
100 2. Another pretty big bug I dscovered at the last minute when I was
101 testing the code is that at the moment the type variable of the class
102 is scoped over the entire declaration, including the patterns. For
103 instance, if I have the following code,
107 er {| Plus a b |} (Inl x) (Inl y) = er x y
108 er {| Plus a b |} (Inr x) (Inr y) = er x y
109 er {| Plus a b |} _ _ = False
111 and I print out the types of the generic patterns, I get the
112 following. Note that all the variable names for "a" are the same,
113 while for "b" they are all different.
116 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
117 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
118 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
120 This is a bug as if I change the code to
122 er {| Plus c b |} (Inl x) (Inl y) = er x y
124 all the names come out to be different.
126 Thus, all the types (Plus a b) come out to be different, so I cannot
127 compare them and test whether they are all the same and thus cannot
128 return an error if the type variables are different.
130 Temporary fix/hack. I am not checking for this, I just assume they are
131 the same, see line "check_ty = True" in TcInstDecls. When we resolve
132 the issue with variables, though - I assume that we will make them to
133 be the same in all the type patterns, jus uncomment the check and
134 everything should work smoothly.
136 Hence, I have also left the rather silly construction of:
137 * extracting all the type variables from all the types
138 * putting them *all* into the environment
139 * typechecking all the types
140 * selecting one of them and using it as the instance_ty.
142 (the alternative is to make sure that all the types are the same,
143 taking one, extracting its variables, putting them into the environment,
144 type checking it, using it as the instance_ty)
146 6. What happens if we do not supply all of the generic patterns? At
147 the moment, the compiler crashes with an error message "Non-exhaustive
148 patterns in a generic declaration"
151 What has not been addressed:
152 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
154 Contexts. In the generated instance declarations for the 3 primitive
155 type constructors, we need contexts. It is unclear what those should
156 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
158 Type application. We have type application in expressions
159 (essentially) on the lhs of an equation. Do we want to allow it on the
162 Scoping of type variables in a generic definition. At the moment, (see
163 TcInstDecls) we extract the type variables inside the type patterns
164 and add them to the environment. See my bug #2 above. This seems pretty
169 %************************************************************************
171 \subsection{Getting the representation type out}
173 %************************************************************************
176 validGenericInstanceType :: Type -> Bool
177 -- Checks for validity of the type pattern in a generic
178 -- declaration. It's ok to have
180 -- but it's not OK to have
183 validGenericInstanceType inst_ty
184 = case tcSplitTyConApp_maybe inst_ty of
185 Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
188 validGenericMethodType :: Type -> Bool
189 -- At the moment we only allow method types built from
193 -- * an arbitrary type not involving the class type variables
194 -- e.g. this is ok: forall b. Ord b => [b] -> a
195 -- where a is the class variable
196 validGenericMethodType ty
199 (local_tvs, _, tau) = tcSplitSigmaTy ty
202 | isTyVarTy ty = True
203 | no_tyvars_in_ty = True
204 | otherwise = case tcSplitTyConApp_maybe ty of
205 Just (tc,tys) -> valid_tycon tc && all valid tys
208 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
210 valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc
211 -- Compare bimapApp, below
215 %************************************************************************
217 \subsection{Generating representation types}
219 %************************************************************************
222 canDoGenerics :: [DataCon] -> Bool
223 -- Called on source-code data types, to see if we should generate
224 -- generic functions for them. (This info is recorded in the interface file for
225 -- imported data types.)
227 canDoGenerics data_cons
228 = not (any bad_con data_cons) -- See comment below
229 && not (null data_cons) -- No values of the type
231 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
232 -- If any of the constructor has an unboxed type as argument,
233 -- then we can't build the embedding-projection pair, because
234 -- it relies on instantiating *polymorphic* sum and product types
235 -- at the argument types of the constructors
237 -- Nor can we do the job if it's an existential data constructor,
239 -- Nor if the args are polymorphic types (I don't think)
240 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
243 %************************************************************************
245 \subsection{Generating the RHS of a generic default method}
247 %************************************************************************
250 type US = Int -- Local unique supply, just a plain Int
251 type FromAlt = (LPat RdrName, LHsExpr RdrName)
253 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
254 mkTyConGenericBinds tycon
255 = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -}
256 (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])))
259 unitBag (L loc (FunBind (L loc to_RDR) False
260 (mkMatchGroup [mkSimpleHsAlt to_pat to_body])))
262 loc = srcLocSpan (getSrcLoc tycon)
263 datacons = tyConDataCons tycon
264 (from_RDR, to_RDR) = mkGenericNames tycon
266 -- Recurse over the sum first
267 from_alts :: [FromAlt]
268 (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
269 init_us = 1::Int -- Unique supply
271 ----------------------------------------------------
273 ----------------------------------------------------
275 mk_sum_stuff :: US -- Base for generating unique names
276 -> [DataCon] -- The data constructors
277 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
278 InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
280 -- For example, given
281 -- data T = C | D Int Int Int
283 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
284 -- case cd of { Inl u -> C;
285 -- Inr abc -> case abc of { a :*: bc ->
286 -- case bc of { b :*: c ->
290 mk_sum_stuff us [datacon]
291 = ([from_alt], to_pat, to_body_fn app_exp)
293 n_args = dataConSourceArity datacon -- Existentials already excluded
295 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
298 datacon_rdr = getRdrName datacon
299 app_exp = nlHsVarApps datacon_rdr datacon_vars
300 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
302 (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
304 mk_sum_stuff us datacons
305 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
307 noLoc (HsCase (nlHsVar to_arg)
308 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
309 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
311 (l_datacons, r_datacons) = splitInHalf datacons
312 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
313 (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
315 to_arg = mkGenericLocal us
318 wrap :: RdrName -> [FromAlt] -> [FromAlt]
319 -- Wrap an application of the Inl or Inr constructor round each alternative
320 wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
323 ----------------------------------------------------
324 -- Dealing with products
325 ----------------------------------------------------
326 mk_prod_stuff :: US -- Base for unique names
327 -> [RdrName] -- arg-ids; args of the original user-defined constructor
328 -- They are bound enclosing from_rhs
329 -- Please bind these in the to_body_fn
330 -> (US, -- Depleted unique-name supply
331 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
332 InPat RdrName, -- to_pat:
333 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
336 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
338 -- \<body-code> -> case abc of { a :*: bc ->
339 -- case bc of { b :*: c ->
342 -- We need to use different uniques in the branches
343 -- because the returned to_body_fns are nested.
344 -- Hence the returned unqique-name supply
346 mk_prod_stuff us [] -- Unit case
348 nlHsVar genUnitDataCon_RDR,
349 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
350 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
351 -- Give a signature to the pattern so we get
352 -- data S a = Nil | S a
353 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
355 -- The (:: Unit) signature ensures that we'll infer the right
356 -- type for toS. If we leave it out, the type is too polymorphic
360 mk_prod_stuff us [arg_var] -- Singleton case
361 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
363 mk_prod_stuff us arg_vars -- Two or more
365 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
368 \x -> noLoc (HsCase (nlHsVar to_arg)
369 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
371 to_arg = mkGenericLocal us
372 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
373 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
374 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
375 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
377 splitInHalf :: [a] -> ([a],[a])
378 splitInHalf list = (left, right)
380 half = length list `div` 2
381 left = take half list
382 right = drop half list
384 mkGenericLocal :: US -> RdrName
385 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
390 tc_name = tyConName tycon
391 tc_occ = nameOccName tc_name
392 tc_mod = nameModuleName tc_name
393 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
394 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
397 %************************************************************************
399 \subsection{Generating the RHS of a generic default method}
401 %************************************************************************
403 Generating the Generic default method. Uses the bimaps to generate the
404 actual method. All of this is rather incomplete, but it would be nice
405 to make even this work. Example
412 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
415 op = <mkGenericRhs op a T>
417 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
419 toOp :: Op Trep -> Op T
420 fromOp :: Op T -> Op Trep
422 (the bimap) and then fill in the RHS with
427 Remember, we're generating a RenamedHsExpr, so the result of all this
428 will be fed to the type checker. So the 'op' on the RHS will be
429 at the representation type for T, Trep.
432 A note about polymorphism. Suppose the class op is polymorphic:
435 op :: forall b. Ord b => a -> b -> b
437 Then we can still generate a bimap with
439 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
441 and fill in the instance decl thus
446 By the time the type checker has done its stuff we'll get
449 op = \b. \dict::Ord b. toOp b (op Trep b dict)
452 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
453 mkGenericRhs sel_id tyvar tycon
454 = mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
456 -- Initialising the "Environment" with the from/to functions
457 -- on the datatype (actually tycon) in question
458 (from_RDR, to_RDR) = mkGenericNames tycon
460 -- Takes out the ForAll and the Class restrictions
461 -- in front of the type of the method.
462 (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
464 -- Do it again! This deals with the case where the method type
465 -- is polymorphic -- see notes above
466 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
468 -- Now we probably have a tycon in front
469 -- of us, quite probably a FunTyCon.
470 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
471 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
473 type EPEnv = (TyVar, -- The class type variable
474 EP (LHsExpr RdrName), -- The EP it maps to
475 [TyVar] -- Other in-scope tyvars; they have an identity EP
479 generate_bimap :: EPEnv
481 -> EP (LHsExpr RdrName)
482 -- Top level case - splitting the TyCon.
483 generate_bimap env@(tv,ep,local_tvs) ty
484 = case getTyVar_maybe ty of
485 Just tv1 | tv == tv1 -> ep -- The class tyvar
486 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
488 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
491 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName)
492 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
493 bimapApp env (Just (tycon, ty_args))
494 | tycon == funTyCon = bimapArrow arg_eps
495 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
496 | otherwise = -- Otherwise validGenericMethodType will
497 -- have checked that the type is a constant type
498 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
501 arg_eps = map (generate_bimap env) ty_args
502 (_,_,local_tvs) = env
505 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
506 bimapArrow [ep1, ep2]
507 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
508 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
510 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
511 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
515 = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
516 toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
518 names = takeList eps gs_RDR
519 tuple_pat = TuplePat (map nlVarPat names) Boxed
520 eps_w_names = eps `zip` names
521 to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
522 from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
525 a_RDR = mkVarUnqual FSLIT("a")
526 b_RDR = mkVarUnqual FSLIT("b")
527 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
529 idEP :: EP (LHsExpr RdrName)
530 idEP = EP idexpr idexpr
532 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)