876c9c008d817ab328d41821fae021a765fbe82a
[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 PrelNames( tyConRepModOcc )
23 import DataCon
24 import PatSyn
25 import Var
26 import VarSet
27 import BasicTypes
28 import Name
29 import MkId
30 import Class
31 import TyCon
32 import Type
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 = applyTys (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] -> [TyVar] -- Univ and ext
116 -> [EqSpec] -- Equality spec
117 -> ThetaType -- Does not include the "stupid theta"
118 -- or the GADT equalities
119 -> [Type] -> Type -- Argument and result types
120 -> TyCon -- Rep tycon
121 -> TcRnIf m n DataCon
122 -- A wrapper for DataCon.mkDataCon that
123 -- a) makes the worker Id
124 -- b) makes the wrapper Id if necessary, including
125 -- allocating its unique (hence monadic)
126 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
127 univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
128 = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
129 ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
130 -- This last one takes the name of the data constructor in the source
131 -- code, which (for Haskell source anyway) will be in the DataName name
132 -- space, and puts it into the VarName name space
133
134 ; traceIf (text "buildDataCon 1" <+> ppr src_name)
135 ; us <- newUniqueSupply
136 ; dflags <- getDynFlags
137 ; let
138 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
139 data_con = mkDataCon src_name declared_infix prom_info
140 src_bangs field_lbls
141 univ_tvs ex_tvs eq_spec ctxt
142 arg_tys res_ty rep_tycon
143 stupid_ctxt dc_wrk dc_rep
144 dc_wrk = mkDataConWorkId work_name data_con
145 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
146 impl_bangs data_con)
147
148 ; traceIf (text "buildDataCon 2" <+> ppr src_name)
149 ; return data_con }
150
151
152 -- The stupid context for a data constructor should be limited to
153 -- the type variables mentioned in the arg_tys
154 -- ToDo: Or functionally dependent on?
155 -- This whole stupid theta thing is, well, stupid.
156 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
157 mkDataConStupidTheta tycon arg_tys univ_tvs
158 | null stupid_theta = [] -- The common case
159 | otherwise = filter in_arg_tys stupid_theta
160 where
161 tc_subst = zipTopTCvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
162 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
163 -- Start by instantiating the master copy of the
164 -- stupid theta, taken from the TyCon
165
166 arg_tyvars = tyCoVarsOfTypes arg_tys
167 in_arg_tys pred = not $ isEmptyVarSet $
168 tyCoVarsOfType pred `intersectVarSet` arg_tyvars
169
170
171 ------------------------------------------------------
172 buildPatSyn :: Name -> Bool
173 -> (Id,Bool) -> Maybe (Id, Bool)
174 -> ([TyVar], ThetaType) -- ^ Univ and req
175 -> ([TyVar], ThetaType) -- ^ Ex and prov
176 -> [Type] -- ^ Argument types
177 -> Type -- ^ Result type
178 -> [FieldLabel] -- ^ Field labels for
179 -- a record pattern synonym
180 -> PatSyn
181 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
182 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
183 pat_ty field_labels
184 = -- The assertion checks that the matcher is
185 -- compatible with the pattern synonym
186 ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
187 , ex_tvs `equalLength` ex_tvs1
188 , pat_ty `eqType` substTy subst pat_ty1
189 , prov_theta `eqTypes` substTys subst prov_theta1
190 , req_theta `eqTypes` substTys subst req_theta1
191 , arg_tys `eqTypes` substTys subst arg_tys1
192 ])
193 , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
194 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
195 , ppr pat_ty <+> twiddle <+> ppr pat_ty1
196 , ppr prov_theta <+> twiddle <+> ppr prov_theta1
197 , ppr req_theta <+> twiddle <+> ppr req_theta1
198 , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
199 mkPatSyn src_name declared_infix
200 (univ_tvs, req_theta) (ex_tvs, prov_theta)
201 arg_tys pat_ty
202 matcher builder field_labels
203 where
204 ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
205 ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
206 (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
207 (arg_tys1, _) = tcSplitFunTys cont_tau
208 twiddle = char '~'
209 subst = zipTopTCvSubst (univ_tvs1 ++ ex_tvs1)
210 (mkTyVarTys (univ_tvs ++ ex_tvs))
211
212 ------------------------------------------------------
213 type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
214 -- A temporary intermediate, to communicate between
215 -- tcClassSigs and buildClass.
216
217 buildClass :: Name -- Name of the class/tycon (they have the same Name)
218 -> [TyVar] -> [Role] -> ThetaType
219 -> Kind
220 -> [FunDep TyVar] -- Functional dependencies
221 -> [ClassATItem] -- Associated types
222 -> [TcMethInfo] -- Method info
223 -> ClassMinimalDef -- Minimal complete definition
224 -> RecFlag -- Info for type constructor
225 -> TcRnIf m n Class
226
227 buildClass tycon_name tvs roles sc_theta kind 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 kind 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 mkTyConRepUserOcc