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, tcSplitPhiTy, applyTy,
15 import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon,
18 import TyCon ( TyCon, tyConName, tyConDataCons,
21 import Name ( nameModule, nameOccName, getSrcLoc )
22 import OccName ( mkGenOcc1, mkGenOcc2 )
23 import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig )
24 import BasicTypes ( EP(..), Boxity(..) )
26 import VarSet ( varSetElems )
27 import Id ( Id, idType )
28 import TysWiredIn ( listTyCon )
31 import SrcLoc ( srcLocSpan, noLoc, Located(..) )
32 import Util ( takeList, isSingleton )
37 #include "HsVersions.h"
40 Roadmap of what's where in the Generics work.
41 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
47 Checks that HsNumTy has a "1" in it.
49 TcInstDcls.mkGenericInstance:
50 Checks for invalid type patterns, such as f {| Int |}
53 Checks for a method type that is too complicated;
54 e.g. has for-alls or lists in it
55 We could lift this restriction
57 TcClassDecl.mkDefMethRhs
58 Checks that the instance type is simple, in an instance decl
59 where we let the compiler fill in a generic method.
60 e.g. instance C (T Int)
61 is not valid if C has generic methods.
63 TcClassDecl.checkGenericClassIsUnary
64 Checks that we don't have generic methods in a multi-parameter class
66 TcClassDecl.checkDefaultBinds
67 Checks that all the equations for a method in a class decl
68 are generic, or all are non-generic
72 Checking that the type constructors which are present in Generic
73 patterns (not Unit, this is done differently) is done in mk_inst_info
74 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
75 HsOpTy is tied to Generic definitions which is not a very good design
76 feature, indeed a bug. However, the check is easy to move from
77 tcHsType back to mk_inst_info and everything will be fine. Also see
78 bug #5. [I don't think that this is the case anymore after SPJ's latest
79 changes in that regard. Delete this comment? -=chak/7Jun2]
83 Making generic information to put into a tycon. Constructs the
84 representation type, which, I think, are not used later. Perhaps it is
85 worth removing them from the GI datatype. Although it does get used in
86 the construction of conversion functions (internally).
90 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
94 Defines generic and other type and data constructors.
96 This is sadly incomplete, but will be added to.
99 Bugs & shortcomings of existing implementation:
100 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
102 2. Another pretty big bug I dscovered at the last minute when I was
103 testing the code is that at the moment the type variable of the class
104 is scoped over the entire declaration, including the patterns. For
105 instance, if I have the following code,
109 er {| Plus a b |} (Inl x) (Inl y) = er x y
110 er {| Plus a b |} (Inr x) (Inr y) = er x y
111 er {| Plus a b |} _ _ = False
113 and I print out the types of the generic patterns, I get the
114 following. Note that all the variable names for "a" are the same,
115 while for "b" they are all different.
118 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
119 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
120 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
122 This is a bug as if I change the code to
124 er {| Plus c b |} (Inl x) (Inl y) = er x y
126 all the names come out to be different.
128 Thus, all the types (Plus a b) come out to be different, so I cannot
129 compare them and test whether they are all the same and thus cannot
130 return an error if the type variables are different.
132 Temporary fix/hack. I am not checking for this, I just assume they are
133 the same, see line "check_ty = True" in TcInstDecls. When we resolve
134 the issue with variables, though - I assume that we will make them to
135 be the same in all the type patterns, jus uncomment the check and
136 everything should work smoothly.
138 Hence, I have also left the rather silly construction of:
139 * extracting all the type variables from all the types
140 * putting them *all* into the environment
141 * typechecking all the types
142 * selecting one of them and using it as the instance_ty.
144 (the alternative is to make sure that all the types are the same,
145 taking one, extracting its variables, putting them into the environment,
146 type checking it, using it as the instance_ty)
148 6. What happens if we do not supply all of the generic patterns? At
149 the moment, the compiler crashes with an error message "Non-exhaustive
150 patterns in a generic declaration"
153 What has not been addressed:
154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 Contexts. In the generated instance declarations for the 3 primitive
157 type constructors, we need contexts. It is unclear what those should
158 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
160 Type application. We have type application in expressions
161 (essentially) on the lhs of an equation. Do we want to allow it on the
164 Scoping of type variables in a generic definition. At the moment, (see
165 TcInstDecls) we extract the type variables inside the type patterns
166 and add them to the environment. See my bug #2 above. This seems pretty
171 %************************************************************************
173 \subsection{Getting the representation type out}
175 %************************************************************************
178 validGenericInstanceType :: Type -> Bool
179 -- Checks for validity of the type pattern in a generic
180 -- declaration. It's ok to have
182 -- but it's not OK to have
185 validGenericInstanceType inst_ty
186 = case tcSplitTyConApp_maybe inst_ty of
187 Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
190 validGenericMethodType :: Type -> Bool
191 -- At the moment we only allow method types built from
196 -- * an arbitrary type not involving the class type variables
197 -- e.g. this is ok: forall b. Ord b => [b] -> a
198 -- where a is the class variable
199 validGenericMethodType ty
202 (local_tvs, _, tau) = tcSplitSigmaTy ty
205 | isTyVarTy ty = True
206 | no_tyvars_in_ty = True
207 | otherwise = case tcSplitTyConApp_maybe ty of
208 Just (tc,tys) -> valid_tycon tc && all valid tys
211 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
213 valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
214 -- Compare bimapApp, below
218 %************************************************************************
220 \subsection{Generating representation types}
222 %************************************************************************
225 canDoGenerics :: [DataCon] -> Bool
226 -- Called on source-code data types, to see if we should generate
227 -- generic functions for them. (This info is recorded in the interface file for
228 -- imported data types.)
230 canDoGenerics data_cons
231 = not (any bad_con data_cons) -- See comment below
232 && not (null data_cons) -- No values of the type
234 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
235 -- If any of the constructor has an unboxed type as argument,
236 -- then we can't build the embedding-projection pair, because
237 -- it relies on instantiating *polymorphic* sum and product types
238 -- at the argument types of the constructors
240 -- Nor can we do the job if it's an existential data constructor,
242 -- Nor if the args are polymorphic types (I don't think)
243 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
246 %************************************************************************
248 \subsection{Generating the RHS of a generic default method}
250 %************************************************************************
253 type US = Int -- Local unique supply, just a plain Int
254 type FromAlt = (LPat RdrName, LHsExpr RdrName)
256 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
257 mkTyConGenericBinds tycon
258 = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
260 unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
262 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
263 to_matches = [mkSimpleHsAlt to_pat to_body]
264 loc = srcLocSpan (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_pat, 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 InPat RdrName, LHsExpr 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_pat, 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 = nlHsVarApps datacon_rdr datacon_vars
302 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
304 (_, from_alt_rhs, to_pat, 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 noLoc (HsCase (nlHsVar to_arg)
310 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
311 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
313 (l_datacons, r_datacons) = splitInHalf datacons
314 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
315 (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
317 to_arg = mkGenericLocal us
320 wrap :: RdrName -> [FromAlt] -> [FromAlt]
321 -- Wrap an application of the Inl or Inr constructor round each alternative
322 wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
325 ----------------------------------------------------
326 -- Dealing with products
327 ----------------------------------------------------
328 mk_prod_stuff :: US -- Base for unique names
329 -> [RdrName] -- arg-ids; args of the original user-defined constructor
330 -- They are bound enclosing from_rhs
331 -- Please bind these in the to_body_fn
332 -> (US, -- Depleted unique-name supply
333 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
334 InPat RdrName, -- to_pat:
335 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
338 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
340 -- \<body-code> -> 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 nlHsVar genUnitDataCon_RDR,
351 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
352 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
353 -- Give a signature to the pattern so we get
354 -- data S a = Nil | S a
355 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
357 -- The (:: Unit) signature ensures that we'll infer the right
358 -- type for toS. If we leave it out, the type is too polymorphic
362 mk_prod_stuff us [arg_var] -- Singleton case
363 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
365 mk_prod_stuff us arg_vars -- Two or more
367 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
370 \x -> noLoc (HsCase (nlHsVar to_arg)
371 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
373 to_arg = mkGenericLocal us
374 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
375 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
376 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
377 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
379 splitInHalf :: [a] -> ([a],[a])
380 splitInHalf list = (left, right)
382 half = length list `div` 2
383 left = take half list
384 right = drop half list
386 mkGenericLocal :: US -> RdrName
387 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
392 tc_name = tyConName tycon
393 tc_occ = nameOccName tc_name
394 tc_mod = nameModule tc_name
395 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
396 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
399 %************************************************************************
401 \subsection{Generating the RHS of a generic default method}
403 %************************************************************************
405 Generating the Generic default method. Uses the bimaps to generate the
406 actual method. All of this is rather incomplete, but it would be nice
407 to make even this work. Example
414 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
417 op = <mkGenericRhs op a T>
419 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
421 toOp :: Op Trep -> Op T
422 fromOp :: Op T -> Op Trep
424 (the bimap) and then fill in the RHS with
429 Remember, we're generating a RenamedHsExpr, so the result of all this
430 will be fed to the type checker. So the 'op' on the RHS will be
431 at the representation type for T, Trep.
434 Note [Polymorphic methods]
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~
436 Suppose the class op is polymorphic:
439 op :: forall b. Ord b => a -> b -> b
441 Then we can still generate a bimap with
443 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
445 and fill in the instance decl thus
450 By the time the type checker has done its stuff we'll get
453 op = \b. \dict::Ord b. toOp b (op Trep b dict)
456 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
457 mkGenericRhs sel_id tyvar tycon
458 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
459 -- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
460 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
462 -- Initialising the "Environment" with the from/to functions
463 -- on the datatype (actually tycon) in question
464 (from_RDR, to_RDR) = mkGenericNames tycon
466 -- Instantiate the selector type, and strip off its class context
467 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
469 -- Do it again! This deals with the case where the method type
470 -- is polymorphic -- see Note [Polymorphic methods] above
471 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
473 -- Now we probably have a tycon in front
474 -- of us, quite probably a FunTyCon.
475 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
476 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
478 type EPEnv = (TyVar, -- The class type variable
479 EP (LHsExpr RdrName), -- The EP it maps to
480 [TyVar] -- Other in-scope tyvars; they have an identity EP
484 generate_bimap :: EPEnv
486 -> EP (LHsExpr RdrName)
487 -- Top level case - splitting the TyCon.
488 generate_bimap env@(tv,ep,local_tvs) ty
489 = case getTyVar_maybe ty of
490 Just tv1 | tv == tv1 -> ep -- The class tyvar
491 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
493 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
496 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName)
497 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
498 bimapApp env (Just (tycon, ty_args))
499 | tycon == funTyCon = bimapArrow arg_eps
500 | tycon == listTyCon = bimapList arg_eps
501 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
502 | otherwise = -- Otherwise validGenericMethodType will
503 -- have checked that the type is a constant type
504 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
507 arg_eps = map (generate_bimap env) ty_args
508 (_,_,local_tvs) = env
511 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
512 bimapArrow [ep1, ep2]
513 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
514 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
516 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
517 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
520 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
522 = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
523 toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
525 names = takeList eps gs_RDR
526 tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
527 eps_w_names = eps `zip` names
528 to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
529 from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
532 -- bimapList :: EP a b -> EP [a] [b]
534 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
535 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
538 a_RDR = mkVarUnqual FSLIT("a")
539 b_RDR = mkVarUnqual FSLIT("b")
540 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
542 idEP :: EP (LHsExpr RdrName)
543 idEP = EP idexpr idexpr
545 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)