Generate Typeable info at definition sites
[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 buildSynonymTyCon,
10 buildFamilyTyCon,
11 buildAlgTyCon,
12 buildDataCon,
13 buildPatSyn,
14 TcMethInfo, buildClass,
15 distinctAbstractTyConRhs, totallyAbstractTyConRhs,
16 mkNewTyConRhs, mkDataTyConRhs,
17 newImplicitBinder, newTyConRepName
18 ) where
19
20 #include "HsVersions.h"
21
22 import IfaceEnv
23 import FamInstEnv( FamInstEnvs )
24 import TysWiredIn( isCTupleTyConName )
25 import PrelNames( tyConRepModOcc )
26 import DataCon
27 import PatSyn
28 import Var
29 import VarSet
30 import BasicTypes
31 import Name
32 import MkId
33 import Class
34 import TyCon
35 import Type
36 import Id
37 import Coercion
38 import TcType
39
40 import SrcLoc( noSrcSpan )
41 import DynFlags
42 import TcRnMonad
43 import UniqSupply
44 import Util
45 import Outputable
46
47 ------------------------------------------------------
48 buildSynonymTyCon :: Name -> [TyVar] -> [Role]
49 -> Type
50 -> Kind -- ^ Kind of the RHS
51 -> TyCon
52 buildSynonymTyCon tc_name tvs roles rhs rhs_kind
53 = mkSynonymTyCon tc_name kind tvs roles rhs
54 where
55 kind = mkPiKinds tvs rhs_kind
56
57
58 buildFamilyTyCon :: Name -- ^ Type family name
59 -> [TyVar] -- ^ Type variables
60 -> Maybe Name -- ^ Result variable name
61 -> FamTyConFlav -- ^ Open, closed or in a boot file?
62 -> Kind -- ^ Kind of the RHS
63 -> Maybe Class -- ^ Parent, if exists
64 -> Injectivity -- ^ Injectivity annotation
65 -- See [Injectivity annotation] in HsDecls
66 -> TyCon
67 buildFamilyTyCon tc_name tvs res_tv rhs rhs_kind parent injectivity
68 = mkFamilyTyCon tc_name kind tvs res_tv rhs parent injectivity
69 where kind = mkPiKinds tvs rhs_kind
70
71
72 ------------------------------------------------------
73 distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
74 distinctAbstractTyConRhs = AbstractTyCon True
75 totallyAbstractTyConRhs = AbstractTyCon False
76
77 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
78 mkDataTyConRhs cons
79 = DataTyCon {
80 data_cons = cons,
81 is_enum = not (null cons) && all is_enum_con cons
82 -- See Note [Enumeration types] in TyCon
83 }
84 where
85 is_enum_con con
86 | (_tvs, theta, arg_tys, _res) <- dataConSig con
87 = null theta && null arg_tys
88
89
90 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
91 -- ^ Monadic because it makes a Name for the coercion TyCon
92 -- We pass the Name of the parent TyCon, as well as the TyCon itself,
93 -- because the latter is part of a knot, whereas the former is not.
94 mkNewTyConRhs tycon_name tycon con
95 = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
96 ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs
97 ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
98 ; return (NewTyCon { data_con = con,
99 nt_rhs = rhs_ty,
100 nt_etad_rhs = (etad_tvs, etad_rhs),
101 nt_co = co_tycon } ) }
102 -- Coreview looks through newtypes with a Nothing
103 -- for nt_co, or uses explicit coercions otherwise
104 where
105 tvs = tyConTyVars tycon
106 roles = tyConRoles tycon
107 inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
108 rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
109 -- Instantiate the data con with the
110 -- type variables from the tycon
111 -- NB: a newtype DataCon has a type that must look like
112 -- forall tvs. <arg-ty> -> T tvs
113 -- Note that we *can't* use dataConInstOrigArgTys here because
114 -- the newtype arising from class Foo a => Bar a where {}
115 -- has a single argument (Foo a) that is a *type class*, so
116 -- dataConInstOrigArgTys returns [].
117
118 etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
119 etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
120 etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
121 (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
122
123 eta_reduce :: [TyVar] -- Reversed
124 -> [Role] -- also reversed
125 -> Type -- Rhs type
126 -> ([TyVar], [Role], Type) -- Eta-reduced version
127 -- (tyvars in normal order)
128 eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
129 Just tv <- getTyVar_maybe arg,
130 tv == a,
131 not (a `elemVarSet` tyVarsOfType fun)
132 = eta_reduce as rs fun
133 eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
134
135
136 ------------------------------------------------------
137 buildDataCon :: FamInstEnvs
138 -> Name
139 -> Bool -- Declared infix
140 -> Promoted TyConRepName -- Promotable
141 -> [HsSrcBang]
142 -> Maybe [HsImplBang]
143 -- See Note [Bangs on imported data constructors] in MkId
144 -> [FieldLabel] -- Field labels
145 -> [TyVar] -> [TyVar] -- Univ and ext
146 -> [(TyVar,Type)] -- Equality spec
147 -> ThetaType -- Does not include the "stupid theta"
148 -- or the GADT equalities
149 -> [Type] -> Type -- Argument and result types
150 -> TyCon -- Rep tycon
151 -> TcRnIf m n DataCon
152 -- A wrapper for DataCon.mkDataCon that
153 -- a) makes the worker Id
154 -- b) makes the wrapper Id if necessary, including
155 -- allocating its unique (hence monadic)
156 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
157 univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
158 = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
159 ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
160 -- This last one takes the name of the data constructor in the source
161 -- code, which (for Haskell source anyway) will be in the DataName name
162 -- space, and puts it into the VarName name space
163
164 ; traceIf (text "buildDataCon 1" <+> ppr src_name)
165 ; us <- newUniqueSupply
166 ; dflags <- getDynFlags
167 ; let
168 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
169 data_con = mkDataCon src_name declared_infix prom_info
170 src_bangs field_lbls
171 univ_tvs ex_tvs eq_spec ctxt
172 arg_tys res_ty rep_tycon
173 stupid_ctxt dc_wrk dc_rep
174 dc_wrk = mkDataConWorkId work_name data_con
175 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
176 impl_bangs data_con)
177
178 ; traceIf (text "buildDataCon 2" <+> ppr src_name)
179 ; return data_con }
180
181
182 -- The stupid context for a data constructor should be limited to
183 -- the type variables mentioned in the arg_tys
184 -- ToDo: Or functionally dependent on?
185 -- This whole stupid theta thing is, well, stupid.
186 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
187 mkDataConStupidTheta tycon arg_tys univ_tvs
188 | null stupid_theta = [] -- The common case
189 | otherwise = filter in_arg_tys stupid_theta
190 where
191 tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
192 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
193 -- Start by instantiating the master copy of the
194 -- stupid theta, taken from the TyCon
195
196 arg_tyvars = tyVarsOfTypes arg_tys
197 in_arg_tys pred = not $ isEmptyVarSet $
198 tyVarsOfType pred `intersectVarSet` arg_tyvars
199
200
201 ------------------------------------------------------
202 buildPatSyn :: Name -> Bool
203 -> (Id,Bool) -> Maybe (Id, Bool)
204 -> ([TyVar], ThetaType) -- ^ Univ and req
205 -> ([TyVar], ThetaType) -- ^ Ex and prov
206 -> [Type] -- ^ Argument types
207 -> Type -- ^ Result type
208 -> [FieldLabel] -- ^ Field labels for
209 -- a record pattern synonym
210 -> PatSyn
211 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
212 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
213 pat_ty field_labels
214 = ASSERT((and [ univ_tvs == univ_tvs'
215 , ex_tvs == ex_tvs'
216 , pat_ty `eqType` pat_ty'
217 , prov_theta `eqTypes` prov_theta'
218 , req_theta `eqTypes` req_theta'
219 , arg_tys `eqTypes` arg_tys'
220 ]))
221 mkPatSyn src_name declared_infix
222 (univ_tvs, req_theta) (ex_tvs, prov_theta)
223 arg_tys pat_ty
224 matcher builder field_labels
225 where
226 ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
227 ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
228 (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
229 (arg_tys', _) = tcSplitFunTys cont_tau
230
231 -- ------------------------------------------------------
232
233 type TcMethInfo = (Name, DefMethSpec, Type)
234 -- A temporary intermediate, to communicate between
235 -- tcClassSigs and buildClass.
236
237 buildClass :: Name -- Name of the class/tycon (they have the same Name)
238 -> [TyVar] -> [Role] -> ThetaType
239 -> [FunDep TyVar] -- Functional dependencies
240 -> [ClassATItem] -- Associated types
241 -> [TcMethInfo] -- Method info
242 -> ClassMinimalDef -- Minimal complete definition
243 -> RecFlag -- Info for type constructor
244 -> TcRnIf m n Class
245
246 buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
247 = fixM $ \ rec_clas -> -- Only name generation inside loop
248 do { traceIf (text "buildClass")
249
250 ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
251 ; tc_rep_name <- newTyConRepName tycon_name
252
253 ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
254 -- Build the selector id and default method id
255
256 -- Make selectors for the superclasses
257 ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
258 (takeList sc_theta [fIRST_TAG..])
259 ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
260 | sc_name <- sc_sel_names]
261 -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
262 -- can construct names for the selectors. Thus
263 -- class (C a, C b) => D a b where ...
264 -- gives superclass selectors
265 -- D_sc1, D_sc2
266 -- (We used to call them D_C, but now we can have two different
267 -- superclasses both called C!)
268
269 ; let use_newtype = isSingleton arg_tys
270 -- Use a newtype if the data constructor
271 -- (a) has exactly one value field
272 -- i.e. exactly one operation or superclass taken together
273 -- (b) that value is of lifted type (which they always are, because
274 -- we box equality superclasses)
275 -- See note [Class newtypes and equality predicates]
276
277 -- We treat the dictionary superclasses as ordinary arguments.
278 -- That means that in the case of
279 -- class C a => D a
280 -- we don't get a newtype with no arguments!
281 args = sc_sel_names ++ op_names
282 op_tys = [ty | (_,_,ty) <- sig_stuff]
283 op_names = [op | (op,_,_) <- sig_stuff]
284 arg_tys = sc_theta ++ op_tys
285 rec_tycon = classTyCon rec_clas
286
287 ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
288 datacon_name
289 False -- Not declared infix
290 NotPromoted -- Class tycons are not promoted
291 (map (const no_bang) args)
292 (Just (map (const HsLazy) args))
293 [{- No fields -}]
294 tvs [{- no existentials -}]
295 [{- No GADT equalities -}]
296 [{- No theta -}]
297 arg_tys
298 (mkTyConApp rec_tycon (mkTyVarTys tvs))
299 rec_tycon
300
301 ; rhs <- if use_newtype
302 then mkNewTyConRhs tycon_name rec_tycon dict_con
303 else if isCTupleTyConName tycon_name
304 then return (TupleTyCon { data_con = dict_con
305 , tup_sort = ConstraintTuple })
306 else return (mkDataTyConRhs [dict_con])
307
308 ; let { clas_kind = mkPiKinds tvs constraintKind
309 ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
310 rhs rec_clas tc_isrec tc_rep_name
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
320 ; result = mkClass tvs fds
321 sc_theta sc_sel_ids at_items
322 op_items mindef tycon
323 }
324 ; traceIf (text "buildClass" <+> ppr tycon)
325 ; return result }
326 where
327 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
328
329 mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
330 mk_op_item rec_clas (op_name, dm_spec, _)
331 = do { dm_info <- case dm_spec of
332 NoDM -> return NoDefMeth
333 GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
334 ; return (GenDefMeth dm_name) }
335 VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
336 ; return (DefMeth dm_name) }
337 ; return (mkDictSelId op_name rec_clas, dm_info) }
338
339 {-
340 Note [Class newtypes and equality predicates]
341 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
342 Consider
343 class (a ~ F b) => C a b where
344 op :: a -> b
345
346 We cannot represent this by a newtype, even though it's not
347 existential, because there are two value fields (the equality
348 predicate and op. See Trac #2238
349
350 Moreover,
351 class (a ~ F b) => C a b where {}
352 Here we can't use a newtype either, even though there is only
353 one field, because equality predicates are unboxed, and classes
354 are boxed.
355 -}
356
357 newImplicitBinder :: Name -- Base name
358 -> (OccName -> OccName) -- Occurrence name modifier
359 -> TcRnIf m n Name -- Implicit name
360 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
361 -- For source type/class decls, this is the first occurrence
362 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
363 newImplicitBinder base_name mk_sys_occ
364 | Just mod <- nameModule_maybe base_name
365 = newGlobalBinder mod occ loc
366 | otherwise -- When typechecking a [d| decl bracket |],
367 -- TH generates types, classes etc with Internal names,
368 -- so we follow suit for the implicit binders
369 = do { uniq <- newUnique
370 ; return (mkInternalName uniq occ loc) }
371 where
372 occ = mk_sys_occ (nameOccName base_name)
373 loc = nameSrcSpan base_name
374
375 -- | Make the 'TyConRepName' for this 'TyCon'
376 newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
377 newTyConRepName tc_name
378 | Just mod <- nameModule_maybe tc_name
379 , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
380 = newGlobalBinder mod occ noSrcSpan
381 | otherwise
382 = newImplicitBinder tc_name mkTyConRepUserOcc