Update Trac ticket URLs to point to GitLab
[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, MethInfo, buildClass,
12 mkNewTyConRhs,
13 newImplicitBinder, newTyConRepName
14 ) where
15
16 #include "HsVersions.h"
17
18 import GhcPrelude
19
20 import IfaceEnv
21 import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
22 import TysWiredIn( isCTupleTyConName )
23 import TysPrim ( voidPrimTy )
24 import DataCon
25 import PatSyn
26 import Var
27 import VarSet
28 import BasicTypes
29 import Name
30 import NameEnv
31 import MkId
32 import Class
33 import TyCon
34 import Type
35 import Id
36 import TcType
37
38 import SrcLoc( SrcSpan, noSrcSpan )
39 import DynFlags
40 import TcRnMonad
41 import UniqSupply
42 import Util
43 import Outputable
44
45
46 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
47 -- ^ Monadic because it makes a Name for the coercion TyCon
48 -- We pass the Name of the parent TyCon, as well as the TyCon itself,
49 -- because the latter is part of a knot, whereas the former is not.
50 mkNewTyConRhs tycon_name tycon con
51 = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
52 ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
53 ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
54 ; return (NewTyCon { data_con = con,
55 nt_rhs = rhs_ty,
56 nt_etad_rhs = (etad_tvs, etad_rhs),
57 nt_co = nt_ax } ) }
58 -- Coreview looks through newtypes with a Nothing
59 -- for nt_co, or uses explicit coercions otherwise
60 where
61 tvs = tyConTyVars tycon
62 roles = tyConRoles tycon
63 con_arg_ty = case dataConRepArgTys con of
64 [arg_ty] -> arg_ty
65 tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
66 rhs_ty = substTyWith (dataConUnivTyVars con)
67 (mkTyVarTys tvs) con_arg_ty
68 -- Instantiate the newtype's RHS with the
69 -- type variables from the tycon
70 -- NB: a newtype DataCon has a type that must look like
71 -- forall tvs. <arg-ty> -> T tvs
72 -- Note that we *can't* use dataConInstOrigArgTys here because
73 -- the newtype arising from class Foo a => Bar a where {}
74 -- has a single argument (Foo a) that is a *type class*, so
75 -- dataConInstOrigArgTys returns [].
76
77 etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
78 etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
79 etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
80 (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
81
82 eta_reduce :: [TyVar] -- Reversed
83 -> [Role] -- also reversed
84 -> Type -- Rhs type
85 -> ([TyVar], [Role], Type) -- Eta-reduced version
86 -- (tyvars in normal order)
87 eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
88 Just tv <- getTyVar_maybe arg,
89 tv == a,
90 not (a `elemVarSet` tyCoVarsOfType fun)
91 = eta_reduce as rs fun
92 eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
93
94 ------------------------------------------------------
95 buildDataCon :: FamInstEnvs
96 -> Name
97 -> Bool -- Declared infix
98 -> TyConRepName
99 -> [HsSrcBang]
100 -> Maybe [HsImplBang]
101 -- See Note [Bangs on imported data constructors] in MkId
102 -> [FieldLabel] -- Field labels
103 -> [TyVar] -- Universals
104 -> [TyCoVar] -- Existentials
105 -> [TyVarBinder] -- User-written 'TyVarBinder's
106 -> [EqSpec] -- Equality spec
107 -> KnotTied ThetaType -- Does not include the "stupid theta"
108 -- or the GADT equalities
109 -> [KnotTied Type] -- Arguments
110 -> KnotTied Type -- Result types
111 -> KnotTied TyCon -- Rep tycon
112 -> NameEnv ConTag -- Maps the Name of each DataCon to its
113 -- ConTag
114 -> TcRnIf m n DataCon
115 -- A wrapper for DataCon.mkDataCon that
116 -- a) makes the worker Id
117 -- b) makes the wrapper Id if necessary, including
118 -- allocating its unique (hence monadic)
119 buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
120 field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
121 rep_tycon tag_map
122 = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
123 ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
124 -- This last one takes the name of the data constructor in the source
125 -- code, which (for Haskell source anyway) will be in the DataName name
126 -- space, and puts it into the VarName name space
127
128 ; traceIf (text "buildDataCon 1" <+> ppr src_name)
129 ; us <- newUniqueSupply
130 ; dflags <- getDynFlags
131 ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
132 tag = lookupNameEnv_NF tag_map src_name
133 -- See Note [Constructor tag allocation], fixes #14657
134 data_con = mkDataCon src_name declared_infix prom_info
135 src_bangs field_lbls
136 univ_tvs ex_tvs user_tvbs eq_spec ctxt
137 arg_tys res_ty NoRRI rep_tycon tag
138 stupid_ctxt dc_wrk dc_rep
139 dc_wrk = mkDataConWorkId work_name data_con
140 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
141 impl_bangs data_con)
142
143 ; traceIf (text "buildDataCon 2" <+> ppr src_name)
144 ; return data_con }
145
146
147 -- The stupid context for a data constructor should be limited to
148 -- the type variables mentioned in the arg_tys
149 -- ToDo: Or functionally dependent on?
150 -- This whole stupid theta thing is, well, stupid.
151 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
152 mkDataConStupidTheta tycon arg_tys univ_tvs
153 | null stupid_theta = [] -- The common case
154 | otherwise = filter in_arg_tys stupid_theta
155 where
156 tc_subst = zipTvSubst (tyConTyVars tycon)
157 (mkTyVarTys univ_tvs)
158 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
159 -- Start by instantiating the master copy of the
160 -- stupid theta, taken from the TyCon
161
162 arg_tyvars = tyCoVarsOfTypes arg_tys
163 in_arg_tys pred = not $ isEmptyVarSet $
164 tyCoVarsOfType pred `intersectVarSet` arg_tyvars
165
166
167 ------------------------------------------------------
168 buildPatSyn :: Name -> Bool
169 -> (Id,Bool) -> Maybe (Id, Bool)
170 -> ([TyVarBinder], ThetaType) -- ^ Univ and req
171 -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
172 -> [Type] -- ^ Argument types
173 -> Type -- ^ Result type
174 -> [FieldLabel] -- ^ Field labels for
175 -- a record pattern synonym
176 -> PatSyn
177 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
178 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
179 pat_ty field_labels
180 = -- The assertion checks that the matcher is
181 -- compatible with the pattern synonym
182 ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
183 , ex_tvs `equalLength` ex_tvs1
184 , pat_ty `eqType` substTy subst pat_ty1
185 , prov_theta `eqTypes` substTys subst prov_theta1
186 , req_theta `eqTypes` substTys subst req_theta1
187 , compareArgTys arg_tys (substTys subst arg_tys1)
188 ])
189 , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
190 , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
191 , ppr pat_ty <+> twiddle <+> ppr pat_ty1
192 , ppr prov_theta <+> twiddle <+> ppr prov_theta1
193 , ppr req_theta <+> twiddle <+> ppr req_theta1
194 , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
195 mkPatSyn src_name declared_infix
196 (univ_tvs, req_theta) (ex_tvs, prov_theta)
197 arg_tys pat_ty
198 matcher builder field_labels
199 where
200 ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
201 ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
202 (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
203 (arg_tys1, _) = (tcSplitFunTys cont_tau)
204 twiddle = char '~'
205 subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
206 (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
207
208 -- For a nullary pattern synonym we add a single void argument to the
209 -- matcher to preserve laziness in the case of unlifted types.
210 -- See #12746
211 compareArgTys :: [Type] -> [Type] -> Bool
212 compareArgTys [] [x] = x `eqType` voidPrimTy
213 compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
214
215
216 ------------------------------------------------------
217 type TcMethInfo = MethInfo -- this variant needs zonking
218 type MethInfo -- A temporary intermediate, to communicate
219 -- between tcClassSigs and buildClass.
220 = ( Name -- Name of the class op
221 , Type -- Type of the class op
222 , Maybe (DefMethSpec (SrcSpan, Type)))
223 -- Nothing => no default method
224 --
225 -- Just VanillaDM => There is an ordinary
226 -- polymorphic default method
227 --
228 -- Just (GenericDM (loc, ty)) => There is a generic default metho
229 -- Here is its type, and the location
230 -- of the type signature
231 -- We need that location /only/ to attach it to the
232 -- generic default method's Name; and we need /that/
233 -- only to give the right location of an ambiguity error
234 -- for the generic default method, spat out by checkValidClass
235
236 buildClass :: Name -- Name of the class/tycon (they have the same Name)
237 -> [TyConBinder] -- Of the tycon
238 -> [Role]
239 -> [FunDep TyVar] -- Functional dependencies
240 -- Super classes, associated types, method info, minimal complete def.
241 -- This is Nothing if the class is abstract.
242 -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
243 -> TcRnIf m n Class
244
245 buildClass tycon_name binders roles fds Nothing
246 = fixM $ \ rec_clas -> -- Only name generation inside loop
247 do { traceIf (text "buildClass")
248
249 ; tc_rep_name <- newTyConRepName tycon_name
250 ; let univ_tvs = binderVars binders
251 tycon = mkClassTyCon tycon_name binders roles
252 AbstractTyCon rec_clas tc_rep_name
253 result = mkAbstractClass tycon_name univ_tvs fds tycon
254 ; traceIf (text "buildClass" <+> ppr tycon)
255 ; return result }
256
257 buildClass tycon_name binders roles fds
258 (Just (sc_theta, at_items, sig_stuff, mindef))
259 = fixM $ \ rec_clas -> -- Only name generation inside loop
260 do { traceIf (text "buildClass")
261
262 ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
263 ; tc_rep_name <- newTyConRepName tycon_name
264
265 ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
266 -- Build the selector id and default method id
267
268 -- Make selectors for the superclasses
269 ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
270 (takeList sc_theta [fIRST_TAG..])
271 ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
272 | sc_name <- sc_sel_names]
273 -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
274 -- can construct names for the selectors. Thus
275 -- class (C a, C b) => D a b where ...
276 -- gives superclass selectors
277 -- D_sc1, D_sc2
278 -- (We used to call them D_C, but now we can have two different
279 -- superclasses both called C!)
280
281 ; let use_newtype = isSingleton arg_tys
282 -- Use a newtype if the data constructor
283 -- (a) has exactly one value field
284 -- i.e. exactly one operation or superclass taken together
285 -- (b) that value is of lifted type (which they always are, because
286 -- we box equality superclasses)
287 -- See note [Class newtypes and equality predicates]
288
289 -- We treat the dictionary superclasses as ordinary arguments.
290 -- That means that in the case of
291 -- class C a => D a
292 -- we don't get a newtype with no arguments!
293 args = sc_sel_names ++ op_names
294 op_tys = [ty | (_,ty,_) <- sig_stuff]
295 op_names = [op | (op,_,_) <- sig_stuff]
296 arg_tys = sc_theta ++ op_tys
297 rec_tycon = classTyCon rec_clas
298 univ_bndrs = tyConTyVarBinders binders
299 univ_tvs = binderVars univ_bndrs
300
301 ; rep_nm <- newTyConRepName datacon_name
302 ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
303 datacon_name
304 False -- Not declared infix
305 rep_nm
306 (map (const no_bang) args)
307 (Just (map (const HsLazy) args))
308 [{- No fields -}]
309 univ_tvs
310 [{- no existentials -}]
311 univ_bndrs
312 [{- No GADT equalities -}]
313 [{- No theta -}]
314 arg_tys
315 (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
316 rec_tycon
317 (mkTyConTagMap rec_tycon)
318
319 ; rhs <- case () of
320 _ | use_newtype
321 -> mkNewTyConRhs tycon_name rec_tycon dict_con
322 | isCTupleTyConName tycon_name
323 -> return (TupleTyCon { data_con = dict_con
324 , tup_sort = ConstraintTuple })
325 | otherwise
326 -> return (mkDataTyConRhs [dict_con])
327
328 ; let { tycon = mkClassTyCon tycon_name binders roles
329 rhs rec_clas tc_rep_name
330 -- A class can be recursive, and in the case of newtypes
331 -- this matters. For example
332 -- class C a where { op :: C b => a -> b -> Int }
333 -- Because C has only one operation, it is represented by
334 -- a newtype, and it should be a *recursive* newtype.
335 -- [If we don't make it a recursive newtype, we'll expand the
336 -- newtype like a synonym, but that will lead to an infinite
337 -- type]
338
339 ; result = mkClass tycon_name univ_tvs fds
340 sc_theta sc_sel_ids at_items
341 op_items mindef tycon
342 }
343 ; traceIf (text "buildClass" <+> ppr tycon)
344 ; return result }
345 where
346 no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
347
348 mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
349 mk_op_item rec_clas (op_name, _, dm_spec)
350 = do { dm_info <- mk_dm_info op_name dm_spec
351 ; return (mkDictSelId op_name rec_clas, dm_info) }
352
353 mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
354 -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
355 mk_dm_info _ Nothing
356 = return Nothing
357 mk_dm_info op_name (Just VanillaDM)
358 = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
359 ; return (Just (dm_name, VanillaDM)) }
360 mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
361 = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
362 ; return (Just (dm_name, GenericDM dm_ty)) }
363
364 {-
365 Note [Class newtypes and equality predicates]
366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
367 Consider
368 class (a ~ F b) => C a b where
369 op :: a -> b
370
371 We cannot represent this by a newtype, even though it's not
372 existential, because there are two value fields (the equality
373 predicate and op. See #2238
374
375 Moreover,
376 class (a ~ F b) => C a b where {}
377 Here we can't use a newtype either, even though there is only
378 one field, because equality predicates are unboxed, and classes
379 are boxed.
380 -}
381
382 newImplicitBinder :: Name -- Base name
383 -> (OccName -> OccName) -- Occurrence name modifier
384 -> TcRnIf m n Name -- Implicit name
385 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
386 -- For source type/class decls, this is the first occurrence
387 -- For iface ones, the LoadIface has already allocated a suitable name in the cache
388 newImplicitBinder base_name mk_sys_occ
389 = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
390
391 newImplicitBinderLoc :: Name -- Base name
392 -> (OccName -> OccName) -- Occurrence name modifier
393 -> SrcSpan
394 -> TcRnIf m n Name -- Implicit name
395 -- Just the same, but lets you specify the SrcSpan
396 newImplicitBinderLoc base_name mk_sys_occ loc
397 | Just mod <- nameModule_maybe base_name
398 = newGlobalBinder mod occ loc
399 | otherwise -- When typechecking a [d| decl bracket |],
400 -- TH generates types, classes etc with Internal names,
401 -- so we follow suit for the implicit binders
402 = do { uniq <- newUnique
403 ; return (mkInternalName uniq occ loc) }
404 where
405 occ = mk_sys_occ (nameOccName base_name)
406
407 -- | Make the 'TyConRepName' for this 'TyCon'
408 newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
409 newTyConRepName tc_name
410 | Just mod <- nameModule_maybe tc_name
411 , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
412 = newGlobalBinder mod occ noSrcSpan
413 | otherwise
414 = newImplicitBinder tc_name mkTyConRepOcc