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 ( SYN_IE(TcHsBinds), TcIdOcc(..) )
23 import TcMonad hiding ( rnMtoTcM )
24 import Inst ( SYN_IE(InstanceMapper) )
25 import TcClassDcl ( tcClassDecl1 )
26 import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
28 import SpecEnv ( SpecEnv )
29 import TcKind ( TcKind, newKindVars )
30 import TcTyDecls ( tcTyDecl, mkDataBinds )
33 import Class ( SYN_IE(Class), classSelIds )
34 import Digraph ( findSCCs, SCC(..) )
35 import Name ( getSrcLoc )
38 import UniqSet ( SYN_IE(UniqSet), emptyUniqSet,
39 unitUniqSet, unionUniqSets,
40 unionManyUniqSets, uniqSetToList )
41 import SrcLoc ( SrcLoc )
42 import TyCon ( TyCon )
43 import Unique ( Unique )
44 import Util ( panic{-, pprTrace-} )
51 data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
53 tcTyAndClassDecls1 :: InstanceMapper
54 -> Bag RenamedTyDecl -> Bag RenamedClassDecl
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 ->
73 tcGroups inst_mapper (group:groups)
74 = tcGroup inst_mapper group `thenTc` \ new_env ->
76 -- Extend the environment using the new tycons and classes
79 -- Do the remaining groups
80 tcGroups inst_mapper groups
86 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv 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 -- NB: it's important that the tycons and classes come back in just
95 -- the same order from this fix as from get_binders, so that these
96 -- extend-env things work properly. A bit UGH-ish.
97 tcExtendTyConEnv tycon_names_w_arities tycons $
98 tcExtendClassEnv class_names classes $
100 -- DEAL WITH TYPE VARIABLES
101 tcTyVarScope tyvar_names ( \ tyvars ->
103 -- DEAL WITH THE DEFINITIONS THEMSELVES
104 foldBag combine (tcDecl inst_mapper)
105 (returnTc (emptyBag, emptyBag))
107 ) `thenTc` \ (tycon_bag,class_bag) ->
109 tycons = bagToList tycon_bag
110 classes = bagToList class_bag
113 -- SNAFFLE ENV TO RETURN
114 tcGetEnv `thenNF_Tc` \ final_env ->
116 returnTc (tycons, classes, final_env)
117 ) `thenTc` \ (_, _, final_env) ->
122 (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
124 tyvar_names = map de_rn tyvar_rn_names
128 = do_a `thenTc` \ (a1,a2) ->
129 do_b `thenTc` \ (b1,b2) ->
130 returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
133 Dealing with one decl
134 ~~~~~~~~~~~~~~~~~~~~~
136 tcDecl :: InstanceMapper
138 -> TcM s (Bag TyCon, Bag Class)
140 tcDecl inst_mapper (TyD decl)
141 = tcTyDecl decl `thenTc` \ tycon ->
142 returnTc (unitBag tycon, emptyBag)
144 tcDecl inst_mapper (ClD decl)
145 = tcClassDecl1 inst_mapper decl `thenTc` \ clas ->
146 returnTc (emptyBag, unitBag clas)
152 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
153 sortByDependency syn_decls cls_decls decls
154 = let -- CHECK FOR SYNONYM CYCLES
155 syn_sccs = findSCCs mk_edges syn_decls
156 syn_cycles = [map fmt_decl (bagToList decls)
157 | CyclicSCC decls <- syn_sccs]
160 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
162 let -- CHECK FOR CLASS CYCLES
163 cls_sccs = findSCCs mk_edges cls_decls
164 cls_cycles = [map fmt_decl (bagToList decls)
165 | CyclicSCC decls <- cls_sccs]
168 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
170 -- DO THE MAIN DEPENDENCY ANALYSIS
172 decl_sccs = findSCCs mk_edges decls
173 scc_bags = map bag_acyclic decl_sccs
178 bag_acyclic (AcyclicSCC scc) = unitBag scc
179 bag_acyclic (CyclicSCC sccs) = sccs
182 = (ppr PprForUser name, getSrcLoc name)
185 get_name (TyD (TyData _ name _ _ _ _ _)) = name
186 get_name (TyD (TyNew _ name _ _ _ _ _)) = name
187 get_name (TyD (TySynonym name _ _ _)) = name
188 get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
191 Edges in Type/Class decls
192 ~~~~~~~~~~~~~~~~~~~~~~~~~
194 mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
195 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs))
196 mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _))
197 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl `unionUniqSets` get_deriv derivs))
198 mk_edges (TyD (TySynonym name _ rhs _))
199 = (uniqueOf name, set_to_bag (get_ty rhs))
200 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
201 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
204 = unionManyUniqSets (map (set_name.fst) ctxt)
206 get_deriv Nothing = emptyUniqSet
207 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
210 = unionManyUniqSets (map get_con cons)
212 get_con (ConDecl _ btys _)
213 = unionManyUniqSets (map get_bty btys)
214 get_con (ConOpDecl bty1 _ bty2 _)
215 = unionUniqSets (get_bty bty1) (get_bty bty2)
216 get_con (NewConDecl _ ty _)
218 get_con (RecConDecl _ nbtys _)
219 = unionManyUniqSets (map (get_bty.snd) nbtys)
221 get_bty (Banged ty) = get_pty ty
222 get_bty (Unbanged ty) = get_pty ty
224 get_ty (MonoTyVar tv)
226 get_ty (MonoTyApp name tys)
227 = (if isRnTyCon name then set_name name else emptyUniqSet)
228 `unionUniqSets` get_tys tys
229 get_ty (MonoFunTy ty1 ty2)
230 = unionUniqSets (get_ty ty1) (get_ty ty2)
231 get_ty (MonoListTy ty)
232 = get_ty ty -- careful when defining [] (,,) etc as
233 get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
235 get_ty other = panic "TcTyClsDecls:get_ty"
237 get_pty (HsForAllTy _ ctxt mty)
238 = get_ctxt ctxt `unionUniqSets` get_ty mty
239 get_pty other = panic "TcTyClsDecls:get_pty"
242 = unionManyUniqSets (map get_ty tys)
245 = unionManyUniqSets (map get_sig sigs)
247 get_sig (ClassOpSig _ ty _ _) = get_pty ty
248 get_sig other = panic "TcTyClsDecls:get_sig"
250 set_name name = unitUniqSet (uniqueOf name)
252 set_to_bag set = listToBag (uniqSetToList set)
258 Extract *binding* names from type and class decls. Type variables are
259 bound in type, data, newtype and class declarations and the polytypes
260 in the class op sigs.
262 Why do we need to grab all these type variables at once, including
263 those locally-quantified type variables in class op signatures?
264 Because we can only commit to the final kind of a type variable when
265 we've completed the mutually recursive group. For example:
268 op :: D b => a -> b -> b
271 bop :: (Monad c) => ...
273 Here, the kind of the locally-polymorphic type variable "b"
274 depends on *all the uses of class D*. For example, the use of
275 Monad c in bop's type signature means that D must have kind Type->Type.
279 get_binders :: Bag Decl
280 -> ([RnName], -- TyVars; no dups
281 [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms
282 [RnName]) -- Classes; no dups
284 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
286 (tyvars, tycons, classes) = foldBag union3 get_binders1
287 (emptyBag,emptyBag,emptyBag)
290 union3 (a1,a2,a3) (b1,b2,b3)
291 = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
293 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
294 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
295 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
296 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
297 get_binders1 (TyD (TySynonym name tyvars _ _))
298 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
299 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
300 = (unitBag tyvar `unionBags` sigs_tvs sigs,
301 emptyBag, unitBag name)
303 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
305 sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
306 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
311 typeCycleErr syn_cycles sty
312 = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
314 classCycleErr cls_cycles sty
315 = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
317 pp_cycle sty str things
319 4 (ppAboves (map pp_thing things))
321 pp_thing (pp_name, loc)
322 = ppCat [pp_name, ppr sty loc]