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 (FunBind (L loc from_RDR) False {- Not infix -}
259 (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])))
262 unitBag (L loc (FunBind (L loc to_RDR) False
263 (mkMatchGroup [mkSimpleHsAlt to_pat to_body])))
265 loc = srcLocSpan (getSrcLoc tycon)
266 datacons = tyConDataCons tycon
267 (from_RDR, to_RDR) = mkGenericNames tycon
269 -- Recurse over the sum first
270 from_alts :: [FromAlt]
271 (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
272 init_us = 1::Int -- Unique supply
274 ----------------------------------------------------
276 ----------------------------------------------------
278 mk_sum_stuff :: US -- Base for generating unique names
279 -> [DataCon] -- The data constructors
280 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
281 InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
283 -- For example, given
284 -- data T = C | D Int Int Int
286 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
287 -- case cd of { Inl u -> C;
288 -- Inr abc -> case abc of { a :*: bc ->
289 -- case bc of { b :*: c ->
293 mk_sum_stuff us [datacon]
294 = ([from_alt], to_pat, to_body_fn app_exp)
296 n_args = dataConSourceArity datacon -- Existentials already excluded
298 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
301 datacon_rdr = getRdrName datacon
302 app_exp = nlHsVarApps datacon_rdr datacon_vars
303 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
305 (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
307 mk_sum_stuff us datacons
308 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
310 noLoc (HsCase (nlHsVar to_arg)
311 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
312 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
314 (l_datacons, r_datacons) = splitInHalf datacons
315 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
316 (r_from_alts, r_to_pat, 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, noLoc (HsApp (nlHsVar 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 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
335 InPat RdrName, -- to_pat:
336 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
339 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
341 -- \<body-code> -> case abc of { a :*: bc ->
342 -- case bc of { b :*: c ->
345 -- We need to use different uniques in the branches
346 -- because the returned to_body_fns are nested.
347 -- Hence the returned unqique-name supply
349 mk_prod_stuff us [] -- Unit case
351 nlHsVar genUnitDataCon_RDR,
352 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
353 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
354 -- Give a signature to the pattern so we get
355 -- data S a = Nil | S a
356 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
358 -- The (:: Unit) signature ensures that we'll infer the right
359 -- type for toS. If we leave it out, the type is too polymorphic
363 mk_prod_stuff us [arg_var] -- Singleton case
364 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
366 mk_prod_stuff us arg_vars -- Two or more
368 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
371 \x -> noLoc (HsCase (nlHsVar to_arg)
372 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
374 to_arg = mkGenericLocal us
375 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
376 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
377 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
378 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
380 splitInHalf :: [a] -> ([a],[a])
381 splitInHalf list = (left, right)
383 half = length list `div` 2
384 left = take half list
385 right = drop half list
387 mkGenericLocal :: US -> RdrName
388 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
393 tc_name = tyConName tycon
394 tc_occ = nameOccName tc_name
395 tc_mod = nameModule tc_name
396 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
397 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
400 %************************************************************************
402 \subsection{Generating the RHS of a generic default method}
404 %************************************************************************
406 Generating the Generic default method. Uses the bimaps to generate the
407 actual method. All of this is rather incomplete, but it would be nice
408 to make even this work. Example
415 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
418 op = <mkGenericRhs op a T>
420 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
422 toOp :: Op Trep -> Op T
423 fromOp :: Op T -> Op Trep
425 (the bimap) and then fill in the RHS with
430 Remember, we're generating a RenamedHsExpr, so the result of all this
431 will be fed to the type checker. So the 'op' on the RHS will be
432 at the representation type for T, Trep.
435 Note [Polymorphic methods]
436 ~~~~~~~~~~~~~~~~~~~~~~~~~~
437 Suppose the class op is polymorphic:
440 op :: forall b. Ord b => a -> b -> b
442 Then we can still generate a bimap with
444 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
446 and fill in the instance decl thus
451 By the time the type checker has done its stuff we'll get
454 op = \b. \dict::Ord b. toOp b (op Trep b dict)
457 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
458 mkGenericRhs sel_id tyvar tycon
459 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
460 pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
461 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
463 -- Initialising the "Environment" with the from/to functions
464 -- on the datatype (actually tycon) in question
465 (from_RDR, to_RDR) = mkGenericNames tycon
467 -- Instantiate the selector type, and strip off its class context
468 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
470 -- Do it again! This deals with the case where the method type
471 -- is polymorphic -- see Note [Polymorphic methods] above
472 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
474 -- Now we probably have a tycon in front
475 -- of us, quite probably a FunTyCon.
476 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
477 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
479 type EPEnv = (TyVar, -- The class type variable
480 EP (LHsExpr RdrName), -- The EP it maps to
481 [TyVar] -- Other in-scope tyvars; they have an identity EP
485 generate_bimap :: EPEnv
487 -> EP (LHsExpr RdrName)
488 -- Top level case - splitting the TyCon.
489 generate_bimap env@(tv,ep,local_tvs) ty
490 = case getTyVar_maybe ty of
491 Just tv1 | tv == tv1 -> ep -- The class tyvar
492 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
494 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
497 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName)
498 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
499 bimapApp env (Just (tycon, ty_args))
500 | tycon == funTyCon = bimapArrow arg_eps
501 | tycon == listTyCon = bimapList arg_eps
502 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
503 | otherwise = -- Otherwise validGenericMethodType will
504 -- have checked that the type is a constant type
505 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
508 arg_eps = map (generate_bimap env) ty_args
509 (_,_,local_tvs) = env
512 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
513 bimapArrow [ep1, ep2]
514 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
515 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
517 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
518 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
521 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
523 = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
524 toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
526 names = takeList eps gs_RDR
527 tuple_pat = TuplePat (map nlVarPat names) Boxed
528 eps_w_names = eps `zip` names
529 to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
530 from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
533 -- bimapList :: EP a b -> EP [a] [b]
535 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
536 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
539 a_RDR = mkVarUnqual FSLIT("a")
540 b_RDR = mkVarUnqual FSLIT("b")
541 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
543 idEP :: EP (LHsExpr RdrName)
544 idEP = EP idexpr idexpr
546 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)