Improve dead block calculation, per Simon Marlow's advice.
[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 <=> want generics functions
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 want_generics 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 want_generics gadt_syn) }
78
79   | otherwise
80   = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
81                        parent is_rec want_generics 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 = mkFamInstCoercion 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 = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
131               cocon_maybe | all_coercions || isRecursiveTyCon tycon 
132                           = Just co_tycon
133                           | otherwise              
134                           = Nothing
135         ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
136         ; return (NewTyCon { data_con    = con, 
137                              nt_rhs      = rhs_ty,
138                              nt_etad_rhs = (etad_tvs, etad_rhs),
139                              nt_co       = cocon_maybe } ) }
140                              -- Coreview looks through newtypes with a Nothing
141                              -- for nt_co, or uses explicit coercions otherwise
142   where
143         -- If all_coercions is True then we use coercions for all newtypes
144         -- otherwise we use coercions for recursive newtypes and look through
145         -- non-recursive newtypes
146     all_coercions = True
147     tvs    = tyConTyVars tycon
148     inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
149     rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
150         -- Instantiate the data con with the 
151         -- type variables from the tycon
152         -- NB: a newtype DataCon has a type that must look like
153         --        forall tvs.  <arg-ty> -> T tvs
154         -- Note that we *can't* use dataConInstOrigArgTys here because
155         -- the newtype arising from   class Foo a => Bar a where {}
156         -- has a single argument (Foo a) that is a *type class*, so
157         -- dataConInstOrigArgTys returns [].
158
159     etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
160     etad_rhs :: Type    -- return a TyCon without pulling on rhs_ty
161                         -- See Note [Tricky iface loop] in LoadIface
162     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
163  
164     eta_reduce :: [TyVar]               -- Reversed
165                -> Type                  -- Rhs type
166                -> ([TyVar], Type)       -- Eta-reduced version (tyvars in normal order)
167     eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
168                            Just tv <- getTyVar_maybe arg,
169                            tv == a,
170                            not (a `elemVarSet` tyVarsOfType fun)
171                          = eta_reduce as fun
172     eta_reduce tvs ty = (reverse tvs, ty)
173                                 
174
175 ------------------------------------------------------
176 buildDataCon :: Name -> Bool
177             -> [HsBang] 
178             -> [Name]                   -- Field labels
179             -> [TyVar] -> [TyVar]       -- Univ and ext 
180             -> [(TyVar,Type)]           -- Equality spec
181             -> ThetaType                -- Does not include the "stupid theta"
182                                         -- or the GADT equalities
183             -> [Type] -> Type           -- Argument and result types
184             -> TyCon                    -- Rep tycon
185             -> TcRnIf m n DataCon
186 -- A wrapper for DataCon.mkDataCon that
187 --   a) makes the worker Id
188 --   b) makes the wrapper Id if necessary, including
189 --      allocating its unique (hence monadic)
190 buildDataCon src_name declared_infix arg_stricts field_lbls
191              univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
192   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
193         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
194         -- This last one takes the name of the data constructor in the source
195         -- code, which (for Haskell source anyway) will be in the DataName name
196         -- space, and puts it into the VarName name space
197
198         ; let
199                 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
200                 data_con = mkDataCon src_name declared_infix
201                                      arg_stricts field_lbls
202                                      univ_tvs ex_tvs eq_spec ctxt
203                                      arg_tys res_ty rep_tycon
204                                      stupid_ctxt dc_ids
205                 dc_ids = mkDataConIds wrap_name work_name data_con
206
207         ; return data_con }
208
209
210 -- The stupid context for a data constructor should be limited to
211 -- the type variables mentioned in the arg_tys
212 -- ToDo: Or functionally dependent on?  
213 --       This whole stupid theta thing is, well, stupid.
214 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
215 mkDataConStupidTheta tycon arg_tys univ_tvs
216   | null stupid_theta = []      -- The common case
217   | otherwise         = filter in_arg_tys stupid_theta
218   where
219     tc_subst     = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
220     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
221         -- Start by instantiating the master copy of the 
222         -- stupid theta, taken from the TyCon
223
224     arg_tyvars      = tyVarsOfTypes arg_tys
225     in_arg_tys pred = not $ isEmptyVarSet $ 
226                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
227 \end{code}
228
229
230 ------------------------------------------------------
231 \begin{code}
232 type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate 
233                                              -- between tcClassSigs and buildClass
234
235 buildClass :: Bool              -- True <=> do not include unfoldings 
236                                 --          on dict selectors
237                                 -- Used when importing a class without -O
238            -> Name -> [TyVar] -> ThetaType
239            -> [FunDep TyVar]               -- Functional dependencies
240            -> [TyThing]                    -- Associated types
241            -> [TcMethInfo]                 -- Method info
242            -> RecFlag                      -- Info for type constructor
243            -> TcRnIf m n Class
244
245 buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
246   = do  { traceIf (text "buildClass")
247         ; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
248         ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
249                 -- The class name is the 'parent' for this datacon, not its tycon,
250                 -- because one should import the class to get the binding for 
251                 -- the datacon
252
253         ; fixM (\ rec_clas -> do {      -- Only name generation inside loop
254
255         ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
256                         -- Build the selector id and default method id
257
258         ; let (eq_theta, dict_theta) = partition isEqPred sc_theta
259
260               -- We only make selectors for the *value* superclasses, 
261               -- not equality predicates 
262         ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
263                                 [1..length dict_theta]
264         ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas 
265                            | sc_name <- sc_sel_names]
266               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
267               -- can construct names for the selectors. Thus
268               --      class (C a, C b) => D a b where ...
269               -- gives superclass selectors
270               --      D_sc1, D_sc2
271               -- (We used to call them D_C, but now we can have two different
272               --  superclasses both called C!)
273         
274         ; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1)
275                 -- Use a newtype if the data constructor has 
276                 --      (a) exactly one value field
277                 --      (b) no existential or equality-predicate fields
278                 -- i.e. exactly one operation or superclass taken together
279                 -- See note [Class newtypes and equality predicates]
280
281                 -- We play a bit fast and loose by treating the dictionary
282                 -- superclasses as ordinary arguments.  That means that in 
283                 -- the case of
284                 --     class C a => D a
285                 -- we don't get a newtype with no arguments!
286               args      = sc_sel_names ++ op_names
287               op_tys    = [ty | (_,_,ty) <- sig_stuff]
288               op_names  = [op | (op,_,_) <- sig_stuff]
289               arg_tys   = map mkPredTy dict_theta ++ op_tys
290               rec_tycon = classTyCon rec_clas
291                
292         ; dict_con <- buildDataCon datacon_name
293                                    False        -- Not declared infix
294                                    (map (const HsNoBang) args)
295                                    [{- No fields -}]
296                                    tvs [{- no existentials -}]
297                                    [{- No GADT equalities -}] 
298                                    eq_theta
299                                    arg_tys
300                                    (mkTyConApp rec_tycon (mkTyVarTys tvs))
301                                    rec_tycon
302
303         ; rhs <- if use_newtype
304                  then mkNewTyConRhs tycon_name rec_tycon dict_con
305                  else return (mkDataTyConRhs [dict_con])
306
307         ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
308
309               ; tycon = mkClassTyCon tycon_name clas_kind tvs
310                                      rhs rec_clas tc_isrec
311                 -- A class can be recursive, and in the case of newtypes 
312                 -- this matters.  For example
313                 --      class C a where { op :: C b => a -> b -> Int }
314                 -- Because C has only one operation, it is represented by
315                 -- a newtype, and it should be a *recursive* newtype.
316                 -- [If we don't make it a recursive newtype, we'll expand the
317                 -- newtype like a synonym, but that will lead to an infinite
318                 -- type]
319               ; atTyCons = [tycon | ATyCon tycon <- ats]
320
321               ; result = mkClass class_name tvs fds 
322                                  (eq_theta ++ dict_theta)  -- Equalities first
323                                  (length eq_theta)         -- Number of equalities
324                                  sc_sel_ids atTyCons
325                                  op_items tycon
326               }
327         ; traceIf (text "buildClass" <+> ppr tycon) 
328         ; return result
329         })}
330   where
331     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
332     mk_op_item rec_clas (op_name, dm_spec, _) 
333       = do { dm_info <- case dm_spec of
334                           NoDM      -> return NoDefMeth
335                           GenericDM -> return GenDefMeth
336                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
337                                           ; return (DefMeth dm_name) }
338            ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
339 \end{code}
340
341 Note [Class newtypes and equality predicates]
342 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
343 Consider
344         class (a ~ F b) => C a b where
345           op :: a -> b
346
347 We cannot represent this by a newtype, even though it's not
348 existential, and there's only one value field, because we do
349 capture an equality predicate:
350
351         data C a b where
352           MkC :: forall a b. (a ~ F b) => (a->b) -> C a b
353
354 We need to access this equality predicate when we get passes a C
355 dictionary.  See Trac #2238
356