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(..),
16 Sig(..), HsPred(..), HsTupCon(..),
17 tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
19 import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
20 import BasicTypes ( RecFlag(..), NewOrData(..) )
23 import TcEnv ( TcEnv, TyThing(..), TyThingDetails(..),
24 tcExtendKindEnv, tcLookupGlobal, tcExtendGlobalEnv )
25 import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
26 import TcClassDcl ( tcClassDecl1 )
27 import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
28 import TcType ( TcKind, newKindVar, zonkKindEnv )
30 import TcUnify ( unifyKind )
31 import TcInstDcls ( tcAddDeclCtxt )
32 import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
33 import Variance ( calcTyConArgVrcs )
34 import Class ( Class, mkClass, classTyCon )
35 import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
36 mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
37 import DataCon ( isNullaryDataCon )
38 import Var ( varName )
40 import Digraph ( stronglyConnComp, SCC(..) )
41 import Name ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
42 mkNameEnv, lookupNameEnv_NF
45 import Maybes ( mapMaybe, catMaybes )
46 import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets,
47 unionManyUniqSets, uniqSetToList )
48 import ErrUtils ( Message )
49 import Unique ( Unique, Uniquable(..) )
50 import HsDecls ( getClassDeclSysNames )
51 import Generics ( mkTyConGenInfo )
52 import CmdLineOpts ( DynFlags )
56 %************************************************************************
58 \subsection{Type checking for type and class declarations}
60 %************************************************************************
65 tcTyAndClassDecls :: TcEnv -- Knot tying stuff
69 tcTyAndClassDecls unf_env decls
70 = sortByDependency decls `thenTc` \ groups ->
71 tcGroups unf_env groups
74 = tcGetEnv `thenNF_Tc` \ env ->
77 tcGroups unf_env (group:groups)
78 = tcGroup unf_env group `thenTc` \ env ->
80 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 :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
117 = getDOptsTc `thenTc` \ dflags ->
119 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
122 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
125 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
128 fixTc ( \ ~(rec_details_list, _) ->
131 kind_env = mkNameEnv final_kinds
132 rec_details = mkNameEnv rec_details_list
134 tyclss, all_tyclss :: [(Name, TyThing)]
135 tyclss = map (buildTyConOrClass dflags is_rec kind_env
136 rec_vrcs rec_details) decls
138 -- Add the tycons that come from the classes
139 -- We want them in the environment because
140 -- they are mentioned in interface files
141 all_tyclss = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
142 let tycon = classTyCon clas
145 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
146 rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
149 tcExtendGlobalEnv all_tyclss $
150 mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
151 tcGetEnv `thenNF_Tc` \ env ->
152 returnTc (tycls_details, env)
153 ) `thenTc` \ (_, env) ->
157 AcyclicSCC _ -> NonRecursive
158 CyclicSCC _ -> Recursive
161 AcyclicSCC decl -> [decl]
162 CyclicSCC decls -> decls
164 tcTyClDecl1 unf_env decl
165 = tcAddDeclCtxt decl $
166 if isClassDecl decl then
167 tcClassDecl1 unf_env decl
173 %************************************************************************
175 \subsection{Step 1: Initial environment}
177 %************************************************************************
180 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
181 getInitialKind (TySynonym name tyvars _ _)
182 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
183 newKindVar `thenNF_Tc` \ result_kind ->
184 returnNF_Tc (name, mk_kind arg_kinds result_kind)
186 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
187 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
188 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
190 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
191 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
192 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
194 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
198 %************************************************************************
200 \subsection{Step 2: Kind checking}
202 %************************************************************************
204 We need to kind check all types in the mutually recursive group
205 before we know the kind of the type variables. For example:
208 op :: D b => a -> b -> b
211 bop :: (Monad c) => ...
213 Here, the kind of the locally-polymorphic type variable "b"
214 depends on *all the uses of class D*. For example, the use of
215 Monad c in bop's type signature means that D must have kind Type->Type.
218 kcTyClDecl :: RenamedTyClDecl -> TcM ()
220 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
221 = tcAddDeclCtxt decl $
222 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
223 kcHsType rhs `thenTc` \ rhs_kind ->
224 unifyKind result_kind rhs_kind
226 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _)
227 = tcAddDeclCtxt decl $
228 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
229 kcHsContext context `thenTc_`
230 mapTc_ kc_con_decl con_decls
232 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
234 kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
235 tcExtendKindEnv kind_env $
236 kcConDetails ex_ctxt details
238 kcTyClDecl decl@(ClassDecl context class_name
239 hs_tyvars fundeps class_sigs
241 = tcAddDeclCtxt decl $
242 kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
243 kcHsContext context `thenTc_`
244 mapTc_ kc_sig (filter isClassOpSig class_sigs)
246 kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
248 kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
249 -> (Kind -> TcM a) -- Thing inside
251 -- Extend the env with bindings for the tyvars, taken from
252 -- the kind of the tycon/class. Give it to the thing inside, and
253 -- check the result kind matches
254 kcTyClDeclBody tc_name hs_tyvars thing_inside
255 = tcLookupGlobal tc_name `thenNF_Tc` \ thing ->
258 ATyCon tc -> tyConKind tc
259 AClass cl -> tyConKind (classTyCon cl)
260 -- For some odd reason, a class doesn't include its kind
262 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
264 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
268 %************************************************************************
270 \subsection{Step 4: Building the tycon/class}
272 %************************************************************************
277 -> RecFlag -> NameEnv Kind
278 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
279 -> RenamedTyClDecl -> (Name, TyThing)
280 -- Can't fail; the only reason it's in the monad
281 -- is so it can zonk the kinds
283 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
284 (TySynonym tycon_name tyvar_names rhs src_loc)
285 = (tycon_name, ATyCon tycon)
287 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
288 tycon_kind = lookupNameEnv_NF kenv tycon_name
289 arity = length tyvar_names
290 tyvars = mkTyClTyVars tycon_kind tyvar_names
291 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
292 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
294 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
295 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
296 = (tycon_name, ATyCon tycon)
298 tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
301 flavour is_rec gen_info
302 gen_info = mkTyConGenInfo dflags tycon name1 name2
304 DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
306 tycon_kind = lookupNameEnv_NF kenv tycon_name
307 tyvars = mkTyClTyVars tycon_kind tyvar_names
308 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
310 flavour = case data_or_new of
311 NewType -> NewTyCon (mkNewTyConRep tycon)
312 DataType | all isNullaryDataCon data_cons -> EnumTyCon
313 | otherwise -> DataTyCon
315 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
316 (ClassDecl context class_name
317 tyvar_names fundeps class_sigs def_methods
319 = (class_name, AClass clas)
321 (tycon_name, _, _, _) = getClassDeclSysNames name_list
322 clas = mkClass class_name tyvars fds
323 sc_theta sc_sel_ids op_items
326 tycon = mkClassTyCon tycon_name class_kind tyvars
328 clas -- Yes! It's a dictionary
331 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
333 class_kind = lookupNameEnv_NF kenv class_name
334 tyvars = mkTyClTyVars class_kind tyvar_names
335 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
336 n_fields = length sc_sel_ids + length op_items
338 flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
339 | otherwise = DataTyCon
341 -- We can find the functional dependencies right away,
342 -- and it is vital to do so. Why? Because in the next pass
343 -- we check for ambiguity in all the type signatures, and we
344 -- need the functional dependcies to be done by then
345 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
346 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
347 lookup = lookupNameEnv_NF tyvar_env
349 bogusVrcs = panic "Bogus tycon arg variances"
353 %************************************************************************
355 \subsection{Dependency analysis}
357 %************************************************************************
362 sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
363 sortByDependency decls
364 = let -- CHECK FOR CLASS CYCLES
365 cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
366 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
368 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
370 let -- CHECK FOR SYNONYM CYCLES
371 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
372 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
375 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
377 -- DO THE MAIN DEPENDENCY ANALYSIS
379 decl_sccs = stronglyConnComp edges
383 tycl_decls = [d | TyClD d <- decls]
384 edges = map mk_edges tycl_decls
386 is_syn_decl (d, _, _) = isSynDecl d
389 Edges in Type/Class decls
390 ~~~~~~~~~~~~~~~~~~~~~~~~~
393 ----------------------------------------------------
394 -- mk_cls_edges looks only at the context of class decls
395 -- Its used when we are figuring out if there's a cycle in the
396 -- superclass hierarchy
398 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
400 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _)
401 = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
402 mk_cls_edges other_decl
405 ----------------------------------------------------
406 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
408 mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _)
409 = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
410 get_cons condecls `unionUniqSets`
413 mk_edges decl@(TySynonym name _ rhs _)
414 = (decl, getUnique name, uniqSetToList (get_ty rhs))
416 mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _)
417 = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
421 ----------------------------------------------------
422 get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
423 get_clas (HsPClass clas _) = Just clas
426 ----------------------------------------------------
427 get_deriv Nothing = emptyUniqSet
428 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
430 ----------------------------------------------------
431 get_cons cons = unionManyUniqSets (map get_con cons)
433 ----------------------------------------------------
434 get_con (ConDecl _ _ _ ctxt details _)
435 = get_ctxt ctxt `unionUniqSets` get_con_details details
437 ----------------------------------------------------
438 get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
439 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
440 get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
442 ----------------------------------------------------
443 get_bty bty = get_ty (getBangType bty)
445 ----------------------------------------------------
446 get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
447 | otherwise = set_name name
448 get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
449 get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
450 get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty
451 get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
452 get_ty (HsUsgTy _ ty) = get_ty ty
453 get_ty (HsUsgForAllTy _ ty) = get_ty ty
454 get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty
455 get_ty (HsPredTy (HsPClass name _)) = set_name name
456 get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think
458 ----------------------------------------------------
459 get_tys tys = unionManyUniqSets (map get_ty tys)
461 ----------------------------------------------------
463 = unionManyUniqSets (map get_sig sigs)
465 get_sig (ClassOpSig _ _ ty _) = get_ty ty
466 get_sig (FixSig _) = emptyUniqSet
467 get_sig other = panic "TcTyClsDecls:get_sig"
469 ----------------------------------------------------
470 set_name name = unitUniqSet (getUnique name)
474 %************************************************************************
476 \subsection{Error management
478 %************************************************************************
481 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
483 typeCycleErr syn_cycles
484 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
486 classCycleErr cls_cycles
487 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
491 4 (vcat (map pp_decl decls))
494 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
496 name = tyClDeclName decl