2 % (c) The AQUA Project, Glasgow University, 1996
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 ( RenamedTyDecl(..), RenamedClassDecl(..), RenamedHsDecl )
20 import TcHsSyn ( TcHsBinds )
21 import BasicTypes ( RecFlag(..) )
24 import Inst ( InstanceMapper )
25 import TcClassDcl ( tcClassDecl1 )
26 import TcEnv ( TcIdOcc(..), tcExtendTyConEnv, tcExtendClassEnv )
27 import TcKind ( TcKind, newKindVar, newKindVars, tcDefaultKind, kindToTcKind )
28 import TcTyDecls ( tcTyDecl, mkDataBinds )
29 import TcMonoType ( tcTyVarScope )
31 import TyCon ( tyConKind, tyConArity, isSynTyCon )
32 import Class ( Class, classBigSig )
33 import TyVar ( 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, Arity )
44 import Unique ( Unique, Uniquable(..) )
45 import Util ( panic{-, pprTrace-} )
52 tcTyAndClassDecls1 :: TcEnv s -> 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 :: TcEnv s -> 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 -> TcEnv s -> 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 SYNONYM CYCLES
161 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
162 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
165 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
167 let -- CHECK FOR CLASS CYCLES
168 cls_sccs = stronglyConnComp (filter is_cls_decl edges)
169 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
172 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
174 -- DO THE MAIN DEPENDENCY ANALYSIS
176 decl_sccs = stronglyConnComp (filter is_ty_cls_decl edges)
181 edges = mapMaybe mk_edges decls
183 bag_acyclic (AcyclicSCC scc) = unitBag scc
184 bag_acyclic (CyclicSCC sccs) = listToBag sccs
186 is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
187 is_syn_decl _ = False
189 is_ty_cls_decl (TyD _, _, _) = True
190 is_ty_cls_decl (ClD _, _, _) = True
191 is_ty_cls_decl other = False
193 is_cls_decl (ClD _, _, _) = True
194 is_cls_decl other = False
197 Edges in Type/Class decls
198 ~~~~~~~~~~~~~~~~~~~~~~~~~
200 mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
201 = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
202 get_cons condecls `unionUniqSets`
205 mk_edges decl@(TyD (TySynonym name _ rhs _))
206 = Just (decl, uniqueOf name, uniqSetToList (get_ty rhs))
208 mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
209 = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
212 mk_edges other_decl = Nothing
214 get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
216 get_deriv Nothing = emptyUniqSet
217 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
219 get_cons cons = unionManyUniqSets (map get_con cons)
221 get_con (ConDecl _ ctxt details _)
222 = get_ctxt ctxt `unionUniqSets` get_con_details details
224 get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
225 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
226 get_con_details (NewCon ty) = get_ty ty
227 get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
229 get_bty (Banged ty) = get_ty ty
230 get_bty (Unbanged ty) = get_ty ty
232 get_ty (MonoTyVar name)
233 = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
234 get_ty (MonoTyApp ty1 ty2)
235 = unionUniqSets (get_ty ty1) (get_ty ty2)
236 get_ty (MonoFunTy ty1 ty2)
237 = unionUniqSets (get_ty ty1) (get_ty ty2)
238 get_ty (MonoListTy tc ty)
239 = set_name tc `unionUniqSets` get_ty ty
240 get_ty (MonoTupleTy tc tys)
241 = set_name tc `unionUniqSets` get_tys tys
242 get_ty (HsForAllTy _ ctxt mty)
243 = get_ctxt ctxt `unionUniqSets` get_ty mty
244 get_ty other = panic "TcTyClsDecls:get_ty"
247 = unionManyUniqSets (map get_ty tys)
250 = unionManyUniqSets (map get_sig sigs)
252 get_sig (ClassOpSig _ _ ty _) = get_ty ty
253 get_sig other = panic "TcTyClsDecls:get_sig"
255 set_name name = unitUniqSet (uniqueOf name)
257 set_to_bag set = listToBag (uniqSetToList set)
263 Extract *binding* names from type and class decls. Type variables are
264 bound in type, data, newtype and class declarations and the polytypes
265 in the class op sigs.
267 Why do we need to grab all these type variables at once, including
268 those locally-quantified type variables in class op signatures?
269 Because we can only commit to the final kind of a type variable when
270 we've completed the mutually recursive group. For example:
273 op :: D b => a -> b -> b
276 bop :: (Monad c) => ...
278 Here, the kind of the locally-polymorphic type variable "b"
279 depends on *all the uses of class D*. For example, the use of
280 Monad c in bop's type signature means that D must have kind Type->Type.
284 get_binders :: [RenamedHsDecl]
285 -> ([HsTyVar Name], -- TyVars; no dups
286 [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
287 [(Name, Arity)]) -- Classes; no dups; with their arities
289 get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
291 (tyvars, tycons, classes) = foldr (union3 . get_binders1)
292 (emptyBag,emptyBag,emptyBag)
295 union3 (a1,a2,a3) (b1,b2,b3)
296 = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
298 get_binders1 (TyD (TyData _ _ name tyvars _ _ _ _))
299 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
300 get_binders1 (TyD (TySynonym name tyvars _ _))
301 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
302 get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
303 = (listToBag tyvars `unionBags` sigs_tvs sigs,
304 emptyBag, unitBag (name, length tyvars))
306 sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
308 sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
309 pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
310 pty_tvs other = emptyBag
315 typeCycleErr syn_cycles
316 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
318 classCycleErr cls_cycles
319 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
323 4 (vcat (map pp_decl decls))
326 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
328 name = hsDeclName decl