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