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