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