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(..) )
23 import TcMonad hiding ( rnMtoTcM )
24 import Inst ( InstanceMapper(..) )
25 import TcClassDcl ( tcClassDecl1 )
26 import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
27 tcTyVarScope, tcGetEnv )
28 import TcKind ( TcKind, newKindVars )
29 import TcTyDecls ( tcTyDecl, mkDataBinds )
32 import Class ( Class(..), classSelIds )
33 import Digraph ( findSCCs, SCC(..) )
34 import Name ( getSrcLoc )
37 import UniqSet ( UniqSet(..), emptyUniqSet,
38 unitUniqSet, unionUniqSets,
39 unionManyUniqSets, uniqSetToList )
40 import SrcLoc ( SrcLoc )
41 import TyCon ( TyCon )
42 import Unique ( Unique )
43 import Util ( panic{-, pprTrace-} )
50 data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
52 tcTyAndClassDecls1 :: InstanceMapper
53 -> Bag RenamedTyDecl -> Bag RenamedClassDecl
56 tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
57 = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
58 tcGroups inst_mapper groups
60 cls_decls = mapBag ClD rncls_decls
61 ty_decls = mapBag TyD rnty_decls
62 syn_decls = filterBag is_syn_decl ty_decls
63 decls = ty_decls `unionBags` cls_decls
65 is_syn_decl (TyD (TySynonym _ _ _ _)) = True
68 tcGroups inst_mapper []
69 = tcGetEnv `thenNF_Tc` \ env ->
72 tcGroups inst_mapper (group:groups)
73 = tcGroup inst_mapper group `thenTc` \ new_env ->
75 -- Extend the environment using the new tycons and classes
78 -- Do the remaining groups
79 tcGroups inst_mapper groups
85 tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
86 tcGroup inst_mapper decls
87 = -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
90 fixTc ( \ ~(tycons,classes,_) ->
92 -- EXTEND TYPE AND CLASS ENVIRONMENTS
93 -- NB: it's important that the tycons and classes come back in just
94 -- the same order from this fix as from get_binders, so that these
95 -- extend-env things work properly. A bit UGH-ish.
96 tcExtendTyConEnv tycon_names_w_arities tycons $
97 tcExtendClassEnv class_names classes $
99 -- DEAL WITH TYPE VARIABLES
100 tcTyVarScope tyvar_names ( \ tyvars ->
102 -- DEAL WITH THE DEFINITIONS THEMSELVES
103 foldBag combine (tcDecl inst_mapper)
104 (returnTc (emptyBag, emptyBag))
106 ) `thenTc` \ (tycon_bag,class_bag) ->
108 tycons = bagToList tycon_bag
109 classes = bagToList class_bag
112 -- SNAFFLE ENV TO RETURN
113 tcGetEnv `thenNF_Tc` \ final_env ->
115 returnTc (tycons, classes, final_env)
116 ) `thenTc` \ (_, _, final_env) ->
121 (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
123 tyvar_names = map de_rn tyvar_rn_names
127 = do_a `thenTc` \ (a1,a2) ->
128 do_b `thenTc` \ (b1,b2) ->
129 returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
132 Dealing with one decl
133 ~~~~~~~~~~~~~~~~~~~~~
135 tcDecl :: InstanceMapper
137 -> TcM s (Bag TyCon, Bag Class)
139 tcDecl inst_mapper (TyD decl)
140 = tcTyDecl decl `thenTc` \ tycon ->
141 returnTc (unitBag tycon, emptyBag)
143 tcDecl inst_mapper (ClD decl)
144 = tcClassDecl1 inst_mapper decl `thenTc` \ clas ->
145 returnTc (emptyBag, unitBag clas)
151 sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
152 sortByDependency syn_decls cls_decls decls
153 = let -- CHECK FOR SYNONYM CYCLES
154 syn_sccs = findSCCs mk_edges syn_decls
155 syn_cycles = [map fmt_decl (bagToList decls)
156 | CyclicSCC decls <- syn_sccs]
159 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
161 let -- CHECK FOR CLASS CYCLES
162 cls_sccs = findSCCs mk_edges cls_decls
163 cls_cycles = [map fmt_decl (bagToList decls)
164 | CyclicSCC decls <- cls_sccs]
167 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
169 -- DO THE MAIN DEPENDENCY ANALYSIS
171 decl_sccs = findSCCs mk_edges decls
172 scc_bags = map bag_acyclic decl_sccs
177 bag_acyclic (AcyclicSCC scc) = unitBag scc
178 bag_acyclic (CyclicSCC sccs) = sccs
181 = (ppr PprForUser name, getSrcLoc name)
184 get_name (TyD (TyData _ name _ _ _ _ _)) = name
185 get_name (TyD (TyNew _ name _ _ _ _ _)) = name
186 get_name (TyD (TySynonym name _ _ _)) = name
187 get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
190 Edges in Type/Class decls
191 ~~~~~~~~~~~~~~~~~~~~~~~~~
193 mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
194 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs))
195 mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _))
196 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl `unionUniqSets` get_deriv derivs))
197 mk_edges (TyD (TySynonym name _ rhs _))
198 = (uniqueOf name, set_to_bag (get_ty rhs))
199 mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
200 = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
203 = unionManyUniqSets (map (set_name.fst) ctxt)
205 get_deriv Nothing = emptyUniqSet
206 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
209 = unionManyUniqSets (map get_con cons)
211 get_con (ConDecl _ btys _)
212 = unionManyUniqSets (map get_bty btys)
213 get_con (ConOpDecl bty1 _ bty2 _)
214 = unionUniqSets (get_bty bty1) (get_bty bty2)
215 get_con (NewConDecl _ ty _)
217 get_con (RecConDecl _ nbtys _)
218 = unionManyUniqSets (map (get_bty.snd) nbtys)
220 get_bty (Banged ty) = get_pty ty
221 get_bty (Unbanged ty) = get_pty ty
223 get_ty (MonoTyVar tv)
225 get_ty (MonoTyApp name tys)
226 = (if isRnTyCon name then set_name name else emptyUniqSet)
227 `unionUniqSets` get_tys tys
228 get_ty (MonoFunTy ty1 ty2)
229 = unionUniqSets (get_ty ty1) (get_ty ty2)
230 get_ty (MonoListTy ty)
231 = get_ty ty -- careful when defining [] (,,) etc as
232 get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
234 get_ty other = panic "TcTyClsDecls:get_ty"
236 get_pty (HsForAllTy _ ctxt mty)
237 = get_ctxt ctxt `unionUniqSets` get_ty mty
238 get_pty other = panic "TcTyClsDecls:get_pty"
241 = unionManyUniqSets (map get_ty tys)
244 = unionManyUniqSets (map get_sig sigs)
246 get_sig (ClassOpSig _ ty _ _) = get_pty ty
247 get_sig other = panic "TcTyClsDecls:get_sig"
249 set_name name = unitUniqSet (uniqueOf name)
251 set_to_bag set = listToBag (uniqSetToList set)
257 Extract *binding* names from type and class decls. Type variables are
258 bound in type, data, newtype and class declarations and the polytypes
259 in the class op sigs.
261 Why do we need to grab all these type variables at once, including
262 those locally-quantified type variables in class op signatures?
263 Because we can only commit to the final kind of a type variable when
264 we've completed the mutually recursive group. For example:
267 op :: D b => a -> b -> b
270 bop :: (Monad c) => ...
272 Here, the kind of the locally-polymorphic type variable "b"
273 depends on *all the uses of class D*. For example, the use of
274 Monad c in bop's type signature means that D must have kind Type->Type.
278 get_binders :: Bag Decl
279 -> ([RnName], -- TyVars; no dups
280 [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms
281 [RnName]) -- Classes; no dups
283 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
285 (tyvars, tycons, classes) = foldBag union3 get_binders1
286 (emptyBag,emptyBag,emptyBag)
289 union3 (a1,a2,a3) (b1,b2,b3)
290 = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
292 get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
293 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
294 get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
295 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
296 get_binders1 (TyD (TySynonym name tyvars _ _))
297 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
298 get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
299 = (unitBag tyvar `unionBags` sigs_tvs sigs,
300 emptyBag, unitBag name)
302 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
304 sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
305 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
310 typeCycleErr syn_cycles sty
311 = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
313 classCycleErr cls_cycles sty
314 = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
316 pp_cycle sty str things
318 4 (ppAboves (map pp_thing things))
320 pp_thing (pp_name, loc)
321 = ppCat [pp_name, ppr sty loc]