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