Fix #10182 by disallowing/avoiding self {-# SOURCE #-} imports
[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 buildSynonymTyCon,
10 buildFamilyTyCon,
11 buildAlgTyCon,
12 buildDataCon,
13 buildPatSyn,
14 TcMethInfo, buildClass,
15 distinctAbstractTyConRhs, totallyAbstractTyConRhs,
16 mkNewTyConRhs, mkDataTyConRhs,
17 newImplicitBinder
18 ) where
19
20 #include "HsVersions.h"
21
22 import IfaceEnv
23 import FamInstEnv( FamInstEnvs )
24 import DataCon
25 import PatSyn
26 import Var
27 import VarSet
28 import BasicTypes
29 import Name
30 import MkId
31 import Class
32 import TyCon
33 import Type
34 import Id
35 import Coercion
36 import TcType
37
38 import DynFlags
39 import TcRnMonad
40 import UniqSupply
41 import Util
42 import Outputable
43
44 ------------------------------------------------------
45 buildSynonymTyCon :: Name -> [TyVar] -> [Role]
46 -> Type
47 -> Kind -- ^ Kind of the RHS
48 -> TcRnIf m n TyCon
49 buildSynonymTyCon tc_name tvs roles rhs rhs_kind
50 = return (mkSynonymTyCon tc_name kind tvs roles rhs)
51 where kind = mkPiKinds tvs rhs_kind
52
53
54 buildFamilyTyCon :: Name -> [TyVar]
55 -> FamTyConFlav
56 -> Kind -- ^ Kind of the RHS
57 -> TyConParent
58 -> TcRnIf m n TyCon
59 buildFamilyTyCon tc_name tvs rhs rhs_kind parent
60 = return (mkFamilyTyCon tc_name kind tvs rhs parent)
61 where kind = mkPiKinds tvs rhs_kind
62
63
64 ------------------------------------------------------
65 distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
66 distinctAbstractTyConRhs = AbstractTyCon True
67 totallyAbstractTyConRhs = AbstractTyCon False
68
69 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
70 mkDataTyConRhs cons
71 = DataTyCon {
72 data_cons = cons,
73 is_enum = not (null cons) && all is_enum_con cons
74 -- See Note [Enumeration types] in TyCon
75 }
76 where
77 is_enum_con con
78 | (_tvs, theta, arg_tys, _res) <- dataConSig con
79 = null theta && null arg_tys
80
81
82 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
83 -- ^ Monadic because it makes a Name for the coercion TyCon
84 -- We pass the Name of the parent TyCon, as well as the TyCon itself,
85 -- because the latter is part of a knot, whereas the former is not.
86 mkNewTyConRhs tycon_name tycon con
87 = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
88 ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs
89 ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
90 ; return (NewTyCon { data_con = con,
91 nt_rhs = rhs_ty,
92 nt_etad_rhs = (etad_tvs, etad_rhs),
93 nt_co = co_tycon } ) }
94 -- Coreview looks through newtypes with a Nothing
95 -- for nt_co, or uses explicit coercions otherwise
96 where
97 tvs = tyConTyVars tycon
98 roles = tyConRoles tycon
99 inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
100 rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
101 -- Instantiate the data con with the
102 -- type variables from the tycon
103 -- NB: a newtype DataCon has a type that must look like
104 -- forall tvs. <arg-ty> -> T tvs
105 -- Note that we *can't* use dataConInstOrigArgTys here because
106 -- the newtype arising from class Foo a => Bar a where {}
107 -- has a single argument (Foo a) that is a *type class*, so
108 -- dataConInstOrigArgTys returns [].
109
110 etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
111 etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
112 etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
113 (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
114
115 eta_reduce :: [TyVar] -- Reversed
116 -> [Role] -- also reversed
117 -> Type -- Rhs type
118 -> ([TyVar], [Role], Type) -- Eta-reduced version
119 -- (tyvars in normal order)
120 eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
121 Just tv <- getTyVar_maybe arg,
122 tv == a,
123 not (a `elemVarSet` tyVarsOfType fun)
124 = eta_reduce as rs fun
125 eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
126
127
128 ------------------------------------------------------
129 buildDataCon :: FamInstEnvs
130 -> Name -> Bool
131 -> [HsBang]
132 -> [Name] -- Field labels
133 -> [TyVar] -> [TyVar] -- Univ and ext
134 -> [(TyVar,Type)] -- Equality spec
135 -> ThetaType -- Does not include the "stupid theta"
136 -- or the GADT equalities
137 -> [Type] -> Type -- Argument and result types
138 -> TyCon -- Rep tycon
139 -> TcRnIf m n DataCon
140 -- A wrapper for DataCon.mkDataCon that
141 -- a) makes the worker Id
142 -- b) makes the wrapper Id if necessary, including
143 -- allocating its unique (hence monadic)
144 buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
145 univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
146 = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
147 ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
148 -- This last one takes the name of the data constructor in the source
149 -- code, which (for Haskell source anyway) will be in the DataName name
150 -- space, and puts it into the VarName name space
151
152 ; us <- newUniqueSupply
153 ; dflags <- getDynFlags
154 ; let
155 stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
156 data_con = mkDataCon src_name declared_infix
157 arg_stricts field_lbls
158 univ_tvs ex_tvs eq_spec ctxt
159 arg_tys res_ty rep_tycon
160 stupid_ctxt dc_wrk dc_rep
161 dc_wrk = mkDataConWorkId work_name data_con
162 dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
163
164 ; return data_con }
165
166
167 -- The stupid context for a data constructor should be limited to
168 -- the type variables mentioned in the arg_tys
169 -- ToDo: Or functionally dependent on?
170 -- This whole stupid theta thing is, well, stupid.
171 mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
172 mkDataConStupidTheta tycon arg_tys univ_tvs
173 | null stupid_theta = [] -- The common case
174 | otherwise = filter in_arg_tys stupid_theta
175 where
176 tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
177 stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
178 -- Start by instantiating the master copy of the
179 -- stupid theta, taken from the TyCon
180
181 arg_tyvars = tyVarsOfTypes arg_tys
182 in_arg_tys pred = not $ isEmptyVarSet $
183 tyVarsOfType pred `intersectVarSet` arg_tyvars
184
185
186 ------------------------------------------------------
187 buildPatSyn :: Name -> Bool
188 -> (Id,Bool) -> Maybe (Id, Bool)
189 -> ([TyVar], ThetaType) -- ^ Univ and req
190 -> ([TyVar], ThetaType) -- ^ Ex and prov
191 -> [Type] -- ^ Argument types
192 -> Type -- ^ Result type
193 -> PatSyn
194 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
195 (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty
196 = ASSERT((and [ univ_tvs == univ_tvs'
197 , ex_tvs == ex_tvs'
198 , pat_ty `eqType` pat_ty'
199 , prov_theta `eqTypes` prov_theta'
200 , req_theta `eqTypes` req_theta'
201 , arg_tys `eqTypes` arg_tys'
202 ]))
203 mkPatSyn src_name declared_infix
204 (univ_tvs, req_theta) (ex_tvs, prov_theta)
205 arg_tys pat_ty
206 matcher builder
207 where
208 ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
209 ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
210 (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
211 (arg_tys', _) = tcSplitFunTys cont_tau
212
213 -- ------------------------------------------------------
214
215 type TcMethInfo = (Name, DefMethSpec, Type)
216 -- A temporary intermediate, to communicate between
217 -- tcClassSigs and buildClass.
218
219 buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
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 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 -- The class name is the 'parent' for this datacon, not its tycon,
233 -- because one should import the class to get the binding for
234 -- the datacon
235
236
237 ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
238 -- Build the selector id and default method id
239
240 -- Make selectors for the superclasses
241 ; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
242 (takeList sc_theta [fIRST_TAG..])
243 ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
244 | sc_name <- sc_sel_names]
245 -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
246 -- can construct names for the selectors. Thus
247 -- class (C a, C b) => D a b where ...
248 -- gives superclass selectors
249 -- D_sc1, D_sc2
250 -- (We used to call them D_C, but now we can have two different
251 -- superclasses both called C!)
252
253 ; let use_newtype = isSingleton arg_tys
254 -- Use a newtype if the data constructor
255 -- (a) has exactly one value field
256 -- i.e. exactly one operation or superclass taken together
257 -- (b) that value is of lifted type (which they always are, because
258 -- we box equality superclasses)
259 -- See note [Class newtypes and equality predicates]
260
261 -- We treat the dictionary superclasses as ordinary arguments.
262 -- That means that in the case of
263 -- class C a => D a
264 -- we don't get a newtype with no arguments!
265 args = sc_sel_names ++ op_names
266 op_tys = [ty | (_,_,ty) <- sig_stuff]
267 op_names = [op | (op,_,_) <- sig_stuff]
268 arg_tys = sc_theta ++ op_tys
269 rec_tycon = classTyCon rec_clas
270
271 ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
272 datacon_name
273 False -- Not declared infix
274 (map (const HsNoBang) 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 return (mkDataTyConRhs [dict_con])
286
287 ; let { clas_kind = mkPiKinds tvs constraintKind
288
289 ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
290 rhs rec_clas tc_isrec
291 -- A class can be recursive, and in the case of newtypes
292 -- this matters. For example
293 -- class C a where { op :: C b => a -> b -> Int }
294 -- Because C has only one operation, it is represented by
295 -- a newtype, and it should be a *recursive* newtype.
296 -- [If we don't make it a recursive newtype, we'll expand the
297 -- newtype like a synonym, but that will lead to an infinite
298 -- type]
299
300 ; result = mkClass tvs fds
301 sc_theta sc_sel_ids at_items
302 op_items mindef tycon
303 }
304 ; traceIf (text "buildClass" <+> ppr tycon)
305 ; return result }
306 where
307 mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
308 mk_op_item rec_clas (op_name, dm_spec, _)
309 = do { dm_info <- case dm_spec of
310 NoDM -> return NoDefMeth
311 GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
312 ; return (GenDefMeth dm_name) }
313 VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
314 ; return (DefMeth dm_name) }
315 ; return (mkDictSelId op_name rec_clas, dm_info) }
316
317 {-
318 Note [Class newtypes and equality predicates]
319 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
320 Consider
321 class (a ~ F b) => C a b where
322 op :: a -> b
323
324 We cannot represent this by a newtype, even though it's not
325 existential, because there are two value fields (the equality
326 predicate and op. See Trac #2238
327
328 Moreover,
329 class (a ~ F b) => C a b where {}
330 Here we can't use a newtype either, even though there is only
331 one field, because equality predicates are unboxed, and classes
332 are boxed.
333 -}