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