Add tuple sections as a new feature
[ghc.git] / compiler / types / Generics.lhs
1 %
2 % (c) The University of Glasgow 2006
3 %
4
5 \begin{code}
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
11 -- for details
12
13 module Generics ( canDoGenerics, mkTyConGenericBinds,
14                   mkGenericRhs, 
15                   validGenericInstanceType, validGenericMethodType
16     ) where
17
18
19 import HsSyn
20 import Type
21 import TcType
22 import DataCon
23
24 import TyCon
25 import Name
26 import RdrName
27 import BasicTypes
28 import Var
29 import VarSet
30 import Id
31 import TysWiredIn
32 import PrelNames
33         
34 import SrcLoc
35 import Util
36 import Bag
37 import Outputable 
38 import FastString
39
40 #include "HsVersions.h"
41 \end{code}
42
43 Roadmap of what's where in the Generics work.
44 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
45
46 Parser
47 No real checks.
48
49 RnSource.rnHsType
50   Checks that HsNumTy has a "1" in it.
51
52 TcInstDcls.mkGenericInstance:
53   Checks for invalid type patterns, such as f {| Int |}
54
55 TcClassDcl.tcClassSig
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
59
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.
65
66 TcClassDecl.checkGenericClassIsUnary
67   Checks that we don't have generic methods in a multi-parameter class
68
69 TcClassDecl.checkDefaultBinds
70   Checks that all the equations for a method in a class decl
71   are generic, or all are non-generic
72
73
74                         
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]
83
84 Generics.lhs
85
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).
90
91 TyCon.lhs
92
93 Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
94
95 TysWiredIn.lhs
96
97 Defines generic and other type and data constructors.
98
99 This is sadly incomplete, but will be added to.
100
101
102 Bugs & shortcomings of existing implementation:
103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104
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,
109
110 class Er a where
111  ...
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
115  
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.
119
120 check_ty
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-}]
124
125 This is a bug as if I change the code to
126
127  er {| Plus c b |} (Inl x)  (Inl y) = er x y 
128
129 all the names come out to be different.
130
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.
134
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.
140
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.
146
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)
150  
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" 
154
155
156 What has not been addressed:
157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
158
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)
162
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
165 RHS?
166
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
170 important.
171
172
173
174 %************************************************************************
175 %*                                                                      *
176 \subsection{Getting the representation type out}
177 %*                                                                      *
178 %************************************************************************
179
180 \begin{code}
181 validGenericInstanceType :: Type -> Bool
182   -- Checks for validity of the type pattern in a generic
183   -- declaration.  It's ok to have  
184   --    f {| a + b |} ...
185   -- but it's not OK to have
186   --    f {| a + Int |}
187
188 validGenericInstanceType inst_ty
189   = case tcSplitTyConApp_maybe inst_ty of
190         Just (tycon, tys) ->  all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
191         Nothing           ->  False
192
193 validGenericMethodType :: Type -> Bool
194   -- At the moment we only allow method types built from
195   --    * type variables
196   --    * function arrow
197   --    * boxed tuples
198   --    * lists
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 
203   = valid tau
204   where
205     (local_tvs, _, tau) = tcSplitSigmaTy ty
206
207     valid 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
213                                 Nothing       -> False
214       where
215         no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
216
217     valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc 
218         -- Compare bimapApp, below
219 \end{code}
220
221
222 %************************************************************************
223 %*                                                                      *
224 \subsection{Generating representation types}
225 %*                                                                      *
226 %************************************************************************
227
228 \begin{code}
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.)
233
234 canDoGenerics data_cons
235   =  not (any bad_con data_cons)        -- See comment below
236   && not (null data_cons)               -- No values of the type
237   where
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
243
244         -- Nor can we do the job if it's an existential data constructor,
245
246         -- Nor if the args are polymorphic types (I don't think)
247     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
248 \end{code}
249
250 %************************************************************************
251 %*                                                                      *
252 \subsection{Generating the RHS of a generic default method}
253 %*                                                                      *
254 %************************************************************************
255
256 \begin{code}
257 type US = Int   -- Local unique supply, just a plain Int
258 type FromAlt = (LPat RdrName, LHsExpr RdrName)
259
260 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
261 mkTyConGenericBinds tycon
262   = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
263         `unionBags`
264     unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
265   where
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
271
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
276
277 ----------------------------------------------------
278 --      Dealing with sums
279 ----------------------------------------------------
280
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
285
286 -- For example, given
287 --      data T = C | D Int Int Int
288 -- 
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 ->
293 --                                                 D a b c }} },
294 --                         cd)
295
296 mk_sum_stuff us [datacon]
297    = ([from_alt], to_pat, to_body_fn app_exp)
298    where
299      n_args = dataConSourceArity datacon        -- Existentials already excluded
300
301      datacon_vars = map mkGenericLocal [us .. us+n_args-1]
302      us'          = us + n_args
303
304      datacon_rdr  = getRdrName datacon
305      app_exp      = nlHsVarApps datacon_rdr datacon_vars
306      from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
307
308      (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
309
310 mk_sum_stuff us datacons
311   = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
312      nlVarPat to_arg,
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])))
316   where
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
320
321     to_arg = mkGenericLocal us
322     us'    = us+1
323
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]
327
328
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
340
341 -- For example:
342 -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
343 --                               abc,
344 --                               \<body-code> -> case abc of { a :*: bc ->
345 --                                               case bc  of { b :*: c  -> 
346 --                                               <body-code> )
347
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
351
352 mk_prod_stuff us []             -- Unit case
353   = (us+1,
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
360         --                              Inr x -> S x }
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
363
364      \x -> x)
365
366 mk_prod_stuff us [arg_var]      -- Singleton case
367   = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
368
369 mk_prod_stuff us arg_vars       -- Two or more
370   = (us'', 
371      nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
372      nlVarPat to_arg, 
373 -- gaw 2004 FIX?
374      \x -> noLoc (HsCase (nlHsVar to_arg) 
375                   (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
376   where
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]
382
383 splitInHalf :: [a] -> ([a],[a])
384 splitInHalf list = (left, right)
385                  where
386                    half  = length list `div` 2
387                    left  = take half list
388                    right = drop half list
389
390 mkGenericLocal :: US -> RdrName
391 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
392
393 mkGenericNames :: TyCon -> (RdrName, RdrName)
394 mkGenericNames tycon
395   = (from_RDR, to_RDR)
396   where
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)
402 \end{code}
403
404 %************************************************************************
405 %*                                                                      *
406 \subsection{Generating the RHS of a generic default method}
407 %*                                                                      *
408 %************************************************************************
409
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
413
414         class Foo a where
415           op :: Op a
416
417         instance Foo T
418
419 Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
420
421         instance Foo T where
422            op = <mkGenericRhs op a T>
423
424 To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
425
426         toOp   :: Op Trep -> Op T
427         fromOp :: Op T    -> Op Trep
428
429 (the bimap) and then fill in the RHS with
430
431         instance Foo T where
432            op = toOp op
433
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.
437
438
439 Note [Polymorphic methods]
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~
441 Suppose the class op is polymorphic:
442
443         class Baz a where
444           op :: forall b. Ord b => a -> b -> b
445
446 Then we can still generate a bimap with
447
448         toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
449
450 and fill in the instance decl thus
451
452         instance Foo T where
453            op = toOp op
454
455 By the time the type checker has done its stuff we'll get
456
457         instance Foo T where
458            op = \b. \dict::Ord b. toOp b (op Trep b dict)
459
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
465 an example:
466   class ChurchEncode k where 
467     match :: k -> z 
468           -> (forall a b z. a -> b -> z)  {- product -} 
469           -> (forall a   z. a -> z)       {- left -} 
470           -> (forall a   z. a -> z)       {- right -} 
471           -> z 
472   
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 
477
478 \begin{code}
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))
484   where 
485         -- Initialising the "Environment" with the from/to functions
486         -- on the datatype (actually tycon) in question
487         (from_RDR, to_RDR) = mkGenericNames tycon 
488
489         -- Instantiate the selector type, and strip off its class context
490         (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
491
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
495
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
500
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
504              )
505
506 -------------------
507 generate_bimap :: EPEnv
508                -> Type
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
514
515   | Just tv1 <- getTyVar_maybe ty
516   = ASSERT( tv == tv1 ) ep                                      -- The class tyvar
517
518   | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
519   = bimapTyCon tycon (map (generate_bimap env) ty_args)
520
521   | otherwise
522   = pprPanic "generate_bimap" (ppr ty)
523
524 -------------------
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)
531
532 -------------------
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 }
538   where
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))
541
542 -------------------
543 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
544 bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
545 bimapTuple eps 
546   = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
547          toEP   = mkHsLam [noLoc tuple_pat] to_body }
548   where
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]
554
555 -------------------
556 -- bimapList :: EP a b -> EP [a] [b]
557 bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
558 bimapList [ep]
559   = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
560          toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
561
562 -------------------
563 a_RDR, b_RDR :: RdrName
564 a_RDR   = mkVarUnqual (fsLit "a")
565 b_RDR   = mkVarUnqual (fsLit "b")
566
567 gs_RDR :: [RdrName]
568 gs_RDR  = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
569
570 idEP :: EP (LHsExpr RdrName)
571 idEP = EP idexpr idexpr
572      where
573        idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
574 \end{code}