Simon's fixes to the generated type instances in Generics
[ghc.git] / compiler / iface / BuildTyCl.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 module BuildTyCl (
8         buildSynTyCon, 
9         buildAlgTyCon, 
10         buildDataCon,
11         TcMethInfo, buildClass,
12         mkAbstractTyConRhs, 
13         mkNewTyConRhs, mkDataTyConRhs, 
14         newImplicitBinder
15     ) where
16
17 #include "HsVersions.h"
18
19 import IfaceEnv
20
21 import DataCon
22 import Var
23 import VarSet
24 import BasicTypes
25 import Name
26 import MkId
27 import Class
28 import TyCon
29 import Type
30 import Coercion
31
32 import TcRnMonad
33 import Data.List        ( partition )
34 import Outputable
35 \end{code}
36         
37
38 \begin{code}
39 ------------------------------------------------------
40 buildSynTyCon :: Name -> [TyVar] 
41               -> SynTyConRhs
42               -> Kind                   -- ^ Kind of the RHS
43               -> TyConParent
44               -> Maybe (TyCon, [Type])    -- ^ family instance if applicable
45               -> TcRnIf m n TyCon
46 buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family 
47   | Just fam_inst_info <- mb_family
48   = ASSERT( isNoParent parent )
49     fixM $ \ tycon_rec -> do 
50     { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec 
51     ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) }
52
53   | otherwise
54   = return (mkSynTyCon tc_name kind tvs rhs parent)
55   where
56     kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
57
58 ------------------------------------------------------
59 buildAlgTyCon :: Name -> [TyVar] 
60               -> ThetaType              -- ^ Stupid theta
61               -> AlgTyConRhs
62               -> RecFlag
63               -> Bool                   -- ^ True <=> was declared in GADT syntax
64               -> TyConParent
65               -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
66               -> TcRnIf m n TyCon
67
68 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
69               parent mb_family
70   | Just fam_inst_info <- mb_family
71   = -- We need to tie a knot as the coercion of a data instance depends
72      -- on the instance representation tycon and vice versa.
73     ASSERT( isNoParent parent )
74     fixM $ \ tycon_rec -> do 
75     { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
76     ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
77                          fam_parent is_rec gadt_syn) }
78
79   | otherwise
80   = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
81                        parent is_rec gadt_syn)
82   where
83     kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
84
85 -- | If a family tycon with instance types is given, the current tycon is an
86 -- instance of that family and we need to
87 --
88 -- (1) create a coercion that identifies the family instance type and the
89 --     representation type from Step (1); ie, it is of the form 
90 --         `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
91 --         `F' the family tycon and `R' the (derived) representation tycon,
92 --         and
93 -- (2) produce a `TyConParent' value containing the parent and coercion
94 --     information.
95 --
96 mkFamInstParentInfo :: Name -> [TyVar] 
97                     -> (TyCon, [Type]) 
98                     -> TyCon 
99                     -> TcRnIf m n TyConParent
100 mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
101   = do { -- Create the coercion
102        ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
103        ; let co_tycon = mkFamInstCo co_tycon_name tvs
104                                     family instTys rep_tycon
105        ; return $ FamInstTyCon family instTys co_tycon }
106     
107 ------------------------------------------------------
108 mkAbstractTyConRhs :: AlgTyConRhs
109 mkAbstractTyConRhs = AbstractTyCon
110
111 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
112 mkDataTyConRhs cons
113   = DataTyCon {
114         data_cons = cons,
115         is_enum = not (null cons) && all is_enum_con cons
116                   -- See Note [Enumeration types] in TyCon
117     }
118   where
119     is_enum_con con
120        | (_tvs, theta, arg_tys, _res) <- dataConSig con
121        = null theta && null arg_tys
122
123
124 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
125 -- ^ Monadic because it makes a Name for the coercion TyCon
126 --   We pass the Name of the parent TyCon, as well as the TyCon itself,
127 --   because the latter is part of a knot, whereas the former is not.
128 mkNewTyConRhs tycon_name tycon con 
129   = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
130         ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs
131         ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
132         ; return (NewTyCon { data_con    = con, 
133                              nt_rhs      = rhs_ty,
134                              nt_etad_rhs = (etad_tvs, etad_rhs),
135                              nt_co       = co_tycon } ) }
136                              -- Coreview looks through newtypes with a Nothing
137                              -- for nt_co, or uses explicit coercions otherwise
138   where
139     tvs    = tyConTyVars tycon
140     inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
141     rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
142         -- Instantiate the data con with the 
143         -- type variables from the tycon
144         -- NB: a newtype DataCon has a type that must look like
145         --        forall tvs.  <arg-ty> -> T tvs
146         -- Note that we *can't* use dataConInstOrigArgTys here because
147         -- the newtype arising from   class Foo a => Bar a where {}
148         -- has a single argument (Foo a) that is a *type class*, so
149         -- dataConInstOrigArgTys returns [].
150
151     etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
152     etad_rhs :: Type    -- return a TyCon without pulling on rhs_ty
153                         -- See Note [Tricky iface loop] in LoadIface
154     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
155  
156     eta_reduce :: [TyVar]               -- Reversed
157                -> Type                  -- Rhs type
158                -> ([TyVar], Type)       -- Eta-reduced version (tyvars in normal order)
159     eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
160                            Just tv <- getTyVar_maybe arg,
161                            tv == a,
162                            not (a `elemVarSet` tyVarsOfType fun)
163                          = eta_reduce as fun
164     eta_reduce tvs ty = (reverse tvs, ty)
165                                 
166
167 ------------------------------------------------------
168 buildDataCon :: Name -> Bool
169             -> [HsBang] 
170             -> [Name]                   -- Field labels
171             -> [TyVar] -> [TyVar]       -- Univ and ext 
172             -> [(TyVar,Type)]           -- Equality spec
173             -> ThetaType                -- Does not include the "stupid theta"
174                                         -- or the GADT equalities
175             -> [Type] -> Type           -- Argument and result types
176             -> TyCon                    -- Rep tycon
177             -> TcRnIf m n DataCon
178 -- A wrapper for DataCon.mkDataCon that
179 --   a) makes the worker Id
180 --   b) makes the wrapper Id if necessary, including
181 --      allocating its unique (hence monadic)
182 buildDataCon src_name declared_infix arg_stricts field_lbls
183              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
184   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
185         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
186         -- This last one takes the name of the data constructor in the source
187         -- code, which (for Haskell source anyway) will be in the DataName name
188         -- space, and puts it into the VarName name space
189
190         ; let
191                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
192                 data_con = mkDataCon src_name declared_infix
193                                      arg_stricts field_lbls
194                                      univ_tvs ex_tvs eq_spec ctxt
195                                      arg_tys res_ty rep_tycon
196                                      stupid_ctxt dc_ids
197                 dc_ids = mkDataConIds wrap_name work_name data_con
198
199         ; return data_con }
200
201
202 -- The stupid context for a data constructor should be limited to
203 -- the type variables mentioned in the arg_tys
204 -- ToDo: Or functionally dependent on?  
205 --       This whole stupid theta thing is, well, stupid.
206 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
207 mkDataConStupidTheta tycon arg_tys univ_tvs
208   | null stupid_theta = []      -- The common case
209   | otherwise         = filter in_arg_tys stupid_theta
210   where
211     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
212     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
213         -- Start by instantiating the master copy of the 
214         -- stupid theta, taken from the TyCon
215
216     arg_tyvars      = tyVarsOfTypes arg_tys
217     in_arg_tys pred = not $ isEmptyVarSet $ 
218                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
219 \end{code}
220
221
222 ------------------------------------------------------
223 \begin{code}
224 type TcMethInfo = (Name, DefMethSpec, Type)  
225         -- A temporary intermediate, to communicate between tcClassSigs and
226         -- buildClass.
227
228 buildClass :: Bool              -- True <=> do not include unfoldings 
229                                 --          on dict selectors
230                                 -- Used when importing a class without -O
231            -> Name -> [TyVar] -> ThetaType
232            -> [FunDep TyVar]               -- Functional dependencies
233            -> [TyThing]                    -- Associated types
234            -> [TcMethInfo]                 -- Method info
235            -> RecFlag                      -- Info for type constructor
236            -> TcRnIf m n Class
237
238 buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
239   = do  { traceIf (text "buildClass")
240         ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
241         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
242                 -- The class name is the 'parent' for this datacon, not its tycon,
243                 -- because one should import the class to get the binding for 
244                 -- the datacon
245
246         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
247
248         ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
249                         -- Build the selector id and default method id
250
251         ; let (eq_theta, dict_theta) = partition isEqPred sc_theta
252
253               -- We only make selectors for the *value* superclasses, 
254               -- not equality predicates 
255         ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
256                                 [1..length dict_theta]
257         ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas 
258                            | sc_name <- sc_sel_names]
259               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
260               -- can construct names for the selectors. Thus
261               --      class (C a, C b) => D a b where ...
262               -- gives superclass selectors
263               --      D_sc1, D_sc2
264               -- (We used to call them D_C, but now we can have two different
265               --  superclasses both called C!)
266         
267         ; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1)
268                 -- Use a newtype if the data constructor has 
269                 --      (a) exactly one value field
270                 --      (b) no existential or equality-predicate fields
271                 -- i.e. exactly one operation or superclass taken together
272                 -- See note [Class newtypes and equality predicates]
273
274                 -- We play a bit fast and loose by treating the dictionary
275                 -- superclasses as ordinary arguments.  That means that in 
276                 -- the case of
277                 --     class C a => D a
278                 -- we don't get a newtype with no arguments!
279               args      = sc_sel_names ++ op_names
280               op_tys    = [ty | (_,_,ty) <- sig_stuff]
281               op_names  = [op | (op,_,_) <- sig_stuff]
282               arg_tys   = map mkPredTy dict_theta ++ op_tys
283               rec_tycon = classTyCon rec_clas
284                
285         ; dict_con <- buildDataCon datacon_name
286                                    False        -- Not declared infix
287                                    (map (const HsNoBang) args)
288                                    [{- No fields -}]
289                                    tvs [{- no existentials -}]
290                                    [{- No GADT equalities -}] 
291                                    eq_theta
292                                    arg_tys
293                                    (mkTyConApp rec_tycon (mkTyVarTys tvs))
294                                    rec_tycon
295
296         ; rhs <- if use_newtype
297                  then mkNewTyConRhs tycon_name rec_tycon dict_con
298                  else return (mkDataTyConRhs [dict_con])
299
300         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
301
302               ; tycon = mkClassTyCon tycon_name clas_kind tvs
303                                      rhs rec_clas tc_isrec
304                 -- A class can be recursive, and in the case of newtypes 
305                 -- this matters.  For example
306                 --      class C a where { op :: C b => a -> b -> Int }
307                 -- Because C has only one operation, it is represented by
308                 -- a newtype, and it should be a *recursive* newtype.
309                 -- [If we don't make it a recursive newtype, we'll expand the
310                 -- newtype like a synonym, but that will lead to an infinite
311                 -- type]
312               ; atTyCons = [tycon | ATyCon tycon <- ats]
313
314               ; result = mkClass class_name tvs fds 
315                                  (eq_theta ++ dict_theta)  -- Equalities first
316                                  (length eq_theta)         -- Number of equalities
317                                  sc_sel_ids atTyCons
318                                  op_items tycon
319               }
320         ; traceIf (text "buildClass" <+> ppr tycon) 
321         ; return result
322         })}
323   where
324     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
325     mk_op_item rec_clas (op_name, dm_spec, _) 
326       = do { dm_info <- case dm_spec of
327                           NoDM      -> return NoDefMeth
328                           GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
329                                           ; return (GenDefMeth dm_name) }
330                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
331                                           ; return (DefMeth dm_name) }
332            ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
333 \end{code}
334
335 Note [Class newtypes and equality predicates]
336 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
337 Consider
338         class (a ~ F b) => C a b where
339           op :: a -> b
340
341 We cannot represent this by a newtype, even though it's not
342 existential, and there's only one value field, because we do
343 capture an equality predicate:
344
345         data C a b where
346           MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
347
348 We need to access this equality predicate when we get passes a C
349 dictionary.  See Trac #2238
350