2 % (c) The University of Glasgow 2006
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
13 module Generics ( canDoGenerics, mkTyConGenericBinds,
15 validGenericInstanceType, validGenericMethodType
42 #include "HsVersions.h"
45 Roadmap of what's where in the Generics work.
46 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
52 Checks that HsNumTy has a "1" in it.
54 TcInstDcls.mkGenericInstance:
55 Checks for invalid type patterns, such as f {| Int |}
58 Checks for a method type that is too complicated;
59 e.g. has for-alls or lists in it
60 We could lift this restriction
62 TcClassDecl.mkDefMethRhs
63 Checks that the instance type is simple, in an instance decl
64 where we let the compiler fill in a generic method.
65 e.g. instance C (T Int)
66 is not valid if C has generic methods.
68 TcClassDecl.checkGenericClassIsUnary
69 Checks that we don't have generic methods in a multi-parameter class
71 TcClassDecl.checkDefaultBinds
72 Checks that all the equations for a method in a class decl
73 are generic, or all are non-generic
77 Checking that the type constructors which are present in Generic
78 patterns (not Unit, this is done differently) is done in mk_inst_info
79 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
80 HsOpTy is tied to Generic definitions which is not a very good design
81 feature, indeed a bug. However, the check is easy to move from
82 tcHsType back to mk_inst_info and everything will be fine. Also see
83 bug #5. [I don't think that this is the case anymore after SPJ's latest
84 changes in that regard. Delete this comment? -=chak/7Jun2]
88 Making generic information to put into a tycon. Constructs the
89 representation type, which, I think, are not used later. Perhaps it is
90 worth removing them from the GI datatype. Although it does get used in
91 the construction of conversion functions (internally).
95 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
99 Defines generic and other type and data constructors.
101 This is sadly incomplete, but will be added to.
104 Bugs & shortcomings of existing implementation:
105 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107 2. Another pretty big bug I dscovered at the last minute when I was
108 testing the code is that at the moment the type variable of the class
109 is scoped over the entire declaration, including the patterns. For
110 instance, if I have the following code,
114 er {| Plus a b |} (Inl x) (Inl y) = er x y
115 er {| Plus a b |} (Inr x) (Inr y) = er x y
116 er {| Plus a b |} _ _ = False
118 and I print out the types of the generic patterns, I get the
119 following. Note that all the variable names for "a" are the same,
120 while for "b" they are all different.
123 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
124 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
125 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
127 This is a bug as if I change the code to
129 er {| Plus c b |} (Inl x) (Inl y) = er x y
131 all the names come out to be different.
133 Thus, all the types (Plus a b) come out to be different, so I cannot
134 compare them and test whether they are all the same and thus cannot
135 return an error if the type variables are different.
137 Temporary fix/hack. I am not checking for this, I just assume they are
138 the same, see line "check_ty = True" in TcInstDecls. When we resolve
139 the issue with variables, though - I assume that we will make them to
140 be the same in all the type patterns, jus uncomment the check and
141 everything should work smoothly.
143 Hence, I have also left the rather silly construction of:
144 * extracting all the type variables from all the types
145 * putting them *all* into the environment
146 * typechecking all the types
147 * selecting one of them and using it as the instance_ty.
149 (the alternative is to make sure that all the types are the same,
150 taking one, extracting its variables, putting them into the environment,
151 type checking it, using it as the instance_ty)
153 6. What happens if we do not supply all of the generic patterns? At
154 the moment, the compiler crashes with an error message "Non-exhaustive
155 patterns in a generic declaration"
158 What has not been addressed:
159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
161 Contexts. In the generated instance declarations for the 3 primitive
162 type constructors, we need contexts. It is unclear what those should
163 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
165 Type application. We have type application in expressions
166 (essentially) on the lhs of an equation. Do we want to allow it on the
169 Scoping of type variables in a generic definition. At the moment, (see
170 TcInstDecls) we extract the type variables inside the type patterns
171 and add them to the environment. See my bug #2 above. This seems pretty
176 %************************************************************************
178 \subsection{Getting the representation type out}
180 %************************************************************************
183 validGenericInstanceType :: Type -> Bool
184 -- Checks for validity of the type pattern in a generic
185 -- declaration. It's ok to have
187 -- but it's not OK to have
190 validGenericInstanceType inst_ty
191 = case tcSplitTyConApp_maybe inst_ty of
192 Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
195 validGenericMethodType :: Type -> Bool
196 -- At the moment we only allow method types built from
201 -- * an arbitrary type not involving the class type variables
202 -- e.g. this is ok: forall b. Ord b => [b] -> a
203 -- where a is the class variable
204 validGenericMethodType ty
207 (local_tvs, _, tau) = tcSplitSigmaTy ty
210 | not (isTauTy ty) = False -- Note [Higher ramk methods]
211 | isTyVarTy ty = True
212 | no_tyvars_in_ty = True
213 | otherwise = case tcSplitTyConApp_maybe ty of
214 Just (tc,tys) -> valid_tycon tc && all valid tys
217 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
219 valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
220 -- Compare bimapApp, below
224 %************************************************************************
226 \subsection{Generating representation types}
228 %************************************************************************
231 canDoGenerics :: [DataCon] -> Bool
232 -- Called on source-code data types, to see if we should generate
233 -- generic functions for them. (This info is recorded in the interface file for
234 -- imported data types.)
236 canDoGenerics data_cons
237 = not (any bad_con data_cons) -- See comment below
238 && not (null data_cons) -- No values of the type
240 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
241 -- If any of the constructor has an unboxed type as argument,
242 -- then we can't build the embedding-projection pair, because
243 -- it relies on instantiating *polymorphic* sum and product types
244 -- at the argument types of the constructors
246 -- Nor can we do the job if it's an existential data constructor,
248 -- Nor if the args are polymorphic types (I don't think)
249 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
252 %************************************************************************
254 \subsection{Generating the RHS of a generic default method}
256 %************************************************************************
259 type US = Int -- Local unique supply, just a plain Int
260 type FromAlt = (LPat RdrName, LHsExpr RdrName)
262 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
263 mkTyConGenericBinds tycon
264 = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
266 unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
268 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
269 to_matches = [mkSimpleHsAlt to_pat to_body]
270 loc = srcLocSpan (getSrcLoc tycon)
271 datacons = tyConDataCons tycon
272 (from_RDR, to_RDR) = mkGenericNames tycon
274 -- Recurse over the sum first
275 from_alts :: [FromAlt]
276 (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
277 init_us = 1::Int -- Unique supply
279 ----------------------------------------------------
281 ----------------------------------------------------
283 mk_sum_stuff :: US -- Base for generating unique names
284 -> [DataCon] -- The data constructors
285 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
286 InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
288 -- For example, given
289 -- data T = C | D Int Int Int
291 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
292 -- case cd of { Inl u -> C;
293 -- Inr abc -> case abc of { a :*: bc ->
294 -- case bc of { b :*: c ->
298 mk_sum_stuff us [datacon]
299 = ([from_alt], to_pat, to_body_fn app_exp)
301 n_args = dataConSourceArity datacon -- Existentials already excluded
303 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
306 datacon_rdr = getRdrName datacon
307 app_exp = nlHsVarApps datacon_rdr datacon_vars
308 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
310 (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
312 mk_sum_stuff us datacons
313 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
315 noLoc (HsCase (nlHsVar to_arg)
316 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
317 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
319 (l_datacons, r_datacons) = splitInHalf datacons
320 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
321 (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
323 to_arg = mkGenericLocal us
326 wrap :: RdrName -> [FromAlt] -> [FromAlt]
327 -- Wrap an application of the Inl or Inr constructor round each alternative
328 wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
331 ----------------------------------------------------
332 -- Dealing with products
333 ----------------------------------------------------
334 mk_prod_stuff :: US -- Base for unique names
335 -> [RdrName] -- arg-ids; args of the original user-defined constructor
336 -- They are bound enclosing from_rhs
337 -- Please bind these in the to_body_fn
338 -> (US, -- Depleted unique-name supply
339 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
340 InPat RdrName, -- to_pat:
341 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
344 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
346 -- \<body-code> -> case abc of { a :*: bc ->
347 -- case bc of { b :*: c ->
350 -- We need to use different uniques in the branches
351 -- because the returned to_body_fns are nested.
352 -- Hence the returned unqique-name supply
354 mk_prod_stuff us [] -- Unit case
356 nlHsVar genUnitDataCon_RDR,
357 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
358 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
359 -- Give a signature to the pattern so we get
360 -- data S a = Nil | S a
361 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
363 -- The (:: Unit) signature ensures that we'll infer the right
364 -- type for toS. If we leave it out, the type is too polymorphic
368 mk_prod_stuff us [arg_var] -- Singleton case
369 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
371 mk_prod_stuff us arg_vars -- Two or more
373 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
376 \x -> noLoc (HsCase (nlHsVar to_arg)
377 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
379 to_arg = mkGenericLocal us
380 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
381 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
382 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
383 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
385 splitInHalf :: [a] -> ([a],[a])
386 splitInHalf list = (left, right)
388 half = length list `div` 2
389 left = take half list
390 right = drop half list
392 mkGenericLocal :: US -> RdrName
393 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
398 tc_name = tyConName tycon
399 tc_occ = nameOccName tc_name
400 tc_mod = nameModule tc_name
401 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
402 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
405 %************************************************************************
407 \subsection{Generating the RHS of a generic default method}
409 %************************************************************************
411 Generating the Generic default method. Uses the bimaps to generate the
412 actual method. All of this is rather incomplete, but it would be nice
413 to make even this work. Example
420 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
423 op = <mkGenericRhs op a T>
425 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
427 toOp :: Op Trep -> Op T
428 fromOp :: Op T -> Op Trep
430 (the bimap) and then fill in the RHS with
435 Remember, we're generating a RenamedHsExpr, so the result of all this
436 will be fed to the type checker. So the 'op' on the RHS will be
437 at the representation type for T, Trep.
440 Note [Polymorphic methods]
441 ~~~~~~~~~~~~~~~~~~~~~~~~~~
442 Suppose the class op is polymorphic:
445 op :: forall b. Ord b => a -> b -> b
447 Then we can still generate a bimap with
449 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
451 and fill in the instance decl thus
456 By the time the type checker has done its stuff we'll get
459 op = \b. \dict::Ord b. toOp b (op Trep b dict)
461 Note [Higher rank methods]
462 ~~~~~~~~~~~~~~~~~~~~~~~~~~
463 Higher-rank method types don't work, because we'd generate a bimap that
464 needs impredicative polymorphism. In principle that should be possible
465 (with boxy types and all) but it would take a bit of working out. Here's
467 class ChurchEncode k where
469 -> (forall a b z. a -> b -> z) {- product -}
470 -> (forall a z. a -> z) {- left -}
471 -> (forall a z. a -> z) {- right -}
474 match {| Unit |} Unit unit prod left right = unit
475 match {| a :*: b |} (x :*: y) unit prod left right = prod x y
476 match {| a :+: b |} (Inl l) unit prod left right = left l
477 match {| a :+: b |} (Inr r) unit prod left right = right r
480 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
481 mkGenericRhs sel_id tyvar tycon
482 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
483 -- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
484 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
486 -- Initialising the "Environment" with the from/to functions
487 -- on the datatype (actually tycon) in question
488 (from_RDR, to_RDR) = mkGenericNames tycon
490 -- Instantiate the selector type, and strip off its class context
491 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
493 -- Do it again! This deals with the case where the method type
494 -- is polymorphic -- see Note [Polymorphic methods] above
495 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
497 -- Now we probably have a tycon in front
498 -- of us, quite probably a FunTyCon.
499 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
500 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
502 type EPEnv = (TyVar, -- The class type variable
503 EP (LHsExpr RdrName), -- The EP it maps to
504 [TyVar] -- Other in-scope tyvars; they have an identity EP
508 generate_bimap :: EPEnv
510 -> EP (LHsExpr RdrName)
511 -- Top level case - splitting the TyCon.
512 generate_bimap env@(tv,ep,local_tvs) ty
513 | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
514 = idEP -- A constant type
516 | Just tv1 <- getTyVar_maybe ty
517 = ASSERT( tv == tv1 ) ep -- The class tyvar
519 | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
520 = bimapTyCon tycon (map (generate_bimap env) ty_args)
523 = pprPanic "generate_bimap" (ppr ty)
526 bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
527 bimapTyCon tycon arg_eps
528 | tycon == funTyCon = bimapArrow arg_eps
529 | tycon == listTyCon = bimapList arg_eps
530 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
531 | otherwise = pprPanic "bimapTyCon" (ppr tycon)
534 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
535 bimapArrow [ep1, ep2]
536 = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
537 toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
539 from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
540 to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
543 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
545 = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
546 toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
548 names = takeList eps gs_RDR
549 tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
550 eps_w_names = eps `zip` names
551 to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
552 from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
555 -- bimapList :: EP a b -> EP [a] [b]
557 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
558 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
561 a_RDR = mkVarUnqual FSLIT("a")
562 b_RDR = mkVarUnqual FSLIT("b")
563 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
565 idEP :: EP (LHsExpr RdrName)
566 idEP = EP idexpr idexpr
568 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)