Major patch to introduce TyConBinder
[ghc.git] / compiler / iface / BuildTyCl.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5
6 {-# LANGUAGE CPP #-}
7
8 module BuildTyCl (
9 buildDataCon, mkDataConUnivTyVarBinders,
10 buildPatSyn,
11 TcMethInfo, buildClass,
12 distinctAbstractTyConRhs, totallyAbstractTyConRhs,
13 mkNewTyConRhs, mkDataTyConRhs,
14 newImplicitBinder, newTyConRepName
15 ) where
16
17 #include "HsVersions.h"
18
19 import IfaceEnv
20 import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
21 import TysWiredIn( isCTupleTyConName )
22 import DataCon
23 import PatSyn
24 import Var
25 import VarSet
26 import BasicTypes
27 import Name
28 import MkId
29 import Class
30 import TyCon
31 import Type
32 import Id
33 import TcType
34
35 import SrcLoc( noSrcSpan )
36 import DynFlags
37 import TcRnMonad
38 import UniqSupply
39 import Util
40 import Outputable
41
42 distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
43 distinctAbstractTyConRhs = AbstractTyCon True
44 totallyAbstractTyConRhs = AbstractTyCon False
45
46 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
47 mkDataTyConRhs cons
48 = DataTyCon {
49 data_cons = cons,
50 is_enum = not (null cons) && all is_enum_con cons
51 -- See Note [Enumeration types] in TyCon
52 }
53 where
54 is_enum_con con
55 | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)
56 <- dataConFullSig con
57 = null ex_tvs && null eq_spec && null theta && null arg_tys
58
59
60 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
61 -- ^ Monadic because it makes a Name for the coercion TyCon
62 -- We pass the Name of the parent TyCon, as well as the TyCon itself,
63 -- because the latter is part of a knot, whereas the former is not.
64 mkNewTyConRhs tycon_name tycon con
65 = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
66 ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
67 ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
68 ; return (NewTyCon { data_con = con,
69 nt_rhs = rhs_ty,
70 nt_etad_rhs = (etad_tvs, etad_rhs),
71 nt_co = nt_ax } ) }
72 -- Coreview looks through newtypes with a Nothing
73 -- for nt_co, or uses explicit coercions otherwise
74 where
75 tvs = tyConTyVars tycon
76 roles = tyConRoles tycon
77 inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs)
78 rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
79 -- Instantiate the data con with the
80 -- type variables from the tycon
81 -- NB: a newtype DataCon has a type that must look like
82 -- forall tvs. <arg-ty> -> T tvs
83 -- Note that we *can't* use dataConInstOrigArgTys here because
84 -- the newtype arising from class Foo a => Bar a where {}
85 -- has a single argument (Foo a) that is a *type class*, so
86 -- dataConInstOrigArgTys returns [].
87
88 etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
89 etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
90 etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
91 (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
92
93 eta_reduce :: [TyVar] -- Reversed
94 -> [Role] -- also reversed
95 -> Type -- Rhs type
96 -> ([TyVar], [Role], Type) -- Eta-reduced version
97 -- (tyvars in normal order)
98 eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
99 Just tv <- getTyVar_maybe arg,
100 tv == a,
101 not (a `elemVarSet` tyCoVarsOfType fun)
102 = eta_reduce as rs fun
103 eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
104
105 ------------------------------------------------------
106 buildDataCon :: FamInstEnvs
107 -> Name
108 -> Bool -- Declared infix
109 -> TyConRepName
110 -> [HsSrcBang]
111 -> Maybe [HsImplBang]
112 -- See Note [Bangs on imported data constructors] in MkId
113 -> [FieldLabel] -- Field labels
114 -> [TyVarBinder] -- Universals
115 -> [TyVarBinder] -- Existentials
116 -> [EqSpec] -- Equality spec
117 -> ThetaType -- Does not include the "stupid theta"
118 -- or the GADT equalities
119 -> [Type] -> Type -- Argument and result types
120 -> TyCon -- Rep tycon
121 -> TcRnIf m n DataCon
122 -- A wrapper for DataCon.mkDataCon that
123 -- a) makes the worker Id
124 -- b) makes the wrapper Id if necessary, including
125 -- allocating its unique (hence monadic)
126 -- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders
127 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
128 univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
129 = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
130 ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
131 -- This last one takes the name of the data constructor in the source
132 -- code, which (for Haskell source anyway) will be in the DataName name
133 -- space, and puts it into the VarName name space
134
135 ; traceIf (text "buildDataCon 1" <+> ppr src_name)
136 ; us <- newUniqueSupply
137 ; dflags <- getDynFlags
138 ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
139 data_con = mkDataCon src_name declared_infix prom_info
140 src_bangs field_lbls
141 univ_tvs ex_tvs eq_spec ctxt
142 arg_tys res_ty NoRRI rep_tycon
143 stupid_ctxt dc_wrk dc_rep
144 dc_wrk = mkDataConWorkId work_name data_con
145 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
146 impl_bangs data_con)
147
148 ; traceIf (text "buildDataCon 2" <+> ppr src_name)
149 ; return data_con }
150
151
152 -- The stupid context for a data constructor should be limited to
153 -- the type variables mentioned in the arg_tys
154 -- ToDo: Or functionally dependent on?
155 -- This whole stupid theta thing is, well, stupid.
156 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]
157 mkDataConStupidTheta tycon arg_tys univ_tvs
158 | null stupid_theta = [] -- The common case
159 | otherwise = filter in_arg_tys stupid_theta
160 where
161 tc_subst = zipTvSubst (tyConTyVars tycon)
162 (mkTyVarTys (binderVars univ_tvs))
163 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
164 -- Start by instantiating the master copy of the
165 -- stupid theta, taken from the TyCon
166
167 arg_tyvars = tyCoVarsOfTypes arg_tys
168 in_arg_tys pred = not $ isEmptyVarSet $
169 tyCoVarsOfType pred `intersectVarSet` arg_tyvars
170
171
172 mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon
173 -> [TyVarBinder] -- For the DataCon
174 -- See Note [Building the TyBinders for a DataCon]
175 mkDataConUnivTyVarBinders tc_bndrs
176 = map mk_binder tc_bndrs
177 where
178 mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv
179 where
180 vis = case tc_vis of
181 AnonTCB -> Specified
182 NamedTCB Visible -> Specified
183 NamedTCB vis -> vis
184
185 {- Note [Building the TyBinders for a DataCon]
186 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
187 A DataCon needs to keep track of the visibility of its universals and
188 existentials, so that visible type application can work properly. This
189 is done by storing the universal and existential TyVarBinders.
190 See Note [TyVarBinders in DataCons] in DataCon.
191
192 During construction of a DataCon, we often start from the TyBinders of
193 the parent TyCon. For example
194 data Maybe a = Nothing | Just a
195 The DataCons start from the TyBinders of the parent TyCon.
196
197 But the ultimate TyBinders for the DataCon are *different* than those
198 of the DataCon. Here is an example:
199
200 data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
201
202 The TyCon has
203
204 tyConTyVars = [ k:*, a:k->*, b:k]
205 tyConTyBinders = [ Named (TvBndr (k :: *) Invisible), Anon (k->*), Anon k ]
206
207 The TyBinders for App line up with App's kind, given above.
208
209 But the DataCon MkApp has the type
210 MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
211
212 That is, its TyBinders should be
213
214 dataConUnivTyVarBinders = [ TvBndr (k:*) Invisible
215 , TvBndr (a:k->*) Specified
216 , TvBndr (b:k) Specified ]
217
218 So we want to take the TyCon's TyBinders and the TyCon's TyVars and
219 merge them, pulling
220 - variable names from the TyVars
221 - visibilities from the TyBinders
222 - but changing Anon/Visible to Specified
223
224 The last part about Visible->Specified comes from this:
225 data T k (a:k) b = MkT (a b)
226 Here k is Visible in T's kind, but we don't have Visible binders in
227 the TyBinders for a term (see Note [No Visible TyBinder in terms]
228 in TyCoRep), so we change it to Specified when making MkT's TyBinders
229
230 This merging operation is done by mkDataConUnivTyBinders. In contrast,
231 the TyBinders passed to mkDataCon are the final TyBinders stored in the
232 DataCon (mkDataCon does no further work).
233 -}
234
235 ------------------------------------------------------
236 buildPatSyn :: Name -> Bool
237 -> (Id,Bool) -> Maybe (Id, Bool)
238 -> ([TyVarBinder], ThetaType) -- ^ Univ and req
239 -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
240 -> [Type] -- ^ Argument types
241 -> Type -- ^ Result type
242 -> [FieldLabel] -- ^ Field labels for
243 -- a record pattern synonym
244 -> PatSyn
245 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
246 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
247 pat_ty field_labels
248 = -- The assertion checks that the matcher is
249 -- compatible with the pattern synonym
250 ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
251 , ex_tvs `equalLength` ex_tvs1
252 , pat_ty `eqType` substTy subst pat_ty1
253 , prov_theta `eqTypes` substTys subst prov_theta1
254 , req_theta `eqTypes` substTys subst req_theta1
255 , arg_tys `eqTypes` substTys subst arg_tys1
256 ])
257 , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
258 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
259 , ppr pat_ty <+> twiddle <+> ppr pat_ty1
260 , ppr prov_theta <+> twiddle <+> ppr prov_theta1
261 , ppr req_theta <+> twiddle <+> ppr req_theta1
262 , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
263 mkPatSyn src_name declared_infix
264 (univ_tvs, req_theta) (ex_tvs, prov_theta)
265 arg_tys pat_ty
266 matcher builder field_labels
267 where
268 ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
269 ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
270 (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
271 (arg_tys1, _) = tcSplitFunTys cont_tau
272 twiddle = char '~'
273 subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
274 (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
275
276 ------------------------------------------------------
277 type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
278 -- A temporary intermediate, to communicate between
279 -- tcClassSigs and buildClass.
280
281 buildClass :: Name -- Name of the class/tycon (they have the same Name)
282 -> [TyConBinder] -- Of the tycon
283 -> [Role] -> ThetaType
284 -> [FunDep TyVar] -- Functional dependencies
285 -> [ClassATItem] -- Associated types
286 -> [TcMethInfo] -- Method info
287 -> ClassMinimalDef -- Minimal complete definition
288 -> RecFlag -- Info for type constructor
289 -> TcRnIf m n Class
290
291 buildClass tycon_name binders roles sc_theta
292 fds at_items sig_stuff mindef tc_isrec
293 = fixM $ \ rec_clas -> -- Only name generation inside loop
294 do { traceIf (text "buildClass")
295
296 ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
297 ; tc_rep_name <- newTyConRepName tycon_name
298
299 ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
300 -- Build the selector id and default method id
301
302 -- Make selectors for the superclasses
303 ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
304 (takeList sc_theta [fIRST_TAG..])
305 ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
306 | sc_name <- sc_sel_names]
307 -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
308 -- can construct names for the selectors. Thus
309 -- class (C a, C b) => D a b where ...
310 -- gives superclass selectors
311 -- D_sc1, D_sc2
312 -- (We used to call them D_C, but now we can have two different
313 -- superclasses both called C!)
314
315 ; let use_newtype = isSingleton arg_tys
316 -- Use a newtype if the data constructor
317 -- (a) has exactly one value field
318 -- i.e. exactly one operation or superclass taken together
319 -- (b) that value is of lifted type (which they always are, because
320 -- we box equality superclasses)
321 -- See note [Class newtypes and equality predicates]
322
323 -- We treat the dictionary superclasses as ordinary arguments.
324 -- That means that in the case of
325 -- class C a => D a
326 -- we don't get a newtype with no arguments!
327 args = sc_sel_names ++ op_names
328 op_tys = [ty | (_,ty,_) <- sig_stuff]
329 op_names = [op | (op,_,_) <- sig_stuff]
330 arg_tys = sc_theta ++ op_tys
331 rec_tycon = classTyCon rec_clas
332 univ_bndrs = mkDataConUnivTyVarBinders binders
333 univ_tvs = binderVars univ_bndrs
334
335 ; rep_nm <- newTyConRepName datacon_name
336 ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
337 datacon_name
338 False -- Not declared infix
339 rep_nm
340 (map (const no_bang) args)
341 (Just (map (const HsLazy) args))
342 [{- No fields -}]
343 univ_bndrs
344 [{- no existentials -}]
345 [{- No GADT equalities -}]
346 [{- No theta -}]
347 arg_tys
348 (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
349 rec_tycon
350
351 ; rhs <- if use_newtype
352 then mkNewTyConRhs tycon_name rec_tycon dict_con
353 else if isCTupleTyConName tycon_name
354 then return (TupleTyCon { data_con = dict_con
355 , tup_sort = ConstraintTuple })
356 else return (mkDataTyConRhs [dict_con])
357
358 ; let { tycon = mkClassTyCon tycon_name binders roles
359 rhs rec_clas tc_isrec tc_rep_name
360 -- A class can be recursive, and in the case of newtypes
361 -- this matters. For example
362 -- class C a where { op :: C b => a -> b -> Int }
363 -- Because C has only one operation, it is represented by
364 -- a newtype, and it should be a *recursive* newtype.
365 -- [If we don't make it a recursive newtype, we'll expand the
366 -- newtype like a synonym, but that will lead to an infinite
367 -- type]
368
369 ; result = mkClass tycon_name univ_tvs fds
370 sc_theta sc_sel_ids at_items
371 op_items mindef tycon
372 }
373 ; traceIf (text "buildClass" <+> ppr tycon)
374 ; return result }
375 where
376 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
377
378 mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
379 mk_op_item rec_clas (op_name, _, dm_spec)
380 = do { dm_info <- case dm_spec of
381 Nothing -> return Nothing
382 Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
383 ; return (Just (dm_name, spec)) }
384 ; return (mkDictSelId op_name rec_clas, dm_info) }
385
386 {-
387 Note [Class newtypes and equality predicates]
388 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
389 Consider
390 class (a ~ F b) => C a b where
391 op :: a -> b
392
393 We cannot represent this by a newtype, even though it's not
394 existential, because there are two value fields (the equality
395 predicate and op. See Trac #2238
396
397 Moreover,
398 class (a ~ F b) => C a b where {}
399 Here we can't use a newtype either, even though there is only
400 one field, because equality predicates are unboxed, and classes
401 are boxed.
402 -}
403
404 newImplicitBinder :: Name -- Base name
405 -> (OccName -> OccName) -- Occurrence name modifier
406 -> TcRnIf m n Name -- Implicit name
407 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
408 -- For source type/class decls, this is the first occurrence
409 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
410 newImplicitBinder base_name mk_sys_occ
411 | Just mod <- nameModule_maybe base_name
412 = newGlobalBinder mod occ loc
413 | otherwise -- When typechecking a [d| decl bracket |],
414 -- TH generates types, classes etc with Internal names,
415 -- so we follow suit for the implicit binders
416 = do { uniq <- newUnique
417 ; return (mkInternalName uniq occ loc) }
418 where
419 occ = mk_sys_occ (nameOccName base_name)
420 loc = nameSrcSpan base_name
421
422 -- | Make the 'TyConRepName' for this 'TyCon'
423 newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
424 newTyConRepName tc_name
425 | Just mod <- nameModule_maybe tc_name
426 , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
427 = newGlobalBinder mod occ noSrcSpan
428 | otherwise
429 = newImplicitBinder tc_name mkTyConRepOcc