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 )
18 import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) )
21 import Inst ( InstanceMapper(..) )
22 import TcClassDcl ( tcClassDecl1 )
23 import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
24 tcExtendGlobalValEnv, tcExtendKindEnv,
25 tcTyVarScope, tcGetEnv )
26 import TcKind ( TcKind, newKindVars )
27 import TcTyDecls ( tcTyDecl )
30 import Class ( Class(..), getClassSelIds )
31 import Digraph ( findSCCs, SCC(..) )
32 import Name ( Name, isTyConName )
35 import UniqSet ( UniqSet(..), emptyUniqSet,
36 singletonUniqSet, unionUniqSets,
37 unionManyUniqSets, uniqSetToList )
38 import SrcLoc ( SrcLoc )
39 import TyCon ( TyCon, getTyConDataCons )
40 import Unique ( Unique )
41 import Util ( panic, pprTrace )
48 data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
50 tcTyAndClassDecls1 :: InstanceMapper
51 -> Bag RenamedTyDecl -> Bag RenamedClassDecl
54 tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
55 = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
56 tcGroups inst_mapper groups
58 cls_decls = mapBag ClD rncls_decls
59 ty_decls = mapBag TyD rnty_decls
60 syn_decls = filterBag is_syn_decl ty_decls
61 decls = ty_decls `unionBags` cls_decls
63 is_syn_decl (TyD (TySynonym _ _ _ _)) = True
66 tcGroups inst_mapper []
67 = tcGetEnv `thenNF_Tc` \ env ->
70 tcGroups inst_mapper (group:groups)
71 = tcGroup inst_mapper group `thenTc` \ new_env ->
73 -- Extend the environment using the new tycons and classes
76 -- Do the remaining groups
77 tcGroups inst_mapper groups
83 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
84 tcGroup inst_mapper decls
85 = fixTc ( \ ~(tycons,classes,_) ->
87 pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
89 -- EXTEND TYPE AND CLASS ENVIRONMENTS
90 -- including their data constructors and class operations
91 tcExtendTyConEnv tycons $
92 tcExtendClassEnv classes $
93 tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $
94 tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
96 -- SNAFFLE ENV TO RETURN
97 tcGetEnv `thenNF_Tc` \ final_env ->
99 -- DEAL WITH TYPE VARIABLES
100 tcTyVarScope tyvar_names ( \ tyvars ->
102 -- MANUFACTURE NEW KINDS, AND EXTEND KIND ENV
103 newKindVars (length tycon_names) `thenNF_Tc` \ tycon_kinds ->
104 newKindVars (length class_names) `thenNF_Tc` \ class_kinds ->
105 tcExtendKindEnv tycon_names tycon_kinds $
106 tcExtendKindEnv class_names class_kinds $
109 -- DEAL WITH THE DEFINITIONS THEMSELVES
110 foldBag combine (tcDecl inst_mapper)
111 (returnTc (emptyBag, emptyBag))
113 ) `thenTc` \ (tycons,classes) ->
115 returnTc (bagToList tycons, bagToList classes, final_env)
116 ) `thenTc` \ (_, _, final_env) ->
120 (tyvar_names, tycon_names, class_names) = get_binders decls
123 = do_a `thenTc` \ (a1,a2) ->
124 do_b `thenTc` \ (b1,b2) ->
125 returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
128 Dealing with one decl
129 ~~~~~~~~~~~~~~~~~~~~~
131 tcDecl :: InstanceMapper
133 -> TcM s (Bag TyCon, Bag Class)
135 tcDecl inst_mapper (TyD decl)
136 = tcTyDecl decl `thenTc` \ tycon ->
137 returnTc (unitBag tycon, emptyBag)
139 tcDecl inst_mapper (ClD decl)
140 = tcClassDecl1 inst_mapper decl `thenTc` \ clas ->
141 returnTc (emptyBag, unitBag clas)
147 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
148 sortByDependency syn_decls cls_decls decls
149 = let -- CHECK FOR SYNONYM CYCLES
150 syn_sccs = findSCCs mk_edges syn_decls
151 syn_cycles = [map fmt_decl (bagToList decls)
152 | CyclicSCC decls <- syn_sccs]
155 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
157 let -- CHECK FOR CLASS CYCLES
158 cls_sccs = findSCCs mk_edges cls_decls
159 cls_cycles = [map fmt_decl (bagToList decls)
160 | CyclicSCC decls <- cls_sccs]
163 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
165 -- DO THE MAIN DEPENDENCY ANALYSIS
167 decl_sccs = findSCCs mk_edges decls
168 scc_bags = map bag_acyclic decl_sccs
173 bag_acyclic (AcyclicSCC scc) = unitBag scc
174 bag_acyclic (CyclicSCC sccs) = sccs
176 fmt_decl (TyD (TySynonym name _ _ _)) = (ppr PprForUser name, getSrcLoc name)
177 fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name)
180 Edges in Type/Class decls
181 ~~~~~~~~~~~~~~~~~~~~~~~~~
183 mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
184 = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
185 mk_edges (TyD (TyNew ctxt name _ condecl _ _ _))
186 = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
187 mk_edges (TyD (TySynonym name _ rhs _))
188 = (getItsUnique name, set_to_bag (get_ty rhs))
189 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
190 = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
193 = unionManyUniqSets (map (set_name.fst) ctxt)
196 = unionManyUniqSets (map get_con cons)
198 get_con (ConDecl _ btys _)
199 = unionManyUniqSets (map get_bty btys)
200 get_con (ConOpDecl bty1 _ bty2 _)
201 = unionUniqSets (get_bty bty1) (get_bty bty2)
202 get_con (NewConDecl _ ty _)
204 get_con (RecConDecl _ nbtys _)
205 = unionManyUniqSets (map (get_bty.snd) nbtys)
207 get_bty (Banged ty) = get_ty ty
208 get_bty (Unbanged ty) = get_ty ty
210 get_ty (MonoTyVar tv)
212 get_ty (MonoTyApp name tys)
213 = (if isTyConName name then set_name name else emptyUniqSet)
214 `unionUniqSets` get_tys tys
215 get_ty (MonoFunTy ty1 ty2)
216 = unionUniqSets (get_ty ty1) (get_ty ty2)
217 get_ty (MonoListTy ty)
218 = get_ty ty -- careful when defining [] (,,) etc as
219 get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
221 get_ty other = panic "TcTyClsDecls:get_ty"
223 get_pty (HsForAllTy _ ctxt mty)
224 = get_ctxt ctxt `unionUniqSets` get_ty mty
225 get_pty other = panic "TcTyClsDecls:get_pty"
228 = unionManyUniqSets (map get_ty tys)
231 = unionManyUniqSets (map get_sig sigs)
233 get_sig (ClassOpSig _ ty _ _) = get_pty ty
234 get_sig other = panic "TcTyClsDecls:get_sig"
236 set_name name = singletonUniqSet (getItsUnique name)
238 set_to_bag set = listToBag (uniqSetToList set)
241 Extract *binding* names from type and class decls. Type variables are
242 bound in type, data, newtype and class declarations and the polytypes
243 in the class op sigs.
245 Why do we need to grab all these type variables at once, including
246 those locally-quantified type variables in class op signatures?
247 Because we can only commit to the final kind of a type variable when
248 we've completed the mutually recursive group. For example:
251 op :: D b => a -> b -> b
254 bop :: (Monad c) => ...
256 Here, the kind of the locally-polymorphic type variable "b"
257 depends on *all the uses of class D*. For example, the use of
258 Monad c in bop's type signature means that D must have kind Type->Type.
262 get_binders :: Bag Decl
263 -> ([Name], -- TyVars; no dups
264 [Name], -- Tycons; no dups
265 [Name]) -- Classes; no dups
267 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
269 (tyvars, tycons, classes) = foldBag union3 get_binders1
270 (emptyBag,emptyBag,emptyBag)
273 union3 (a1,a2,a3) (b1,b2,b3)
274 = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
276 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
277 = (listToBag tyvars, unitBag name, emptyBag)
278 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
279 = (listToBag tyvars, unitBag name, emptyBag)
280 get_binders1 (TyD (TySynonym name tyvars _ _))
281 = (listToBag tyvars, unitBag name, emptyBag)
282 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
283 = (unitBag tyvar `unionBags` sigs_tvs sigs,
284 emptyBag, unitBag name)
286 -- ToDo: will this duplicate the class tyvar
288 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
290 sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
291 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs
296 typeCycleErr syn_cycles sty
297 = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
299 classCycleErr cls_cycles sty
300 = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
302 pp_cycle sty str things
304 4 (ppAboves (map pp_thing things))
306 pp_thing (pp_name, loc)
307 = ppCat [pp_name, ppr sty loc]