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 ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
19 RnName(..){-instance Uniquable-}
21 import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
24 import Inst ( InstanceMapper(..) )
25 import TcClassDcl ( tcClassDecl1 )
26 import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
28 tcTyVarScope, tcGetEnv )
29 import TcKind ( TcKind, newKindVars )
30 import TcTyDecls ( tcTyDecl, mkDataBinds )
33 import Class ( Class(..), getClassSelIds )
34 import Digraph ( findSCCs, SCC(..) )
35 import Name ( getSrcLoc )
38 import UniqSet ( UniqSet(..), emptyUniqSet,
39 unitUniqSet, unionUniqSets,
40 unionManyUniqSets, uniqSetToList )
41 import SrcLoc ( SrcLoc )
42 import TyCon ( TyCon, tyConDataCons, isDataTyCon )
43 import Unique ( Unique )
44 import Util ( panic, pprTrace )
51 data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
53 tcTyAndClassDecls1 :: InstanceMapper
54 -> Bag RenamedTyDecl -> Bag RenamedClassDecl
55 -> TcM s (TcEnv s, TcHsBinds s)
57 tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
58 = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
59 tcGroups inst_mapper groups
61 cls_decls = mapBag ClD rncls_decls
62 ty_decls = mapBag TyD rnty_decls
63 syn_decls = filterBag is_syn_decl ty_decls
64 decls = ty_decls `unionBags` cls_decls
66 is_syn_decl (TyD (TySynonym _ _ _ _)) = True
69 tcGroups inst_mapper []
70 = tcGetEnv `thenNF_Tc` \ env ->
71 returnTc (env, EmptyBinds)
73 tcGroups inst_mapper (group:groups)
74 = tcGroup inst_mapper group `thenTc` \ (new_env, binds1) ->
76 -- Extend the environment using the new tycons and classes
79 -- Do the remaining groups
80 tcGroups inst_mapper groups `thenTc` \ (final_env, binds2) ->
82 returnTc (final_env, binds1 `ThenBinds` binds2)
88 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s)
89 tcGroup inst_mapper decls
90 = pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
93 fixTc ( \ ~(tycons,classes,_) ->
95 -- EXTEND TYPE AND CLASS ENVIRONMENTS
96 -- including their data constructors and class operations
97 -- NB: it's important that the tycons and classes come back in just
98 -- the same order from this fix as from get_binders, so that these
99 -- extend-env things work properly. A bit UGH-ish.
100 tcExtendTyConEnv tycon_names_w_arities tycons $
101 tcExtendClassEnv class_names classes $
103 -- DEAL WITH TYPE VARIABLES
104 tcTyVarScope tyvar_names ( \ tyvars ->
106 -- DEAL WITH THE DEFINITIONS THEMSELVES
107 foldBag combine (tcDecl inst_mapper)
108 (returnTc (emptyBag, emptyBag))
110 ) `thenTc` \ (tycon_bag,class_bag) ->
112 tycons = bagToList tycon_bag
113 classes = bagToList class_bag
116 -- SNAFFLE ENV TO RETURN
117 tcGetEnv `thenNF_Tc` \ final_env ->
119 returnTc (tycons, classes, final_env)
120 ) `thenTc` \ (tycons, classes, final_env) ->
123 -- Create any necessary record selector Ids and their bindings
124 mapAndUnzipTc mkDataBinds (filter isDataTyCon tycons) `thenTc` \ (data_ids_s, binds) ->
126 -- Extend the global value environment with
128 -- b) record selectors
129 -- c) class op selectors
132 tcExtendGlobalValEnv (concat data_ids_s) $
133 tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
134 tcGetEnv `thenNF_Tc` \ really_final_env ->
136 returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
139 (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
141 tyvar_names = map de_rn tyvar_rn_names
145 = do_a `thenTc` \ (a1,a2) ->
146 do_b `thenTc` \ (b1,b2) ->
147 returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
150 Dealing with one decl
151 ~~~~~~~~~~~~~~~~~~~~~
153 tcDecl :: InstanceMapper
155 -> TcM s (Bag TyCon, Bag Class)
157 tcDecl inst_mapper (TyD decl)
158 = tcTyDecl decl `thenTc` \ tycon ->
159 returnTc (unitBag tycon, emptyBag)
161 tcDecl inst_mapper (ClD decl)
162 = tcClassDecl1 inst_mapper decl `thenTc` \ clas ->
163 returnTc (emptyBag, unitBag clas)
169 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
170 sortByDependency syn_decls cls_decls decls
171 = let -- CHECK FOR SYNONYM CYCLES
172 syn_sccs = findSCCs mk_edges syn_decls
173 syn_cycles = [map fmt_decl (bagToList decls)
174 | CyclicSCC decls <- syn_sccs]
177 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
179 let -- CHECK FOR CLASS CYCLES
180 cls_sccs = findSCCs mk_edges cls_decls
181 cls_cycles = [map fmt_decl (bagToList decls)
182 | CyclicSCC decls <- cls_sccs]
185 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
187 -- DO THE MAIN DEPENDENCY ANALYSIS
189 decl_sccs = findSCCs mk_edges decls
190 scc_bags = map bag_acyclic decl_sccs
195 bag_acyclic (AcyclicSCC scc) = unitBag scc
196 bag_acyclic (CyclicSCC sccs) = sccs
199 = (ppr PprForUser name, getSrcLoc name)
202 get_name (TyD (TyData _ name _ _ _ _ _)) = name
203 get_name (TyD (TyNew _ name _ _ _ _ _)) = name
204 get_name (TyD (TySynonym name _ _ _)) = name
205 get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
208 Edges in Type/Class decls
209 ~~~~~~~~~~~~~~~~~~~~~~~~~
211 mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
212 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
213 mk_edges (TyD (TyNew ctxt name _ condecl _ _ _))
214 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
215 mk_edges (TyD (TySynonym name _ rhs _))
216 = (uniqueOf name, set_to_bag (get_ty rhs))
217 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
218 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
221 = unionManyUniqSets (map (set_name.fst) ctxt)
224 = unionManyUniqSets (map get_con cons)
226 get_con (ConDecl _ btys _)
227 = unionManyUniqSets (map get_bty btys)
228 get_con (ConOpDecl bty1 _ bty2 _)
229 = unionUniqSets (get_bty bty1) (get_bty bty2)
230 get_con (NewConDecl _ ty _)
232 get_con (RecConDecl _ nbtys _)
233 = unionManyUniqSets (map (get_bty.snd) nbtys)
235 get_bty (Banged ty) = get_ty ty
236 get_bty (Unbanged ty) = get_ty ty
238 get_ty (MonoTyVar tv)
240 get_ty (MonoTyApp name tys)
241 = (if isRnTyCon name then set_name name else emptyUniqSet)
242 `unionUniqSets` get_tys tys
243 get_ty (MonoFunTy ty1 ty2)
244 = unionUniqSets (get_ty ty1) (get_ty ty2)
245 get_ty (MonoListTy ty)
246 = get_ty ty -- careful when defining [] (,,) etc as
247 get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
249 get_ty other = panic "TcTyClsDecls:get_ty"
251 get_pty (HsForAllTy _ ctxt mty)
252 = get_ctxt ctxt `unionUniqSets` get_ty mty
253 get_pty other = panic "TcTyClsDecls:get_pty"
256 = unionManyUniqSets (map get_ty tys)
259 = unionManyUniqSets (map get_sig sigs)
261 get_sig (ClassOpSig _ ty _ _) = get_pty ty
262 get_sig other = panic "TcTyClsDecls:get_sig"
264 set_name name = unitUniqSet (uniqueOf name)
266 set_to_bag set = listToBag (uniqSetToList set)
272 Extract *binding* names from type and class decls. Type variables are
273 bound in type, data, newtype and class declarations and the polytypes
274 in the class op sigs.
276 Why do we need to grab all these type variables at once, including
277 those locally-quantified type variables in class op signatures?
278 Because we can only commit to the final kind of a type variable when
279 we've completed the mutually recursive group. For example:
282 op :: D b => a -> b -> b
285 bop :: (Monad c) => ...
287 Here, the kind of the locally-polymorphic type variable "b"
288 depends on *all the uses of class D*. For example, the use of
289 Monad c in bop's type signature means that D must have kind Type->Type.
293 get_binders :: Bag Decl
294 -> ([RnName], -- TyVars; no dups
295 [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms
296 [RnName]) -- Classes; no dups
298 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
300 (tyvars, tycons, classes) = foldBag union3 get_binders1
301 (emptyBag,emptyBag,emptyBag)
304 union3 (a1,a2,a3) (b1,b2,b3)
305 = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
307 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
308 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
309 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
310 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
311 get_binders1 (TyD (TySynonym name tyvars _ _))
312 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
313 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
314 = (unitBag tyvar `unionBags` sigs_tvs sigs,
315 emptyBag, unitBag name)
317 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
319 sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
320 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
325 typeCycleErr syn_cycles sty
326 = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
328 classCycleErr cls_cycles sty
329 = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
331 pp_cycle sty str things
333 4 (ppAboves (map pp_thing things))
335 pp_thing (pp_name, loc)
336 = ppCat [pp_name, ppr sty loc]