2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcTyClsDecls]{Typecheck type and class declarations}
11 #include "HsVersions.h"
13 import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..),
15 ConDecl(..), ConDetails(..), BangType(..),
19 import RnHsSyn ( RenamedHsDecl )
20 import RnEnv ( listTyCon_name, tupleTyCon_name ) -- ToDo: move these
21 import BasicTypes ( RecFlag(..), Arity )
24 import Inst ( InstanceMapper )
25 import TcClassDcl ( tcClassDecl1 )
26 import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv )
27 import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind )
28 import TcTyDecls ( tcTyDecl )
29 import TcMonoType ( tcTyVarScope )
31 import TyCon ( tyConKind, tyConArity, isSynTyCon )
32 import Class ( Class, classBigSig )
33 import Var ( tyVarKind )
35 import Digraph ( stronglyConnComp, SCC(..) )
36 import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
38 import Maybes ( mapMaybe )
39 import UniqSet ( UniqSet, emptyUniqSet,
40 unitUniqSet, unionUniqSets,
41 unionManyUniqSets, uniqSetToList )
42 import SrcLoc ( SrcLoc )
43 import TyCon ( TyCon )
44 import Unique ( Unique, Uniquable(..) )
45 import Util ( panic{-, pprTrace-} )
52 tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper -- Knot tying stuff
56 tcTyAndClassDecls1 unf_env inst_mapper decls
57 = sortByDependency decls `thenTc` \ groups ->
58 tcGroups unf_env inst_mapper groups
60 tcGroups unf_env inst_mapper []
61 = tcGetEnv `thenNF_Tc` \ env ->
64 tcGroups unf_env inst_mapper (group:groups)
65 = tcGroup unf_env inst_mapper group `thenTc` \ (group_tycons, group_classes) ->
67 -- Extend the environment using the new tycons and classes
68 tcExtendTyConEnv [(getName tycon, (kindToTcKind (tyConKind tycon),
69 if isSynTyCon tycon then Just (tyConArity tycon) else Nothing,
71 | tycon <- group_tycons] $
73 tcExtendClassEnv [(getName clas, (classKind clas, clas))
74 | clas <- group_classes] $
77 -- Do the remaining groups
78 tcGroups unf_env inst_mapper groups
80 classKind clas = map (kindToTcKind . tyVarKind) tyvars
82 (tyvars, _, _, _, _) = classBigSig clas
88 Notice the uses of @zipLazy@, which makes sure
89 that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
93 tcGroup :: GlobalValueEnv -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class])
94 tcGroup unf_env inst_mapper scc
96 fixTc ( \ ~(rec_tycons, rec_classes) ->
98 -- EXTEND TYPE AND CLASS ENVIRONMENTS
100 mk_tycon_bind (name, arity) = newKindVar `thenNF_Tc` \ kind ->
101 returnNF_Tc (name, (kind, arity, find name rec_tycons))
103 mk_class_bind (name, arity) = newKindVars arity `thenNF_Tc` \ kinds ->
104 returnNF_Tc (name, (kinds, find name rec_classes))
106 find name [] = pprPanic "tcGroup" (ppr name)
107 find name (thing:things) | name == getName thing = thing
108 | otherwise = find name things
111 mapNF_Tc mk_tycon_bind tycon_names_w_arities `thenNF_Tc` \ tycon_binds ->
112 mapNF_Tc mk_class_bind class_names_w_arities `thenNF_Tc` \ class_binds ->
113 tcExtendTyConEnv tycon_binds $
114 tcExtendClassEnv class_binds $
116 -- DEAL WITH TYPE VARIABLES
117 tcTyVarScope tyvar_names ( \ tyvars ->
119 -- DEAL WITH THE DEFINITIONS THEMSELVES
120 foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls
121 ) `thenTc` \ (tycons, classes) ->
123 returnTc (tycons, classes)
126 is_rec_group = case scc of
127 AcyclicSCC _ -> NonRecursive
128 CyclicSCC _ -> Recursive
131 AcyclicSCC decl -> [decl]
132 CyclicSCC decls -> decls
134 (tyvar_names, tycon_names_w_arities, class_names_w_arities) = get_binders decls
137 Dealing with one decl
138 ~~~~~~~~~~~~~~~~~~~~~
140 tcDecl :: RecFlag -- True => recursive group
141 -> GlobalValueEnv -> InstanceMapper
142 -> ([TyCon], [Class]) -- Accumulating parameter
144 -> TcM s ([TyCon], [Class])
146 tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl)
147 = tcTyDecl is_rec_group decl `thenTc` \ tycon ->
148 returnTc (tycon:tycons, classes)
150 tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (ClD decl)
151 = tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas ->
152 returnTc (tycons, clas:classes)
158 sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl]
159 sortByDependency decls
160 = let -- CHECK FOR CLASS CYCLES
161 cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges decls)
162 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
164 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
166 let -- CHECK FOR SYNONYM CYCLES
167 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
168 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
171 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
173 -- DO THE MAIN DEPENDENCY ANALYSIS
175 decl_sccs = stronglyConnComp edges
179 edges = mapMaybe mk_edges decls
181 is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
182 is_syn_decl _ = False
184 is_cls_decl (ClD _, _, _) = True
185 is_cls_decl other = False
188 Edges in Type/Class decls
189 ~~~~~~~~~~~~~~~~~~~~~~~~~
191 -- mk_cls_edges looks only at the context of class decls
192 -- Its used when we are figuring out if there's a cycle in the
193 -- superclass hierarchy
195 mk_cls_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
197 mk_cls_edges decl@(ClD (ClassDecl ctxt name _ _ _ _ _ _ _))
198 = Just (decl, getUnique name, map (getUnique . fst) ctxt)
199 mk_cls_edges other_decl
203 mk_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
205 mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
206 = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
207 get_cons condecls `unionUniqSets`
210 mk_edges decl@(TyD (TySynonym name _ rhs _))
211 = Just (decl, getUnique name, uniqSetToList (get_ty rhs))
213 mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
214 = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
217 mk_edges other_decl = Nothing
219 get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
221 get_deriv Nothing = emptyUniqSet
222 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
224 get_cons cons = unionManyUniqSets (map get_con cons)
226 get_con (ConDecl _ _ ctxt details _)
227 = get_ctxt ctxt `unionUniqSets` get_con_details details
229 get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
230 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
231 get_con_details (NewCon ty) = get_ty ty
232 get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
234 get_bty (Banged ty) = get_ty ty
235 get_bty (Unbanged ty) = get_ty ty
237 get_ty (MonoTyVar name)
238 = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
239 get_ty (MonoTyApp ty1 ty2)
240 = unionUniqSets (get_ty ty1) (get_ty ty2)
241 get_ty (MonoFunTy ty1 ty2)
242 = unionUniqSets (get_ty ty1) (get_ty ty2)
243 get_ty (MonoListTy ty)
244 = set_name listTyCon_name `unionUniqSets` get_ty ty
245 get_ty (MonoTupleTy tys boxed)
246 = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
247 get_ty (HsForAllTy _ ctxt mty)
248 = get_ctxt ctxt `unionUniqSets` get_ty mty
249 get_ty other = panic "TcTyClsDecls:get_ty"
252 = unionManyUniqSets (map get_ty tys)
255 = unionManyUniqSets (map get_sig sigs)
257 get_sig (ClassOpSig _ _ ty _) = get_ty ty
258 get_sig other = panic "TcTyClsDecls:get_sig"
260 set_name name = unitUniqSet (getUnique 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,
270 *and* the polytypes in the class op sigs.
271 *and* the existentially quantified contexts in datacon decls
273 Why do we need to grab all these type variables at once, including
274 those locally-quantified type variables in class op signatures?
276 [Incidentally, this only works because the names are all unique by now.]
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 :: [RenamedHsDecl]
294 -> ([HsTyVar Name], -- TyVars; no dups
295 [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
296 [(Name, Arity)]) -- Classes; no dups; with their arities
298 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
300 (tyvars, tycons, classes) = foldr (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 (TySynonym name tyvars _ _))
308 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
309 get_binders1 (TyD (TyData _ _ name tyvars condecls _ _ _))
310 = (listToBag tyvars `unionBags` cons_tvs condecls,
311 unitBag (name,Nothing), emptyBag)
312 get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
313 = (listToBag tyvars `unionBags` sigs_tvs sigs,
314 emptyBag, unitBag (name, length tyvars))
316 cons_tvs condecls = unionManyBags (map con_tvs condecls)
318 con_tvs (ConDecl _ tvs _ _ _) = listToBag tvs
320 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
322 sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
323 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
324 pty_tvs other = emptyBag
329 typeCycleErr syn_cycles
330 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
332 classCycleErr cls_cycles
333 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
337 4 (vcat (map pp_decl decls))
340 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
342 name = hsDeclName decl