2 % (c) The University of Glasgow 2006
6 module Generics ( canDoGenerics, mkTyConGenericBinds,
8 validGenericInstanceType, validGenericMethodType
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
194 -- * an arbitrary type not involving the class type variables
195 -- e.g. this is ok: forall b. Ord b => [b] -> a
196 -- where a is the class variable
197 validGenericMethodType ty
200 (local_tvs, _, tau) = tcSplitSigmaTy ty
203 | not (isTauTy ty) = False -- Note [Higher ramk methods]
204 | isTyVarTy ty = True
205 | no_tyvars_in_ty = True
206 | otherwise = case tcSplitTyConApp_maybe ty of
207 Just (tc,tys) -> valid_tycon tc && all valid tys
210 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
212 valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
213 -- Compare bimapApp, below
217 %************************************************************************
219 \subsection{Generating representation types}
221 %************************************************************************
224 canDoGenerics :: [DataCon] -> Bool
225 -- Called on source-code data types, to see if we should generate
226 -- generic functions for them. (This info is recorded in the interface file for
227 -- imported data types.)
229 canDoGenerics data_cons
230 = not (any bad_con data_cons) -- See comment below
231 && not (null data_cons) -- No values of the type
233 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
234 -- If any of the constructor has an unboxed type as argument,
235 -- then we can't build the embedding-projection pair, because
236 -- it relies on instantiating *polymorphic* sum and product types
237 -- at the argument types of the constructors
239 -- Nor can we do the job if it's an existential data constructor,
241 -- Nor if the args are polymorphic types (I don't think)
242 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
245 %************************************************************************
247 \subsection{Generating the RHS of a generic default method}
249 %************************************************************************
252 type US = Int -- Local unique supply, just a plain Int
253 type FromAlt = (LPat RdrName, LHsExpr RdrName)
255 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
256 mkTyConGenericBinds tycon
257 = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
259 unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
261 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
262 to_matches = [mkSimpleHsAlt to_pat to_body]
263 loc = srcLocSpan (getSrcLoc tycon)
264 datacons = tyConDataCons tycon
265 (from_RDR, to_RDR) = mkGenericNames tycon
267 -- Recurse over the sum first
268 from_alts :: [FromAlt]
269 (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
270 init_us = 1::Int -- Unique supply
272 ----------------------------------------------------
274 ----------------------------------------------------
276 mk_sum_stuff :: US -- Base for generating unique names
277 -> [DataCon] -- The data constructors
278 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
279 InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
281 -- For example, given
282 -- data T = C | D Int Int Int
284 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
285 -- case cd of { Inl u -> C;
286 -- Inr abc -> case abc of { a :*: bc ->
287 -- case bc of { b :*: c ->
291 mk_sum_stuff us [datacon]
292 = ([from_alt], to_pat, to_body_fn app_exp)
294 n_args = dataConSourceArity datacon -- Existentials already excluded
296 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
299 datacon_rdr = getRdrName datacon
300 app_exp = nlHsVarApps datacon_rdr datacon_vars
301 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
303 (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
305 mk_sum_stuff us datacons
306 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
308 noLoc (HsCase (nlHsVar to_arg)
309 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
310 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
312 (l_datacons, r_datacons) = splitInHalf datacons
313 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
314 (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
316 to_arg = mkGenericLocal us
319 wrap :: RdrName -> [FromAlt] -> [FromAlt]
320 -- Wrap an application of the Inl or Inr constructor round each alternative
321 wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
324 ----------------------------------------------------
325 -- Dealing with products
326 ----------------------------------------------------
327 mk_prod_stuff :: US -- Base for unique names
328 -> [RdrName] -- arg-ids; args of the original user-defined constructor
329 -- They are bound enclosing from_rhs
330 -- Please bind these in the to_body_fn
331 -> (US, -- Depleted unique-name supply
332 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
333 InPat RdrName, -- to_pat:
334 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
337 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
339 -- \<body-code> -> case abc of { a :*: bc ->
340 -- case bc of { b :*: c ->
343 -- We need to use different uniques in the branches
344 -- because the returned to_body_fns are nested.
345 -- Hence the returned unqique-name supply
347 mk_prod_stuff us [] -- Unit case
349 nlHsVar genUnitDataCon_RDR,
350 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
351 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
352 -- Give a signature to the pattern so we get
353 -- data S a = Nil | S a
354 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
356 -- The (:: Unit) signature ensures that we'll infer the right
357 -- type for toS. If we leave it out, the type is too polymorphic
361 mk_prod_stuff us [arg_var] -- Singleton case
362 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
364 mk_prod_stuff us arg_vars -- Two or more
366 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
369 \x -> noLoc (HsCase (nlHsVar to_arg)
370 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
372 to_arg = mkGenericLocal us
373 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
374 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
375 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
376 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
378 splitInHalf :: [a] -> ([a],[a])
379 splitInHalf list = (left, right)
381 half = length list `div` 2
382 left = take half list
383 right = drop half list
385 mkGenericLocal :: US -> RdrName
386 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
391 tc_name = tyConName tycon
392 tc_occ = nameOccName tc_name
393 tc_mod = nameModule tc_name
394 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
395 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
398 %************************************************************************
400 \subsection{Generating the RHS of a generic default method}
402 %************************************************************************
404 Generating the Generic default method. Uses the bimaps to generate the
405 actual method. All of this is rather incomplete, but it would be nice
406 to make even this work. Example
413 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
416 op = <mkGenericRhs op a T>
418 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
420 toOp :: Op Trep -> Op T
421 fromOp :: Op T -> Op Trep
423 (the bimap) and then fill in the RHS with
428 Remember, we're generating a RenamedHsExpr, so the result of all this
429 will be fed to the type checker. So the 'op' on the RHS will be
430 at the representation type for T, Trep.
433 Note [Polymorphic methods]
434 ~~~~~~~~~~~~~~~~~~~~~~~~~~
435 Suppose the class op is polymorphic:
438 op :: forall b. Ord b => a -> b -> b
440 Then we can still generate a bimap with
442 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
444 and fill in the instance decl thus
449 By the time the type checker has done its stuff we'll get
452 op = \b. \dict::Ord b. toOp b (op Trep b dict)
454 Note [Higher rank methods]
455 ~~~~~~~~~~~~~~~~~~~~~~~~~~
456 Higher-rank method types don't work, because we'd generate a bimap that
457 needs impredicative polymorphism. In principle that should be possible
458 (with boxy types and all) but it would take a bit of working out. Here's
460 class ChurchEncode k where
462 -> (forall a b z. a -> b -> z) {- product -}
463 -> (forall a z. a -> z) {- left -}
464 -> (forall a z. a -> z) {- right -}
467 match {| Unit |} Unit unit prod left right = unit
468 match {| a :*: b |} (x :*: y) unit prod left right = prod x y
469 match {| a :+: b |} (Inl l) unit prod left right = left l
470 match {| a :+: b |} (Inr r) unit prod left right = right r
473 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
474 mkGenericRhs sel_id tyvar tycon
475 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
476 -- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
477 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
479 -- Initialising the "Environment" with the from/to functions
480 -- on the datatype (actually tycon) in question
481 (from_RDR, to_RDR) = mkGenericNames tycon
483 -- Instantiate the selector type, and strip off its class context
484 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
486 -- Do it again! This deals with the case where the method type
487 -- is polymorphic -- see Note [Polymorphic methods] above
488 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
490 -- Now we probably have a tycon in front
491 -- of us, quite probably a FunTyCon.
492 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
493 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
495 type EPEnv = (TyVar, -- The class type variable
496 EP (LHsExpr RdrName), -- The EP it maps to
497 [TyVar] -- Other in-scope tyvars; they have an identity EP
501 generate_bimap :: EPEnv
503 -> EP (LHsExpr RdrName)
504 -- Top level case - splitting the TyCon.
505 generate_bimap env@(tv,ep,local_tvs) ty
506 | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
507 = idEP -- A constant type
509 | Just tv1 <- getTyVar_maybe ty
510 = ASSERT( tv == tv1 ) ep -- The class tyvar
512 | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
513 = bimapTyCon tycon (map (generate_bimap env) ty_args)
516 = pprPanic "generate_bimap" (ppr ty)
519 bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
520 bimapTyCon tycon arg_eps
521 | tycon == funTyCon = bimapArrow arg_eps
522 | tycon == listTyCon = bimapList arg_eps
523 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
524 | otherwise = pprPanic "bimapTyCon" (ppr tycon)
527 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
528 bimapArrow [ep1, ep2]
529 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
530 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
532 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
533 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
536 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
538 = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
539 toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
541 names = takeList eps gs_RDR
542 tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
543 eps_w_names = eps `zip` names
544 to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
545 from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
548 -- bimapList :: EP a b -> EP [a] [b]
550 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
551 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
554 a_RDR = mkVarUnqual FSLIT("a")
555 b_RDR = mkVarUnqual FSLIT("b")
556 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
558 idEP :: EP (LHsExpr RdrName)
559 idEP = EP idexpr idexpr
561 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)