2 % (c) The University of Glasgow 2006
6 {-# OPTIONS -fno-warn-incomplete-patterns #-}
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
40 #include "HsVersions.h"
43 Roadmap of what's where in the Generics work.
44 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
50 Checks that HsNumTy has a "1" in it.
52 TcInstDcls.mkGenericInstance:
53 Checks for invalid type patterns, such as f {| Int |}
56 Checks for a method type that is too complicated;
57 e.g. has for-alls or lists in it
58 We could lift this restriction
60 TcClassDecl.mkDefMethRhs
61 Checks that the instance type is simple, in an instance decl
62 where we let the compiler fill in a generic method.
63 e.g. instance C (T Int)
64 is not valid if C has generic methods.
66 TcClassDecl.checkGenericClassIsUnary
67 Checks that we don't have generic methods in a multi-parameter class
69 TcClassDecl.checkDefaultBinds
70 Checks that all the equations for a method in a class decl
71 are generic, or all are non-generic
75 Checking that the type constructors which are present in Generic
76 patterns (not Unit, this is done differently) is done in mk_inst_info
77 (TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
78 HsOpTy is tied to Generic definitions which is not a very good design
79 feature, indeed a bug. However, the check is easy to move from
80 tcHsType back to mk_inst_info and everything will be fine. Also see
81 bug #5. [I don't think that this is the case anymore after SPJ's latest
82 changes in that regard. Delete this comment? -=chak/7Jun2]
86 Making generic information to put into a tycon. Constructs the
87 representation type, which, I think, are not used later. Perhaps it is
88 worth removing them from the GI datatype. Although it does get used in
89 the construction of conversion functions (internally).
93 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
97 Defines generic and other type and data constructors.
99 This is sadly incomplete, but will be added to.
102 Bugs & shortcomings of existing implementation:
103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
105 2. Another pretty big bug I dscovered at the last minute when I was
106 testing the code is that at the moment the type variable of the class
107 is scoped over the entire declaration, including the patterns. For
108 instance, if I have the following code,
112 er {| Plus a b |} (Inl x) (Inl y) = er x y
113 er {| Plus a b |} (Inr x) (Inr y) = er x y
114 er {| Plus a b |} _ _ = False
116 and I print out the types of the generic patterns, I get the
117 following. Note that all the variable names for "a" are the same,
118 while for "b" they are all different.
121 [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
122 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
123 std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
125 This is a bug as if I change the code to
127 er {| Plus c b |} (Inl x) (Inl y) = er x y
129 all the names come out to be different.
131 Thus, all the types (Plus a b) come out to be different, so I cannot
132 compare them and test whether they are all the same and thus cannot
133 return an error if the type variables are different.
135 Temporary fix/hack. I am not checking for this, I just assume they are
136 the same, see line "check_ty = True" in TcInstDecls. When we resolve
137 the issue with variables, though - I assume that we will make them to
138 be the same in all the type patterns, jus uncomment the check and
139 everything should work smoothly.
141 Hence, I have also left the rather silly construction of:
142 * extracting all the type variables from all the types
143 * putting them *all* into the environment
144 * typechecking all the types
145 * selecting one of them and using it as the instance_ty.
147 (the alternative is to make sure that all the types are the same,
148 taking one, extracting its variables, putting them into the environment,
149 type checking it, using it as the instance_ty)
151 6. What happens if we do not supply all of the generic patterns? At
152 the moment, the compiler crashes with an error message "Non-exhaustive
153 patterns in a generic declaration"
156 What has not been addressed:
157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
159 Contexts. In the generated instance declarations for the 3 primitive
160 type constructors, we need contexts. It is unclear what those should
161 be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
163 Type application. We have type application in expressions
164 (essentially) on the lhs of an equation. Do we want to allow it on the
167 Scoping of type variables in a generic definition. At the moment, (see
168 TcInstDecls) we extract the type variables inside the type patterns
169 and add them to the environment. See my bug #2 above. This seems pretty
174 %************************************************************************
176 \subsection{Getting the representation type out}
178 %************************************************************************
181 validGenericInstanceType :: Type -> Bool
182 -- Checks for validity of the type pattern in a generic
183 -- declaration. It's ok to have
185 -- but it's not OK to have
188 validGenericInstanceType inst_ty
189 = case tcSplitTyConApp_maybe inst_ty of
190 Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
193 validGenericMethodType :: Type -> Bool
194 -- At the moment we only allow method types built from
199 -- * an arbitrary type not involving the class type variables
200 -- e.g. this is ok: forall b. Ord b => [b] -> a
201 -- where a is the class variable
202 validGenericMethodType ty
205 (local_tvs, _, tau) = tcSplitSigmaTy ty
208 | not (isTauTy ty) = False -- Note [Higher ramk methods]
209 | isTyVarTy ty = True
210 | no_tyvars_in_ty = True
211 | otherwise = case tcSplitTyConApp_maybe ty of
212 Just (tc,tys) -> valid_tycon tc && all valid tys
215 no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
217 valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
218 -- Compare bimapApp, below
222 %************************************************************************
224 \subsection{Generating representation types}
226 %************************************************************************
229 canDoGenerics :: [DataCon] -> Bool
230 -- Called on source-code data types, to see if we should generate
231 -- generic functions for them. (This info is recorded in the interface file for
232 -- imported data types.)
234 canDoGenerics data_cons
235 = not (any bad_con data_cons) -- See comment below
236 && not (null data_cons) -- No values of the type
238 bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
239 -- If any of the constructor has an unboxed type as argument,
240 -- then we can't build the embedding-projection pair, because
241 -- it relies on instantiating *polymorphic* sum and product types
242 -- at the argument types of the constructors
244 -- Nor can we do the job if it's an existential data constructor,
246 -- Nor if the args are polymorphic types (I don't think)
247 bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
250 %************************************************************************
252 \subsection{Generating the RHS of a generic default method}
254 %************************************************************************
257 type US = Int -- Local unique supply, just a plain Int
258 type FromAlt = (LPat RdrName, LHsExpr RdrName)
260 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
261 mkTyConGenericBinds tycon
262 = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
264 unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
266 from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
267 to_matches = [mkSimpleHsAlt to_pat to_body]
268 loc = srcLocSpan (getSrcLoc tycon)
269 datacons = tyConDataCons tycon
270 (from_RDR, to_RDR) = mkGenericNames tycon
272 -- Recurse over the sum first
273 from_alts :: [FromAlt]
274 (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
275 init_us = 1::Int -- Unique supply
277 ----------------------------------------------------
279 ----------------------------------------------------
281 mk_sum_stuff :: US -- Base for generating unique names
282 -> [DataCon] -- The data constructors
283 -> ([FromAlt], -- Alternatives for the T->Trep "from" function
284 InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
286 -- For example, given
287 -- data T = C | D Int Int Int
289 -- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
290 -- case cd of { Inl u -> C;
291 -- Inr abc -> case abc of { a :*: bc ->
292 -- case bc of { b :*: c ->
296 mk_sum_stuff us [datacon]
297 = ([from_alt], to_pat, to_body_fn app_exp)
299 n_args = dataConSourceArity datacon -- Existentials already excluded
301 datacon_vars = map mkGenericLocal [us .. us+n_args-1]
304 datacon_rdr = getRdrName datacon
305 app_exp = nlHsVarApps datacon_rdr datacon_vars
306 from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
308 (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
310 mk_sum_stuff us datacons
311 = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
313 noLoc (HsCase (nlHsVar to_arg)
314 (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
315 mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
317 (l_datacons, r_datacons) = splitInHalf datacons
318 (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
319 (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
321 to_arg = mkGenericLocal us
324 wrap :: RdrName -> [FromAlt] -> [FromAlt]
325 -- Wrap an application of the Inl or Inr constructor round each alternative
326 wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
329 ----------------------------------------------------
330 -- Dealing with products
331 ----------------------------------------------------
332 mk_prod_stuff :: US -- Base for unique names
333 -> [RdrName] -- arg-ids; args of the original user-defined constructor
334 -- They are bound enclosing from_rhs
335 -- Please bind these in the to_body_fn
336 -> (US, -- Depleted unique-name supply
337 LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
338 InPat RdrName, -- to_pat:
339 LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
342 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
344 -- \<body-code> -> case abc of { a :*: bc ->
345 -- case bc of { b :*: c ->
348 -- We need to use different uniques in the branches
349 -- because the returned to_body_fns are nested.
350 -- Hence the returned unqique-name supply
352 mk_prod_stuff us [] -- Unit case
354 nlHsVar genUnitDataCon_RDR,
355 noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
356 (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
357 -- Give a signature to the pattern so we get
358 -- data S a = Nil | S a
359 -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
361 -- The (:: Unit) signature ensures that we'll infer the right
362 -- type for toS. If we leave it out, the type is too polymorphic
366 mk_prod_stuff us [arg_var] -- Singleton case
367 = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
369 mk_prod_stuff us arg_vars -- Two or more
371 nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
374 \x -> noLoc (HsCase (nlHsVar to_arg)
375 (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
377 to_arg = mkGenericLocal us
378 (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
379 (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
380 (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
381 pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
383 splitInHalf :: [a] -> ([a],[a])
384 splitInHalf list = (left, right)
386 half = length list `div` 2
387 left = take half list
388 right = drop half list
390 mkGenericLocal :: US -> RdrName
391 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
393 mkGenericNames :: TyCon -> (RdrName, RdrName)
397 tc_name = tyConName tycon
398 tc_occ = nameOccName tc_name
399 tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name
400 from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
401 to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
404 %************************************************************************
406 \subsection{Generating the RHS of a generic default method}
408 %************************************************************************
410 Generating the Generic default method. Uses the bimaps to generate the
411 actual method. All of this is rather incomplete, but it would be nice
412 to make even this work. Example
419 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
422 op = <mkGenericRhs op a T>
424 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
426 toOp :: Op Trep -> Op T
427 fromOp :: Op T -> Op Trep
429 (the bimap) and then fill in the RHS with
434 Remember, we're generating a RenamedHsExpr, so the result of all this
435 will be fed to the type checker. So the 'op' on the RHS will be
436 at the representation type for T, Trep.
439 Note [Polymorphic methods]
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~
441 Suppose the class op is polymorphic:
444 op :: forall b. Ord b => a -> b -> b
446 Then we can still generate a bimap with
448 toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
450 and fill in the instance decl thus
455 By the time the type checker has done its stuff we'll get
458 op = \b. \dict::Ord b. toOp b (op Trep b dict)
460 Note [Higher rank methods]
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~
462 Higher-rank method types don't work, because we'd generate a bimap that
463 needs impredicative polymorphism. In principle that should be possible
464 (with boxy types and all) but it would take a bit of working out. Here's
466 class ChurchEncode k where
468 -> (forall a b z. a -> b -> z) {- product -}
469 -> (forall a z. a -> z) {- left -}
470 -> (forall a z. a -> z) {- right -}
473 match {| Unit |} Unit unit prod left right = unit
474 match {| a :*: b |} (x :*: y) unit prod left right = prod x y
475 match {| a :+: b |} (Inl l) unit prod left right = left l
476 match {| a :+: b |} (Inr r) unit prod left right = right r
479 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
480 mkGenericRhs sel_id tyvar tycon
481 = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
482 -- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
483 mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
485 -- Initialising the "Environment" with the from/to functions
486 -- on the datatype (actually tycon) in question
487 (from_RDR, to_RDR) = mkGenericNames tycon
489 -- Instantiate the selector type, and strip off its class context
490 (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
492 -- Do it again! This deals with the case where the method type
493 -- is polymorphic -- see Note [Polymorphic methods] above
494 (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
496 -- Now we probably have a tycon in front
497 -- of us, quite probably a FunTyCon.
498 ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
499 bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
501 type EPEnv = (TyVar, -- The class type variable
502 EP (LHsExpr RdrName), -- The EP it maps to
503 [TyVar] -- Other in-scope tyvars; they have an identity EP
507 generate_bimap :: EPEnv
509 -> EP (LHsExpr RdrName)
510 -- Top level case - splitting the TyCon.
511 generate_bimap env@(tv,ep,local_tvs) ty
512 | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
513 = idEP -- A constant type
515 | Just tv1 <- getTyVar_maybe ty
516 = ASSERT( tv == tv1 ) ep -- The class tyvar
518 | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
519 = bimapTyCon tycon (map (generate_bimap env) ty_args)
522 = pprPanic "generate_bimap" (ppr ty)
525 bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
526 bimapTyCon tycon arg_eps
527 | tycon == funTyCon = bimapArrow arg_eps
528 | tycon == listTyCon = bimapList arg_eps
529 | isBoxedTupleTyCon tycon = bimapTuple arg_eps
530 | otherwise = pprPanic "bimapTyCon" (ppr tycon)
533 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
534 bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
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)
544 bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
546 = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
547 toEP = mkHsLam [noLoc tuple_pat] to_body }
549 names = takeList eps gs_RDR
550 tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
551 eps_w_names = eps `zip` names
552 to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
553 from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
556 -- bimapList :: EP a b -> EP [a] [b]
557 bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
559 = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
560 toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
563 a_RDR, b_RDR :: RdrName
564 a_RDR = mkVarUnqual (fsLit "a")
565 b_RDR = mkVarUnqual (fsLit "b")
568 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
570 idEP :: EP (LHsExpr RdrName)
571 idEP = EP idexpr idexpr
573 idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)