87b5f36b7e02fbd0d97afabe8205aa390cd47c86
[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 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 -> [TyVar] -> [TyVar] -- Univ and ext
115 -> [EqSpec] -- Equality spec
116 -> ThetaType -- Does not include the "stupid theta"
117 -- or the GADT equalities
118 -> [Type] -> Type -- Argument and result types
119 -> TyCon -- Rep tycon
120 -> TcRnIf m n DataCon
121 -- A wrapper for DataCon.mkDataCon that
122 -- a) makes the worker Id
123 -- b) makes the wrapper Id if necessary, including
124 -- allocating its unique (hence monadic)
125 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
126 univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
127 = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
128 ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
129 -- This last one takes the name of the data constructor in the source
130 -- code, which (for Haskell source anyway) will be in the DataName name
131 -- space, and puts it into the VarName name space
132
133 ; traceIf (text "buildDataCon 1" <+> ppr src_name)
134 ; us <- newUniqueSupply
135 ; dflags <- getDynFlags
136 ; let
137 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
138 data_con = mkDataCon src_name declared_infix prom_info
139 src_bangs field_lbls
140 univ_tvs ex_tvs eq_spec ctxt
141 arg_tys res_ty NoRRI rep_tycon
142 stupid_ctxt dc_wrk dc_rep
143 dc_wrk = mkDataConWorkId work_name data_con
144 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
145 impl_bangs data_con)
146
147 ; traceIf (text "buildDataCon 2" <+> ppr src_name)
148 ; return data_con }
149
150
151 -- The stupid context for a data constructor should be limited to
152 -- the type variables mentioned in the arg_tys
153 -- ToDo: Or functionally dependent on?
154 -- This whole stupid theta thing is, well, stupid.
155 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
156 mkDataConStupidTheta tycon arg_tys univ_tvs
157 | null stupid_theta = [] -- The common case
158 | otherwise = filter in_arg_tys stupid_theta
159 where
160 tc_subst = zipTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
161 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
162 -- Start by instantiating the master copy of the
163 -- stupid theta, taken from the TyCon
164
165 arg_tyvars = tyCoVarsOfTypes arg_tys
166 in_arg_tys pred = not $ isEmptyVarSet $
167 tyCoVarsOfType pred `intersectVarSet` arg_tyvars
168
169
170 ------------------------------------------------------
171 buildPatSyn :: Name -> Bool
172 -> (Id,Bool) -> Maybe (Id, Bool)
173 -> ([TyVar], ThetaType) -- ^ Univ and req
174 -> ([TyVar], ThetaType) -- ^ Ex and prov
175 -> [Type] -- ^ Argument types
176 -> Type -- ^ Result type
177 -> [FieldLabel] -- ^ Field labels for
178 -- a record pattern synonym
179 -> PatSyn
180 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
181 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
182 pat_ty field_labels
183 = -- The assertion checks that the matcher is
184 -- compatible with the pattern synonym
185 ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
186 , ex_tvs `equalLength` ex_tvs1
187 , pat_ty `eqType` substTy subst pat_ty1
188 , prov_theta `eqTypes` substTys subst prov_theta1
189 , req_theta `eqTypes` substTys subst req_theta1
190 , arg_tys `eqTypes` substTys subst arg_tys1
191 ])
192 , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
193 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
194 , ppr pat_ty <+> twiddle <+> ppr pat_ty1
195 , ppr prov_theta <+> twiddle <+> ppr prov_theta1
196 , ppr req_theta <+> twiddle <+> ppr req_theta1
197 , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
198 mkPatSyn src_name declared_infix
199 (univ_tvs, req_theta) (ex_tvs, prov_theta)
200 arg_tys pat_ty
201 matcher builder field_labels
202 where
203 ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
204 ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
205 (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
206 (arg_tys1, _) = tcSplitFunTys cont_tau
207 twiddle = char '~'
208 subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
209 (mkTyVarTys (univ_tvs ++ ex_tvs))
210
211 ------------------------------------------------------
212 type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
213 -- A temporary intermediate, to communicate between
214 -- tcClassSigs and buildClass.
215
216 buildClass :: Name -- Name of the class/tycon (they have the same Name)
217 -> [TyVar] -> [Role] -> ThetaType
218 -> [TyBinder]
219 -> [FunDep TyVar] -- Functional dependencies
220 -> [ClassATItem] -- Associated types
221 -> [TcMethInfo] -- Method info
222 -> ClassMinimalDef -- Minimal complete definition
223 -> RecFlag -- Info for type constructor
224 -> TcRnIf m n Class
225
226 buildClass tycon_name tvs roles sc_theta binders
227 fds at_items sig_stuff mindef tc_isrec
228 = fixM $ \ rec_clas -> -- Only name generation inside loop
229 do { traceIf (text "buildClass")
230
231 ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
232 ; tc_rep_name <- newTyConRepName tycon_name
233
234 ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
235 -- Build the selector id and default method id
236
237 -- Make selectors for the superclasses
238 ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
239 (takeList sc_theta [fIRST_TAG..])
240 ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
241 | sc_name <- sc_sel_names]
242 -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
243 -- can construct names for the selectors. Thus
244 -- class (C a, C b) => D a b where ...
245 -- gives superclass selectors
246 -- D_sc1, D_sc2
247 -- (We used to call them D_C, but now we can have two different
248 -- superclasses both called C!)
249
250 ; let use_newtype = isSingleton arg_tys
251 -- Use a newtype if the data constructor
252 -- (a) has exactly one value field
253 -- i.e. exactly one operation or superclass taken together
254 -- (b) that value is of lifted type (which they always are, because
255 -- we box equality superclasses)
256 -- See note [Class newtypes and equality predicates]
257
258 -- We treat the dictionary superclasses as ordinary arguments.
259 -- That means that in the case of
260 -- class C a => D a
261 -- we don't get a newtype with no arguments!
262 args = sc_sel_names ++ op_names
263 op_tys = [ty | (_,ty,_) <- sig_stuff]
264 op_names = [op | (op,_,_) <- sig_stuff]
265 arg_tys = sc_theta ++ op_tys
266 rec_tycon = classTyCon rec_clas
267
268 ; rep_nm <- newTyConRepName datacon_name
269 ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
270 datacon_name
271 False -- Not declared infix
272 rep_nm
273 (map (const no_bang) args)
274 (Just (map (const HsLazy) args))
275 [{- No fields -}]
276 tvs [{- no existentials -}]
277 [{- No GADT equalities -}]
278 [{- No theta -}]
279 arg_tys
280 (mkTyConApp rec_tycon (mkTyVarTys tvs))
281 rec_tycon
282
283 ; rhs <- if use_newtype
284 then mkNewTyConRhs tycon_name rec_tycon dict_con
285 else if isCTupleTyConName tycon_name
286 then return (TupleTyCon { data_con = dict_con
287 , tup_sort = ConstraintTuple })
288 else return (mkDataTyConRhs [dict_con])
289
290 ; let { tycon = mkClassTyCon tycon_name binders tvs roles
291 rhs rec_clas tc_isrec tc_rep_name
292 -- A class can be recursive, and in the case of newtypes
293 -- this matters. For example
294 -- class C a where { op :: C b => a -> b -> Int }
295 -- Because C has only one operation, it is represented by
296 -- a newtype, and it should be a *recursive* newtype.
297 -- [If we don't make it a recursive newtype, we'll expand the
298 -- newtype like a synonym, but that will lead to an infinite
299 -- type]
300
301 ; result = mkClass tvs fds
302 sc_theta sc_sel_ids at_items
303 op_items mindef tycon
304 }
305 ; traceIf (text "buildClass" <+> ppr tycon)
306 ; return result }
307 where
308 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
309
310 mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
311 mk_op_item rec_clas (op_name, _, dm_spec)
312 = do { dm_info <- case dm_spec of
313 Nothing -> return Nothing
314 Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
315 ; return (Just (dm_name, spec)) }
316 ; return (mkDictSelId op_name rec_clas, dm_info) }
317
318 {-
319 Note [Class newtypes and equality predicates]
320 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
321 Consider
322 class (a ~ F b) => C a b where
323 op :: a -> b
324
325 We cannot represent this by a newtype, even though it's not
326 existential, because there are two value fields (the equality
327 predicate and op. See Trac #2238
328
329 Moreover,
330 class (a ~ F b) => C a b where {}
331 Here we can't use a newtype either, even though there is only
332 one field, because equality predicates are unboxed, and classes
333 are boxed.
334 -}
335
336 newImplicitBinder :: Name -- Base name
337 -> (OccName -> OccName) -- Occurrence name modifier
338 -> TcRnIf m n Name -- Implicit name
339 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
340 -- For source type/class decls, this is the first occurrence
341 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
342 newImplicitBinder base_name mk_sys_occ
343 | Just mod <- nameModule_maybe base_name
344 = newGlobalBinder mod occ loc
345 | otherwise -- When typechecking a [d| decl bracket |],
346 -- TH generates types, classes etc with Internal names,
347 -- so we follow suit for the implicit binders
348 = do { uniq <- newUnique
349 ; return (mkInternalName uniq occ loc) }
350 where
351 occ = mk_sys_occ (nameOccName base_name)
352 loc = nameSrcSpan base_name
353
354 -- | Make the 'TyConRepName' for this 'TyCon'
355 newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
356 newTyConRepName tc_name
357 | Just mod <- nameModule_maybe tc_name
358 , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
359 = newGlobalBinder mod occ noSrcSpan
360 | otherwise
361 = newImplicitBinder tc_name mkTyConRepOcc