Re-add FunTy (big patch)
[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 TyCoRep( TyBinder(..), TyVarBinder(..) )
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 = piResultTys (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] -> [TyBinder] -- Universals
116 -> [TyVarBinder] -- 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 TyVarBinders. See mkDataConUnivTyBinders
128 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
129 univ_tvs univ_bndrs ex_tvs 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 dc_bndrs = mkDataConUnivTyVarBinders univ_tvs univ_bndrs
140 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
141 data_con = mkDataCon src_name declared_infix prom_info
142 src_bangs field_lbls
143 dc_bndrs ex_tvs eq_spec ctxt
144 arg_tys res_ty NoRRI rep_tycon
145 stupid_ctxt dc_wrk dc_rep
146 dc_wrk = mkDataConWorkId work_name data_con
147 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
148 impl_bangs data_con)
149
150 ; traceIf (text "buildDataCon 2" <+> ppr src_name)
151 ; return data_con }
152
153
154 -- The stupid context for a data constructor should be limited to
155 -- the type variables mentioned in the arg_tys
156 -- ToDo: Or functionally dependent on?
157 -- This whole stupid theta thing is, well, stupid.
158 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
159 mkDataConStupidTheta tycon arg_tys univ_tvs
160 | null stupid_theta = [] -- The common case
161 | otherwise = filter in_arg_tys stupid_theta
162 where
163 tc_subst = zipTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
164 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
165 -- Start by instantiating the master copy of the
166 -- stupid theta, taken from the TyCon
167
168 arg_tyvars = tyCoVarsOfTypes arg_tys
169 in_arg_tys pred = not $ isEmptyVarSet $
170 tyCoVarsOfType pred `intersectVarSet` arg_tyvars
171
172
173 mkDataConUnivTyVarBinders :: [TyVar] -> [TyBinder] -- From the TyCon
174 -> [TyVarBinder] -- For the DataCon
175 -- See Note [Building the TyBinders for a DataCon]
176 mkDataConUnivTyVarBinders tvs bndrs
177 = zipWith mk_binder tvs bndrs
178 where
179 mk_binder tv bndr = mkTyVarBinder vis tv
180 where
181 vis = case bndr of
182 Anon _ -> Specified
183 Named (TvBndr _ Visible) -> Specified
184 Named (TvBndr _ vis) -> vis
185
186 {- Note [Building the TyBinders for a DataCon]
187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
188 A DataCon needs to keep track of the visibility of its universals and
189 existentials, so that visible type application can work properly. This
190 is done by storing the universal and existential TyVarBinders.
191 See Note [TyVarBinders in DataCons] in DataCon.
192
193 During construction of a DataCon, we often start from the TyBinders of
194 the parent TyCon. For example
195 data Maybe a = Nothing | Just a
196 The DataCons start from the TyBinders of the parent TyCon.
197
198 But the ultimate TyBinders for the DataCon are *different* than those
199 of the DataCon. Here is an example:
200
201 data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
202
203 The TyCon has
204
205 tyConTyVars = [ k:*, a:k->*, b:k]
206 tyConTyBinders = [ Named (TvBndr (k :: *) Invisible), Anon (k->*), Anon k ]
207
208 The TyBinders for App line up with App's kind, given above.
209
210 But the DataCon MkApp has the type
211 MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
212
213 That is, its TyBinders should be
214
215 dataConUnivTyVarBinders = [ TvBndr (k:*) Invisible
216 , TvBndr (a:k->*) Specified
217 , TvBndr (b:k) Specified ]
218
219 So we want to take the TyCon's TyBinders and the TyCon's TyVars and
220 merge them, pulling
221 - variable names from the TyVars
222 - visibilities from the TyBinders
223 - but changing Anon/Visible to Specified
224
225 The last part about Visible->Specified comes from this:
226 data T k (a:k) b = MkT (a b)
227 Here k is Visible in T's kind, but we don't have Visible binders in
228 the TyBinders for a term (see Note [No Visible TyBinder in terms]
229 in TyCoRep), so we change it to Specified when making MkT's TyBinders
230
231 This merging operation is done by mkDataConUnivTyBinders. In contrast,
232 the TyBinders passed to mkDataCon are the final TyBinders stored in the
233 DataCon (mkDataCon does no further work).
234 -}
235
236 ------------------------------------------------------
237 buildPatSyn :: Name -> Bool
238 -> (Id,Bool) -> Maybe (Id, Bool)
239 -> ([TyVarBinder], ThetaType) -- ^ Univ and req
240 -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
241 -> [Type] -- ^ Argument types
242 -> Type -- ^ Result type
243 -> [FieldLabel] -- ^ Field labels for
244 -- a record pattern synonym
245 -> PatSyn
246 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
247 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
248 pat_ty field_labels
249 = -- The assertion checks that the matcher is
250 -- compatible with the pattern synonym
251 ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
252 , ex_tvs `equalLength` ex_tvs1
253 , pat_ty `eqType` substTy subst pat_ty1
254 , prov_theta `eqTypes` substTys subst prov_theta1
255 , req_theta `eqTypes` substTys subst req_theta1
256 , arg_tys `eqTypes` substTys subst arg_tys1
257 ])
258 , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
259 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
260 , ppr pat_ty <+> twiddle <+> ppr pat_ty1
261 , ppr prov_theta <+> twiddle <+> ppr prov_theta1
262 , ppr req_theta <+> twiddle <+> ppr req_theta1
263 , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
264 mkPatSyn src_name declared_infix
265 (univ_tvs, req_theta) (ex_tvs, prov_theta)
266 arg_tys pat_ty
267 matcher builder field_labels
268 where
269 ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
270 ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
271 (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
272 (arg_tys1, _) = tcSplitFunTys cont_tau
273 twiddle = char '~'
274 subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
275 (mkTyVarTys (map binderVar (univ_tvs ++ ex_tvs)))
276
277 ------------------------------------------------------
278 type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
279 -- A temporary intermediate, to communicate between
280 -- tcClassSigs and buildClass.
281
282 buildClass :: Name -- Name of the class/tycon (they have the same Name)
283 -> [TyVar] -> [Role] -> ThetaType
284 -> [TyBinder] -- of the tycon
285 -> [FunDep TyVar] -- Functional dependencies
286 -> [ClassATItem] -- Associated types
287 -> [TcMethInfo] -- Method info
288 -> ClassMinimalDef -- Minimal complete definition
289 -> RecFlag -- Info for type constructor
290 -> TcRnIf m n Class
291
292 buildClass tycon_name tvs roles sc_theta binders
293 fds at_items sig_stuff mindef tc_isrec
294 = fixM $ \ rec_clas -> -- Only name generation inside loop
295 do { traceIf (text "buildClass")
296
297 ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
298 ; tc_rep_name <- newTyConRepName tycon_name
299
300 ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
301 -- Build the selector id and default method id
302
303 -- Make selectors for the superclasses
304 ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
305 (takeList sc_theta [fIRST_TAG..])
306 ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
307 | sc_name <- sc_sel_names]
308 -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
309 -- can construct names for the selectors. Thus
310 -- class (C a, C b) => D a b where ...
311 -- gives superclass selectors
312 -- D_sc1, D_sc2
313 -- (We used to call them D_C, but now we can have two different
314 -- superclasses both called C!)
315
316 ; let use_newtype = isSingleton arg_tys
317 -- Use a newtype if the data constructor
318 -- (a) has exactly one value field
319 -- i.e. exactly one operation or superclass taken together
320 -- (b) that value is of lifted type (which they always are, because
321 -- we box equality superclasses)
322 -- See note [Class newtypes and equality predicates]
323
324 -- We treat the dictionary superclasses as ordinary arguments.
325 -- That means that in the case of
326 -- class C a => D a
327 -- we don't get a newtype with no arguments!
328 args = sc_sel_names ++ op_names
329 op_tys = [ty | (_,ty,_) <- sig_stuff]
330 op_names = [op | (op,_,_) <- sig_stuff]
331 arg_tys = sc_theta ++ op_tys
332 rec_tycon = classTyCon rec_clas
333
334 ; rep_nm <- newTyConRepName datacon_name
335 ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
336 datacon_name
337 False -- Not declared infix
338 rep_nm
339 (map (const no_bang) args)
340 (Just (map (const HsLazy) args))
341 [{- No fields -}]
342 tvs binders
343 [{- no existentials -}]
344 [{- No GADT equalities -}]
345 [{- No theta -}]
346 arg_tys
347 (mkTyConApp rec_tycon (mkTyVarTys tvs))
348 rec_tycon
349
350 ; rhs <- if use_newtype
351 then mkNewTyConRhs tycon_name rec_tycon dict_con
352 else if isCTupleTyConName tycon_name
353 then return (TupleTyCon { data_con = dict_con
354 , tup_sort = ConstraintTuple })
355 else return (mkDataTyConRhs [dict_con])
356
357 ; let { tycon = mkClassTyCon tycon_name binders tvs roles
358 rhs rec_clas tc_isrec tc_rep_name
359 -- A class can be recursive, and in the case of newtypes
360 -- this matters. For example
361 -- class C a where { op :: C b => a -> b -> Int }
362 -- Because C has only one operation, it is represented by
363 -- a newtype, and it should be a *recursive* newtype.
364 -- [If we don't make it a recursive newtype, we'll expand the
365 -- newtype like a synonym, but that will lead to an infinite
366 -- type]
367
368 ; result = mkClass tvs fds
369 sc_theta sc_sel_ids at_items
370 op_items mindef tycon
371 }
372 ; traceIf (text "buildClass" <+> ppr tycon)
373 ; return result }
374 where
375 no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
376
377 mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
378 mk_op_item rec_clas (op_name, _, dm_spec)
379 = do { dm_info <- case dm_spec of
380 Nothing -> return Nothing
381 Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
382 ; return (Just (dm_name, spec)) }
383 ; return (mkDictSelId op_name rec_clas, dm_info) }
384
385 {-
386 Note [Class newtypes and equality predicates]
387 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
388 Consider
389 class (a ~ F b) => C a b where
390 op :: a -> b
391
392 We cannot represent this by a newtype, even though it's not
393 existential, because there are two value fields (the equality
394 predicate and op. See Trac #2238
395
396 Moreover,
397 class (a ~ F b) => C a b where {}
398 Here we can't use a newtype either, even though there is only
399 one field, because equality predicates are unboxed, and classes
400 are boxed.
401 -}
402
403 newImplicitBinder :: Name -- Base name
404 -> (OccName -> OccName) -- Occurrence name modifier
405 -> TcRnIf m n Name -- Implicit name
406 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
407 -- For source type/class decls, this is the first occurrence
408 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
409 newImplicitBinder base_name mk_sys_occ
410 | Just mod <- nameModule_maybe base_name
411 = newGlobalBinder mod occ loc
412 | otherwise -- When typechecking a [d| decl bracket |],
413 -- TH generates types, classes etc with Internal names,
414 -- so we follow suit for the implicit binders
415 = do { uniq <- newUnique
416 ; return (mkInternalName uniq occ loc) }
417 where
418 occ = mk_sys_occ (nameOccName base_name)
419 loc = nameSrcSpan base_name
420
421 -- | Make the 'TyConRepName' for this 'TyCon'
422 newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
423 newTyConRepName tc_name
424 | Just mod <- nameModule_maybe tc_name
425 , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
426 = newGlobalBinder mod occ noSrcSpan
427 | otherwise
428 = newImplicitBinder tc_name mkTyConRepOcc