2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcTyClsDecls]{Typecheck type and class declarations}
11 #include "HsVersions.h"
13 import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
14 import HsSyn ( HsDecl(..), TyClDecl(..),
18 tyClDeclName, hsTyVarNames,
19 isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
21 import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs )
22 import BasicTypes ( RecFlag(..), NewOrData(..) )
25 import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
26 tcExtendKindEnv, tcLookup, tcExtendGlobalEnv )
27 import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
28 import TcClassDcl ( tcClassDecl1 )
29 import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
30 import TcType ( TcKind, newKindVar, zonkKindEnv )
32 import TcUnify ( unifyKind )
33 import TcInstDcls ( tcAddDeclCtxt )
34 import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
35 import Variance ( calcTyConArgVrcs )
36 import Class ( Class, mkClass, classTyCon )
37 import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
38 mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
39 import DataCon ( isNullaryDataCon )
40 import Var ( varName )
42 import Digraph ( stronglyConnComp, SCC(..) )
43 import Name ( Name, NamedThing(..), getSrcLoc, isTyVarName )
44 import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF )
47 import Maybes ( mapMaybe )
48 import ErrUtils ( Message )
49 import HsDecls ( getClassDeclSysNames )
50 import Generics ( mkTyConGenInfo )
54 %************************************************************************
56 \subsection{Type checking for type and class declarations}
58 %************************************************************************
63 tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
67 tcTyAndClassDecls unf_env decls
68 = sortByDependency decls `thenTc` \ groups ->
69 tcGroups unf_env groups
72 = tcGetEnv `thenNF_Tc` \ env ->
75 tcGroups unf_env (group:groups)
76 = tcGroup unf_env group `thenTc` \ env ->
78 tcGroups unf_env groups
83 Consider a mutually-recursive group, binding
84 a type constructor T and a class C.
86 Step 1: getInitialKind
87 Construct a KindEnv by binding T and C to a kind variable
90 In that environment, do a kind check
92 Step 3: Zonk the kinds
94 Step 4: buildTyConOrClass
95 Construct an environment binding T to a TyCon and C to a Class.
96 a) Their kinds comes from zonking the relevant kind variable
97 b) Their arity (for synonyms) comes direct from the decl
98 c) The funcional dependencies come from the decl
99 d) The rest comes a knot-tied binding of T and C, returned from Step 4
100 e) The variances of the tycons in the group is calculated from
104 In this environment, walk over the decls, constructing the TyCons and Classes.
105 This uses in a strict way items (a)-(c) above, which is why they must
106 be constructed in Step 4.
107 Feed the results back to Step 4.
109 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
110 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
113 tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
115 = getDOptsTc `thenTc` \ dflags ->
117 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
120 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
123 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
126 fixTc ( \ ~(rec_details_list, _) ->
129 kind_env = mkNameEnv final_kinds
130 rec_details = mkNameEnv rec_details_list
132 tyclss, all_tyclss :: [(Name, TyThing)]
133 tyclss = map (buildTyConOrClass dflags is_rec kind_env
134 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 tcExtendGlobalEnv 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 unf_env decl
163 = tcAddDeclCtxt decl $
164 if isClassDecl decl then
165 tcClassDecl1 unf_env decl
171 %************************************************************************
173 \subsection{Step 1: Initial environment}
175 %************************************************************************
178 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
179 getInitialKind (TySynonym name tyvars _ _)
180 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
181 newKindVar `thenNF_Tc` \ result_kind ->
182 returnNF_Tc (name, mk_kind arg_kinds result_kind)
184 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
185 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
186 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
188 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
189 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
190 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
192 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
196 %************************************************************************
198 \subsection{Step 2: Kind checking}
200 %************************************************************************
202 We need to kind check all types in the mutually recursive group
203 before we know the kind of the type variables. For example:
206 op :: D b => a -> b -> b
209 bop :: (Monad c) => ...
211 Here, the kind of the locally-polymorphic type variable "b"
212 depends on *all the uses of class D*. For example, the use of
213 Monad c in bop's type signature means that D must have kind Type->Type.
216 kcTyClDecl :: RenamedTyClDecl -> TcM ()
218 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
219 = tcAddDeclCtxt decl $
220 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
221 kcHsType rhs `thenTc` \ rhs_kind ->
222 unifyKind result_kind rhs_kind
224 kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ loc _ _)
225 = tcAddDeclCtxt decl $
226 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
227 kcHsContext context `thenTc_`
228 mapTc_ kc_con_decl con_decls
230 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
232 kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
233 tcExtendKindEnv kind_env $
234 kcConDetails ex_ctxt details
236 kcTyClDecl decl@(ClassDecl context class_name
237 hs_tyvars fundeps class_sigs
239 = tcAddDeclCtxt decl $
240 kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
241 kcHsContext context `thenTc_`
242 mapTc_ kc_sig (filter isClassOpSig class_sigs)
244 kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
246 kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
247 -> (Kind -> TcM a) -- Thing inside
249 -- Extend the env with bindings for the tyvars, taken from
250 -- the kind of the tycon/class. Give it to the thing inside, and
251 -- check the result kind matches
252 kcTyClDeclBody tc_name hs_tyvars thing_inside
253 = tcLookup tc_name `thenNF_Tc` \ thing ->
256 AGlobal (ATyCon tc) -> tyConKind tc
257 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
259 -- For some odd reason, a class doesn't include its kind
261 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
263 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
267 %************************************************************************
269 \subsection{Step 4: Building the tycon/class}
271 %************************************************************************
276 -> RecFlag -> NameEnv Kind
277 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
278 -> RenamedTyClDecl -> (Name, TyThing)
279 -- Can't fail; the only reason it's in the monad
280 -- is so it can zonk the kinds
282 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
283 (TySynonym tycon_name tyvar_names rhs src_loc)
284 = (tycon_name, ATyCon tycon)
286 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
287 tycon_kind = lookupNameEnv_NF kenv tycon_name
288 arity = length tyvar_names
289 tyvars = mkTyClTyVars tycon_kind tyvar_names
290 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
291 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
293 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
294 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
295 = (tycon_name, ATyCon tycon)
297 tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
299 flavour is_rec gen_info
301 gen_info | not (dopt Opt_Generics dflags) = Nothing
302 | otherwise = mkTyConGenInfo tycon name1 name2
304 DataTyDetails ctxt data_cons = 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 mkClassEdges 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, not (isIfaceSigDecl d)]
384 edges = map mkEdges tycl_decls
386 is_syn_decl (d, _, _) = isSynDecl d
389 Edges in Type/Class decls
390 ~~~~~~~~~~~~~~~~~~~~~~~~~
393 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
394 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
396 add n fvs | isTyVarName n = fvs
397 | otherwise = n : fvs
399 ----------------------------------------------------
400 -- mk_cls_edges looks only at the context of class decls
401 -- Its used when we are figuring out if there's a cycle in the
402 -- superclass hierarchy
404 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
406 mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
407 mkClassEdges other_decl = Nothing
409 ----------------------------------------------------
410 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
411 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
415 %************************************************************************
417 \subsection{Error management
419 %************************************************************************
422 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
424 typeCycleErr syn_cycles
425 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
427 classCycleErr cls_cycles
428 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
432 4 (vcat (map pp_decl decls))
435 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
437 name = tyClDeclName decl