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(..), TyClDecl(..),
14 HsType(..), HsTyVarBndr,
15 ConDecl(..), ConDetails(..), BangType(..),
16 Sig(..), HsPred(..), HsTupCon(..),
17 tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
19 import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
20 import BasicTypes ( RecFlag(..), NewOrData(..), Arity )
23 import TcEnv ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
24 tcExtendTypeEnv, tcExtendKindEnv, tcLookupTy
26 import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
27 import TcClassDcl ( tcClassDecl1 )
28 import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
29 import TcType ( TcKind, newKindVar, newKindVars, zonkKindEnv )
31 import TcUnify ( unifyKind )
32 import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
33 import Variance ( calcTyConArgVrcs )
34 import Class ( Class, mkClass, classTyCon )
35 import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon )
36 import DataCon ( isNullaryDataCon )
37 import Var ( TyVar, tyVarKind, varName )
41 import Digraph ( stronglyConnComp, SCC(..) )
42 import Name ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
43 mkNameEnv, lookupNameEnv_NF
46 import Maybes ( mapMaybe, catMaybes )
47 import UniqSet ( UniqSet, emptyUniqSet,
48 unitUniqSet, unionUniqSets,
49 unionManyUniqSets, uniqSetToList )
50 import ErrUtils ( Message )
51 import Unique ( Unique, Uniquable(..) )
55 %************************************************************************
57 \subsection{Type checking for type and class declarations}
59 %************************************************************************
64 tcTyAndClassDecls :: ValueEnv -- Knot tying stuff
68 tcTyAndClassDecls unf_env decls
69 = sortByDependency decls `thenTc` \ groups ->
70 tcGroups unf_env groups
73 = tcGetEnv `thenNF_Tc` \ env ->
76 tcGroups unf_env (group:groups)
77 = tcGroup unf_env group `thenTc` \ env ->
79 tcGroups unf_env groups
85 Consider a mutually-recursive group, binding
86 a type constructor T and a class C.
88 Step 1: getInitialKind
89 Construct a KindEnv by binding T and C to a kind variable
92 In that environment, do a kind check
94 Step 3: Zonk the kinds
96 Step 4: buildTyConOrClass
97 Construct an environment binding T to a TyCon and C to a Class.
98 a) Their kinds comes from zonking the relevant kind variable
99 b) Their arity (for synonyms) comes direct from the decl
100 c) The funcional dependencies come from the decl
101 d) The rest comes a knot-tied binding of T and C, returned from Step 4
102 e) The variances of the tycons in the group is calculated from
106 In this environment, walk over the decls, constructing the TyCons and Classes.
107 This uses in a strict way items (a)-(c) above, which is why they must
108 be constructed in Step 4.
109 Feed the results back to Step 4.
111 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
112 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
115 tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM s TcEnv
118 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
121 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
124 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
127 fixTc ( \ ~(rec_details_list, _) ->
130 kind_env = mkNameEnv final_kinds
131 rec_details = mkNameEnv rec_details_list
133 tyclss, all_tyclss :: [(Name, TyThing)]
134 tyclss = map (buildTyConOrClass is_rec kind_env rec_vrcs rec_details) decls
136 -- Add the tycons that come from the classes
137 -- We want them in the environment because
138 -- they are mentioned in interface files
139 all_tyclss = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
140 let tycon = classTyCon clas
143 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
144 rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
147 tcExtendTypeEnv all_tyclss $
148 mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
149 tcGetEnv `thenNF_Tc` \ env ->
150 returnTc (tycls_details, env)
151 ) `thenTc` \ (_, env) ->
155 AcyclicSCC _ -> NonRecursive
156 CyclicSCC _ -> Recursive
159 AcyclicSCC decl -> [decl]
160 CyclicSCC decls -> decls
162 tcTyClDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails)
164 tcTyClDecl1 unf_env decl
165 | isClassDecl decl = tcClassDecl1 unf_env decl
166 | otherwise = tcTyDecl1 decl
170 %************************************************************************
172 \subsection{Step 1: Initial environment}
174 %************************************************************************
177 getInitialKind :: RenamedTyClDecl -> NF_TcM s (Name, TcKind)
178 getInitialKind (TySynonym name tyvars _ _)
179 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
180 newKindVar `thenNF_Tc` \ result_kind ->
181 returnNF_Tc (name, mk_kind arg_kinds result_kind)
183 getInitialKind (TyData _ _ name tyvars _ _ _ _ _)
184 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
185 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
187 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
188 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
189 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
191 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
195 %************************************************************************
197 \subsection{Step 2: Kind checking}
199 %************************************************************************
201 We need to kind check all types in the mutually recursive group
202 before we know the kind of the type variables. For example:
205 op :: D b => a -> b -> b
208 bop :: (Monad c) => ...
210 Here, the kind of the locally-polymorphic type variable "b"
211 depends on *all the uses of class D*. For example, the use of
212 Monad c in bop's type signature means that D must have kind Type->Type.
215 kcTyClDecl :: RenamedTyClDecl -> TcM s ()
217 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
218 = tcAddDeclCtxt decl $
219 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
220 kcHsType rhs `thenTc` \ rhs_kind ->
221 unifyKind result_kind rhs_kind
223 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc)
224 = tcAddDeclCtxt decl $
225 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
226 kcHsContext context `thenTc_`
227 mapTc_ kc_con_decl con_decls
229 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
231 kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
232 tcExtendKindEnv kind_env $
233 kcConDetails ex_ctxt details
235 kcTyClDecl decl@(ClassDecl context class_name
236 hs_tyvars fundeps class_sigs
238 = tcAddDeclCtxt decl $
239 kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
240 kcHsContext context `thenTc_`
241 mapTc_ kc_sig (filter isClassOpSig class_sigs)
243 kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
245 kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
246 -> (Kind -> TcM s a) -- Thing inside
248 -- Extend the env with bindings for the tyvars, taken from
249 -- the kind of the tycon/class. Give it to the thing inside, and
250 -- check the result kind matches
251 kcTyClDeclBody tc_name hs_tyvars thing_inside
252 = tcLookupTy tc_name `thenNF_Tc` \ tc ->
254 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) (tyThingKind tc)
256 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
260 %************************************************************************
262 \subsection{Step 4: Building the tycon/class}
264 %************************************************************************
268 :: RecFlag -> NameEnv Kind
269 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
270 -> RenamedTyClDecl -> (Name, TyThing)
271 -- Can't fail; the only reason it's in the monad
272 -- is so it can zonk the kinds
274 buildTyConOrClass is_rec kenv rec_vrcs rec_details
275 (TySynonym tycon_name tyvar_names rhs src_loc)
276 = (tycon_name, ATyCon tycon)
278 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
279 tycon_kind = lookupNameEnv_NF kenv tycon_name
280 arity = length tyvar_names
281 tyvars = mkTyClTyVars tycon_kind tyvar_names
282 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
283 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
285 buildTyConOrClass is_rec kenv rec_vrcs rec_details
286 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc)
287 = (tycon_name, ATyCon tycon)
289 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
294 DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
296 tycon_kind = lookupNameEnv_NF kenv tycon_name
297 tyvars = mkTyClTyVars tycon_kind tyvar_names
298 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
300 flavour = case data_or_new of
301 NewType -> NewTyCon (mkNewTyConRep tycon)
302 DataType | all isNullaryDataCon data_cons -> EnumTyCon
303 | otherwise -> DataTyCon
305 buildTyConOrClass is_rec kenv rec_vrcs rec_details
306 (ClassDecl context class_name
307 tyvar_names fundeps class_sigs def_methods pragmas
308 tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
309 = (class_name, AClass clas)
311 clas = mkClass class_name tyvars fds
312 sc_theta sc_sel_ids op_items
315 tycon = mkClassTyCon tycon_name class_kind tyvars
317 clas -- Yes! It's a dictionary
320 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
322 class_kind = lookupNameEnv_NF kenv class_name
323 tyvars = mkTyClTyVars class_kind tyvar_names
324 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
325 n_fields = length sc_sel_ids + length op_items
327 flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
328 | otherwise = DataTyCon
330 -- We can find the functional dependencies right away,
331 -- and it is vital to do so. Why? Because in the next pass
332 -- we check for ambiguity in all the type signatures, and we
333 -- need the functional dependcies to be done by then
334 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
335 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
336 lookup = lookupNameEnv_NF tyvar_env
338 bogusVrcs = panic "Bogus tycon arg variances"
342 %************************************************************************
344 \subsection{Dependency analysis}
346 %************************************************************************
351 sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedTyClDecl]
352 sortByDependency decls
353 = let -- CHECK FOR CLASS CYCLES
354 cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
355 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
357 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
359 let -- CHECK FOR SYNONYM CYCLES
360 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
361 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
364 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
366 -- DO THE MAIN DEPENDENCY ANALYSIS
368 decl_sccs = stronglyConnComp edges
372 tycl_decls = [d | TyClD d <- decls]
373 edges = map mk_edges tycl_decls
375 is_syn_decl (d, _, _) = isSynDecl d
378 Edges in Type/Class decls
379 ~~~~~~~~~~~~~~~~~~~~~~~~~
382 ----------------------------------------------------
383 -- mk_cls_edges looks only at the context of class decls
384 -- Its used when we are figuring out if there's a cycle in the
385 -- superclass hierarchy
387 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
389 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
390 = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
391 mk_cls_edges other_decl
394 ----------------------------------------------------
395 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
397 mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
398 = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
399 get_cons condecls `unionUniqSets`
402 mk_edges decl@(TySynonym name _ rhs _)
403 = (decl, getUnique name, uniqSetToList (get_ty rhs))
405 mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
406 = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
410 ----------------------------------------------------
411 get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
412 get_clas (HsPClass clas _) = Just clas
415 ----------------------------------------------------
416 get_deriv Nothing = emptyUniqSet
417 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
419 ----------------------------------------------------
420 get_cons cons = unionManyUniqSets (map get_con cons)
422 ----------------------------------------------------
423 get_con (ConDecl _ _ _ ctxt details _)
424 = get_ctxt ctxt `unionUniqSets` get_con_details details
426 ----------------------------------------------------
427 get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
428 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
429 get_con_details (NewCon ty _) = get_ty ty
430 get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
432 ----------------------------------------------------
433 get_bty bty = get_ty (getBangType bty)
435 ----------------------------------------------------
436 get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
437 | otherwise = set_name name
438 get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
439 get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
440 get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty
441 get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
442 get_ty (HsUsgTy _ ty) = get_ty ty
443 get_ty (HsUsgForAllTy _ ty) = get_ty ty
444 get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty
445 get_ty (HsPredTy (HsPClass name _)) = set_name name
446 get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think
448 ----------------------------------------------------
449 get_tys tys = unionManyUniqSets (map get_ty tys)
451 ----------------------------------------------------
453 = unionManyUniqSets (map get_sig sigs)
455 get_sig (ClassOpSig _ _ ty _) = get_ty ty
456 get_sig (FixSig _) = emptyUniqSet
457 get_sig other = panic "TcTyClsDecls:get_sig"
459 ----------------------------------------------------
460 set_name name = unitUniqSet (getUnique name)
461 set_to_bag set = listToBag (uniqSetToList set)
465 %************************************************************************
467 \subsection{Error management
469 %************************************************************************
472 tcAddDeclCtxt decl thing_inside
479 (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
480 (TySynonym name _ _ loc) -> (name, loc, "type synonym")
481 (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "data type")
482 (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "newtype")
484 ctxt = hsep [ptext SLIT("In the"), text thing,
485 ptext SLIT("declaration for"), quotes (ppr name)]
489 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
491 typeCycleErr syn_cycles
492 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
494 classCycleErr cls_cycles
495 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
499 4 (vcat (map pp_decl decls))
502 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
504 name = tyClDeclName decl