2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[TcTyClsDecls]{Typecheck type and class declarations}
7 #include "HsVersions.h"
15 import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
16 ClassDecl(..), MonoType(..), PolyType(..),
17 Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
18 import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) )
19 import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
22 import Inst ( InstanceMapper(..) )
23 import TcClassDcl ( tcClassDecl1 )
24 import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
26 tcTyVarScope, tcGetEnv )
27 import TcKind ( TcKind, newKindVars )
28 import TcTyDecls ( tcTyDecl, tcRecordSelectors )
31 import Class ( Class(..), getClassSelIds )
32 import Digraph ( findSCCs, SCC(..) )
33 import Name ( Name, isTyConName )
36 import UniqSet ( UniqSet(..), emptyUniqSet,
37 unitUniqSet, unionUniqSets,
38 unionManyUniqSets, uniqSetToList )
39 import SrcLoc ( SrcLoc )
40 import TyCon ( TyCon, tyConDataCons )
41 import Unique ( Unique )
42 import Util ( panic, pprTrace )
49 data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
51 tcTyAndClassDecls1 :: InstanceMapper
52 -> Bag RenamedTyDecl -> Bag RenamedClassDecl
53 -> TcM s (TcEnv s, TcHsBinds s)
55 tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
56 = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
57 tcGroups inst_mapper groups
59 cls_decls = mapBag ClD rncls_decls
60 ty_decls = mapBag TyD rnty_decls
61 syn_decls = filterBag is_syn_decl ty_decls
62 decls = ty_decls `unionBags` cls_decls
64 is_syn_decl (TyD (TySynonym _ _ _ _)) = True
67 tcGroups inst_mapper []
68 = tcGetEnv `thenNF_Tc` \ env ->
69 returnTc (env, EmptyBinds)
71 tcGroups inst_mapper (group:groups)
72 = tcGroup inst_mapper group `thenTc` \ (new_env, binds1) ->
74 -- Extend the environment using the new tycons and classes
77 -- Do the remaining groups
78 tcGroups inst_mapper groups `thenTc` \ (final_env, binds2) ->
80 returnTc (final_env, binds1 `ThenBinds` binds2)
86 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s)
87 tcGroup inst_mapper decls
88 = pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
91 fixTc ( \ ~(tycons,classes,_) ->
93 -- EXTEND TYPE AND CLASS ENVIRONMENTS
94 -- including their data constructors and class operations
95 -- NB: it's important that the tycons and classes come back in just
96 -- the same order from this fix as from get_binders, so that these
97 -- extend-env things work properly. A bit UGH-ish.
98 tcExtendTyConEnv tycon_names_w_arities tycons $
99 tcExtendClassEnv class_names classes $
101 -- DEAL WITH TYPE VARIABLES
102 tcTyVarScope tyvar_names ( \ tyvars ->
104 -- DEAL WITH THE DEFINITIONS THEMSELVES
105 foldBag combine (tcDecl inst_mapper)
106 (returnTc (emptyBag, emptyBag))
108 ) `thenTc` \ (tycon_bag,class_bag) ->
110 tycons = bagToList tycon_bag
111 classes = bagToList class_bag
114 -- SNAFFLE ENV TO RETURN
115 tcGetEnv `thenNF_Tc` \ final_env ->
117 returnTc (tycons, classes, final_env)
118 ) `thenTc` \ (tycons, classes, final_env) ->
121 -- Create any necessary record selector Ids and their bindings
122 mapAndUnzipTc tcRecordSelectors tycons `thenTc` \ (sel_ids_s, binds) ->
124 -- Extend the global value environment with
126 -- b) record selectors
127 -- c) class op selectors
130 tcExtendGlobalValEnv (concat (map tyConDataCons tycons)) $
131 tcExtendGlobalValEnv (concat sel_ids_s) $
132 tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
133 tcGetEnv `thenNF_Tc` \ really_final_env ->
135 returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
138 (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
141 = do_a `thenTc` \ (a1,a2) ->
142 do_b `thenTc` \ (b1,b2) ->
143 returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
146 Dealing with one decl
147 ~~~~~~~~~~~~~~~~~~~~~
149 tcDecl :: InstanceMapper
151 -> TcM s (Bag TyCon, Bag Class)
153 tcDecl inst_mapper (TyD decl)
154 = tcTyDecl decl `thenTc` \ tycon ->
155 returnTc (unitBag tycon, emptyBag)
157 tcDecl inst_mapper (ClD decl)
158 = tcClassDecl1 inst_mapper decl `thenTc` \ clas ->
159 returnTc (emptyBag, unitBag clas)
165 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
166 sortByDependency syn_decls cls_decls decls
167 = let -- CHECK FOR SYNONYM CYCLES
168 syn_sccs = findSCCs mk_edges syn_decls
169 syn_cycles = [map fmt_decl (bagToList decls)
170 | CyclicSCC decls <- syn_sccs]
173 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
175 let -- CHECK FOR CLASS CYCLES
176 cls_sccs = findSCCs mk_edges cls_decls
177 cls_cycles = [map fmt_decl (bagToList decls)
178 | CyclicSCC decls <- cls_sccs]
181 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
183 -- DO THE MAIN DEPENDENCY ANALYSIS
185 decl_sccs = findSCCs mk_edges decls
186 scc_bags = map bag_acyclic decl_sccs
191 bag_acyclic (AcyclicSCC scc) = unitBag scc
192 bag_acyclic (CyclicSCC sccs) = sccs
195 = (ppr PprForUser name, getSrcLoc name)
198 get_name (TyD (TyData _ name _ _ _ _ _)) = name
199 get_name (TyD (TyNew _ name _ _ _ _ _)) = name
200 get_name (TyD (TySynonym name _ _ _)) = name
201 get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
204 Edges in Type/Class decls
205 ~~~~~~~~~~~~~~~~~~~~~~~~~
207 mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
208 = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
209 mk_edges (TyD (TyNew ctxt name _ condecl _ _ _))
210 = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
211 mk_edges (TyD (TySynonym name _ rhs _))
212 = (getItsUnique name, set_to_bag (get_ty rhs))
213 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
214 = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
217 = unionManyUniqSets (map (set_name.fst) ctxt)
220 = unionManyUniqSets (map get_con cons)
222 get_con (ConDecl _ btys _)
223 = unionManyUniqSets (map get_bty btys)
224 get_con (ConOpDecl bty1 _ bty2 _)
225 = unionUniqSets (get_bty bty1) (get_bty bty2)
226 get_con (NewConDecl _ ty _)
228 get_con (RecConDecl _ nbtys _)
229 = unionManyUniqSets (map (get_bty.snd) nbtys)
231 get_bty (Banged ty) = get_ty ty
232 get_bty (Unbanged ty) = get_ty ty
234 get_ty (MonoTyVar tv)
236 get_ty (MonoTyApp name tys)
237 = (if isTyConName name then set_name name else emptyUniqSet)
238 `unionUniqSets` get_tys tys
239 get_ty (MonoFunTy ty1 ty2)
240 = unionUniqSets (get_ty ty1) (get_ty ty2)
241 get_ty (MonoListTy ty)
242 = get_ty ty -- careful when defining [] (,,) etc as
243 get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
245 get_ty other = panic "TcTyClsDecls:get_ty"
247 get_pty (HsForAllTy _ ctxt mty)
248 = get_ctxt ctxt `unionUniqSets` get_ty mty
249 get_pty other = panic "TcTyClsDecls:get_pty"
252 = unionManyUniqSets (map get_ty tys)
255 = unionManyUniqSets (map get_sig sigs)
257 get_sig (ClassOpSig _ ty _ _) = get_pty ty
258 get_sig other = panic "TcTyClsDecls:get_sig"
260 set_name name = unitUniqSet (getItsUnique name)
262 set_to_bag set = listToBag (uniqSetToList set)
268 Extract *binding* names from type and class decls. Type variables are
269 bound in type, data, newtype and class declarations and the polytypes
270 in the class op sigs.
272 Why do we need to grab all these type variables at once, including
273 those locally-quantified type variables in class op signatures?
274 Because we can only commit to the final kind of a type variable when
275 we've completed the mutually recursive group. For example:
278 op :: D b => a -> b -> b
281 bop :: (Monad c) => ...
283 Here, the kind of the locally-polymorphic type variable "b"
284 depends on *all the uses of class D*. For example, the use of
285 Monad c in bop's type signature means that D must have kind Type->Type.
289 get_binders :: Bag Decl
290 -> ([Name], -- TyVars; no dups
291 [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
292 [Name]) -- Classes; no dups
294 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
296 (tyvars, tycons, classes) = foldBag union3 get_binders1
297 (emptyBag,emptyBag,emptyBag)
300 union3 (a1,a2,a3) (b1,b2,b3)
301 = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
303 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
304 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
305 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
306 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
307 get_binders1 (TyD (TySynonym name tyvars _ _))
308 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
309 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
310 = (unitBag tyvar `unionBags` sigs_tvs sigs,
311 emptyBag, unitBag name)
313 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
315 sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
316 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
321 typeCycleErr syn_cycles sty
322 = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
324 classCycleErr cls_cycles sty
325 = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
327 pp_cycle sty str things
329 4 (ppAboves (map pp_thing things))
331 pp_thing (pp_name, loc)
332 = ppCat [pp_name, ppr sty loc]