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