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 from_matches placeHolderNames))
262 unitBag (L loc (FunBind (L loc to_RDR) False
263 to_matches placeHolderNames))
265 from_matches = mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
266 to_matches = mkMatchGroup [mkSimpleHsAlt to_pat to_body]
267 loc = srcLocSpan (getSrcLoc tycon)
268 datacons = tyConDataCons tycon
269 (from_RDR, to_RDR) = mkGenericNames tycon
271 -- Recurse over the sum first
272 from_alts :: [FromAlt]
273 (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
274 init_us = 1::Int -- Unique supply
276 ----------------------------------------------------
278 ----------------------------------------------------
280 mk_sum_stuff :: US -- Base for generating unique names
281 -> [DataCon] -- The data constructors
282 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
283 InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
285 -- For example, given
286 -- data T = C | D Int Int Int
288 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
289 -- case cd of { Inl u -> C;
290 -- Inr abc -> case abc of { a :*: bc ->
291 -- case bc of { b :*: c ->
295 mk_sum_stuff us [datacon]
296 = ([from_alt], to_pat, to_body_fn app_exp)
298 n_args = dataConSourceArity datacon -- Existentials already excluded
300 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
303 datacon_rdr = getRdrName datacon
304 app_exp = nlHsVarApps datacon_rdr datacon_vars
305 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
307 (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
309 mk_sum_stuff us datacons
310 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
312 noLoc (HsCase (nlHsVar to_arg)
313 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
314 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
316 (l_datacons, r_datacons) = splitInHalf datacons
317 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
318 (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
320 to_arg = mkGenericLocal us
323 wrap :: RdrName -> [FromAlt] -> [FromAlt]
324 -- Wrap an application of the Inl or Inr constructor round each alternative
325 wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
328 ----------------------------------------------------
329 -- Dealing with products
330 ----------------------------------------------------
331 mk_prod_stuff :: US -- Base for unique names
332 -> [RdrName] -- arg-ids; args of the original user-defined constructor
333 -- They are bound enclosing from_rhs
334 -- Please bind these in the to_body_fn
335 -> (US, -- Depleted unique-name supply
336 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
337 InPat RdrName, -- to_pat:
338 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
341 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
343 -- \<body-code> -> case abc of { a :*: bc ->
344 -- case bc of { b :*: c ->
347 -- We need to use different uniques in the branches
348 -- because the returned to_body_fns are nested.
349 -- Hence the returned unqique-name supply
351 mk_prod_stuff us [] -- Unit case
353 nlHsVar genUnitDataCon_RDR,
354 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
355 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
356 -- Give a signature to the pattern so we get
357 -- data S a = Nil | S a
358 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
360 -- The (:: Unit) signature ensures that we'll infer the right
361 -- type for toS. If we leave it out, the type is too polymorphic
365 mk_prod_stuff us [arg_var] -- Singleton case
366 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
368 mk_prod_stuff us arg_vars -- Two or more
370 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
373 \x -> noLoc (HsCase (nlHsVar to_arg)
374 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
376 to_arg = mkGenericLocal us
377 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
378 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
379 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
380 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
382 splitInHalf :: [a] -> ([a],[a])
383 splitInHalf list = (left, right)
385 half = length list `div` 2
386 left = take half list
387 right = drop half list
389 mkGenericLocal :: US -> RdrName
390 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
395 tc_name = tyConName tycon
396 tc_occ = nameOccName tc_name
397 tc_mod = nameModule tc_name
398 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
399 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
402 %************************************************************************
404 \subsection{Generating the RHS of a generic default method}
406 %************************************************************************
408 Generating the Generic default method. Uses the bimaps to generate the
409 actual method. All of this is rather incomplete, but it would be nice
410 to make even this work. Example
417 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
420 op = <mkGenericRhs op a T>
422 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
424 toOp :: Op Trep -> Op T
425 fromOp :: Op T -> Op Trep
427 (the bimap) and then fill in the RHS with
432 Remember, we're generating a RenamedHsExpr, so the result of all this
433 will be fed to the type checker. So the 'op' on the RHS will be
434 at the representation type for T, Trep.
437 Note [Polymorphic methods]
438 ~~~~~~~~~~~~~~~~~~~~~~~~~~
439 Suppose the class op is polymorphic:
442 op :: forall b. Ord b => a -> b -> b
444 Then we can still generate a bimap with
446 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
448 and fill in the instance decl thus
453 By the time the type checker has done its stuff we'll get
456 op = \b. \dict::Ord b. toOp b (op Trep b dict)
459 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
460 mkGenericRhs sel_id tyvar tycon
461 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
462 -- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
463 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
465 -- Initialising the "Environment" with the from/to functions
466 -- on the datatype (actually tycon) in question
467 (from_RDR, to_RDR) = mkGenericNames tycon
469 -- Instantiate the selector type, and strip off its class context
470 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
472 -- Do it again! This deals with the case where the method type
473 -- is polymorphic -- see Note [Polymorphic methods] above
474 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
476 -- Now we probably have a tycon in front
477 -- of us, quite probably a FunTyCon.
478 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
479 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
481 type EPEnv = (TyVar, -- The class type variable
482 EP (LHsExpr RdrName), -- The EP it maps to
483 [TyVar] -- Other in-scope tyvars; they have an identity EP
487 generate_bimap :: EPEnv
489 -> EP (LHsExpr RdrName)
490 -- Top level case - splitting the TyCon.
491 generate_bimap env@(tv,ep,local_tvs) ty
492 = case getTyVar_maybe ty of
493 Just tv1 | tv == tv1 -> ep -- The class tyvar
494 | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method
496 Nothing -> bimapApp env (tcSplitTyConApp_maybe ty)
499 bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName)
500 bimapApp env Nothing = panic "TcClassDecl: Type Application!"
501 bimapApp env (Just (tycon, ty_args))
502 | tycon == funTyCon = bimapArrow arg_eps
503 | tycon == listTyCon = bimapList arg_eps
504 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
505 | otherwise = -- Otherwise validGenericMethodType will
506 -- have checked that the type is a constant type
507 ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
510 arg_eps = map (generate_bimap env) ty_args
511 (_,_,local_tvs) = env
514 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
515 bimapArrow [ep1, ep2]
516 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
517 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
519 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
520 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
523 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
525 = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
526 toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
528 names = takeList eps gs_RDR
529 tuple_pat = TuplePat (map nlVarPat names) Boxed
530 eps_w_names = eps `zip` names
531 to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
532 from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
535 -- bimapList :: EP a b -> EP [a] [b]
537 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
538 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
541 a_RDR = mkVarUnqual FSLIT("a")
542 b_RDR = mkVarUnqual FSLIT("b")
543 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
545 idEP :: EP (LHsExpr RdrName)
546 idEP = EP idexpr idexpr
548 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)