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 ( TyClDecl(..), HsTyVarBndr,
15 ConDecl(..), Sig(..), HsPred(..),
16 tyClDeclName, hsTyVarNames,
17 isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
19 import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
20 import BasicTypes ( RecFlag(..), NewOrData(..), isRec )
21 import HscTypes ( implicitTyThingIds )
24 import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
25 tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
26 import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
27 import TcClassDcl ( tcClassDecl1 )
28 import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
29 import TcType ( TcKind, newKindVar, zonkKindEnv )
31 import TcUnify ( unifyKind )
32 import TcInstDcls ( tcAddDeclCtxt )
33 import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
34 import Variance ( calcTyConArgVrcs )
35 import Class ( Class, mkClass, classTyCon )
36 import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
37 mkSynTyCon, mkAlgTyCon, mkClassTyCon )
38 import DataCon ( isNullaryDataCon )
39 import Var ( varName )
41 import Digraph ( stronglyConnComp, SCC(..) )
42 import Name ( Name, getSrcLoc, isTyVarName )
43 import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF )
46 import Maybes ( mapMaybe )
47 import ErrUtils ( Message )
48 import HsDecls ( getClassDeclSysNames )
49 import Generics ( mkTyConGenInfo )
53 %************************************************************************
55 \subsection{Type checking for type and class declarations}
57 %************************************************************************
62 tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
66 tcTyAndClassDecls unf_env decls
67 = sortByDependency decls `thenTc` \ groups ->
68 tcGroups unf_env groups
71 = tcGetEnv `thenNF_Tc` \ env ->
74 tcGroups unf_env (group:groups)
75 = tcGroup unf_env group `thenTc` \ env ->
77 tcGroups unf_env groups
82 Consider a mutually-recursive group, binding
83 a type constructor T and a class C.
85 Step 1: getInitialKind
86 Construct a KindEnv by binding T and C to a kind variable
89 In that environment, do a kind check
91 Step 3: Zonk the kinds
93 Step 4: buildTyConOrClass
94 Construct an environment binding T to a TyCon and C to a Class.
95 a) Their kinds comes from zonking the relevant kind variable
96 b) Their arity (for synonyms) comes direct from the decl
97 c) The funcional dependencies come from the decl
98 d) The rest comes a knot-tied binding of T and C, returned from Step 4
99 e) The variances of the tycons in the group is calculated from
103 In this environment, walk over the decls, constructing the TyCons and Classes.
104 This uses in a strict way items (a)-(c) above, which is why they must
105 be constructed in Step 4. Feed the results back to Step 4.
106 For this step, pass the is-recursive flag as the wimp-out flag
110 Step 6: tcTyClDecl1 again
111 For a recursive group only, check all the decls again, just
112 but this time with the wimp flag off. Now we can check things
113 like whether a function argument is an unboxed tuple, looking
114 through type synonyms properly. We can't do that in Step 5.
116 Step 7: Extend environment
117 We extend the type environment with bindings not only for the TyCons and Classes,
118 but also for their "implicit Ids" like data constructors and class selectors
120 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
121 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
124 tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
126 = getDOptsTc `thenTc` \ dflags ->
128 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
131 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
134 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
137 fixTc ( \ ~(rec_details_list, _, _) ->
140 kind_env = mkNameEnv final_kinds
141 rec_details = mkNameEnv rec_details_list
143 tyclss, all_tyclss :: [TyThing]
144 tyclss = map (buildTyConOrClass dflags is_rec kind_env
145 rec_vrcs rec_details) decls
147 -- Add the tycons that come from the classes
148 -- We want them in the environment because
149 -- they are mentioned in interface files
150 all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
153 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
154 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
157 tcExtendGlobalEnv all_tyclss $
158 mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details ->
161 tcGetEnv `thenNF_Tc` \ env ->
162 returnTc (tycls_details, all_tyclss, env)
163 ) `thenTc` \ (_, all_tyclss, env) ->
168 -- For a recursive group, check all the types again,
169 -- this time with the wimp flag off
170 (if isRec is_rec then
171 mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
177 -- Extend the environment with the final TyCons/Classes
178 -- and their implicit Ids
179 tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
183 AcyclicSCC _ -> NonRecursive
184 CyclicSCC _ -> Recursive
187 AcyclicSCC decl -> [decl]
188 CyclicSCC decls -> decls
190 tcTyClDecl1 is_rec unf_env decl
191 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
192 | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec unf_env decl)
196 %************************************************************************
198 \subsection{Step 1: Initial environment}
200 %************************************************************************
203 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
204 getInitialKind (TySynonym name tyvars _ _)
205 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
206 newKindVar `thenNF_Tc` \ result_kind ->
207 returnNF_Tc (name, mk_kind arg_kinds result_kind)
209 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
210 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
211 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
213 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
214 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
215 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
217 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
221 %************************************************************************
223 \subsection{Step 2: Kind checking}
225 %************************************************************************
227 We need to kind check all types in the mutually recursive group
228 before we know the kind of the type variables. For example:
231 op :: D b => a -> b -> b
234 bop :: (Monad c) => ...
236 Here, the kind of the locally-polymorphic type variable "b"
237 depends on *all the uses of class D*. For example, the use of
238 Monad c in bop's type signature means that D must have kind Type->Type.
241 kcTyClDecl :: RenamedTyClDecl -> TcM ()
243 kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
244 = tcAddDeclCtxt decl $
245 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
246 kcHsType rhs `thenTc` \ rhs_kind ->
247 unifyKind result_kind rhs_kind
249 kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _)
250 = tcAddDeclCtxt decl $
251 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
252 kcHsContext context `thenTc_`
253 mapTc_ kc_con_decl con_decls
255 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
257 kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
258 tcExtendKindEnv kind_env $
259 kcConDetails new_or_data ex_ctxt details
261 kcTyClDecl decl@(ClassDecl context class_name
262 hs_tyvars fundeps class_sigs
264 = tcAddDeclCtxt decl $
265 kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
266 kcHsContext context `thenTc_`
267 mapTc_ kc_sig (filter isClassOpSig class_sigs)
269 kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
271 kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
272 -> (Kind -> TcM a) -- Thing inside
274 -- Extend the env with bindings for the tyvars, taken from
275 -- the kind of the tycon/class. Give it to the thing inside, and
276 -- check the result kind matches
277 kcTyClDeclBody tc_name hs_tyvars thing_inside
278 = tcLookup tc_name `thenNF_Tc` \ thing ->
281 AGlobal (ATyCon tc) -> tyConKind tc
282 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
284 -- For some odd reason, a class doesn't include its kind
286 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
288 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
292 %************************************************************************
294 \subsection{Step 4: Building the tycon/class}
296 %************************************************************************
301 -> RecFlag -> NameEnv Kind
302 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
303 -> RenamedTyClDecl -> TyThing
305 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
306 (TySynonym tycon_name tyvar_names rhs src_loc)
309 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
310 tycon_kind = lookupNameEnv_NF kenv tycon_name
311 arity = length tyvar_names
312 tyvars = mkTyClTyVars tycon_kind tyvar_names
313 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
314 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
316 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
317 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
320 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
321 data_cons nconstrs sel_ids
322 flavour is_rec gen_info
324 gen_info | not (dopt Opt_Generics dflags) = Nothing
325 | otherwise = mkTyConGenInfo tycon name1 name2
327 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
329 tycon_kind = lookupNameEnv_NF kenv tycon_name
330 tyvars = mkTyClTyVars tycon_kind tyvar_names
331 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
333 flavour = case data_or_new of
334 NewType -> NewTyCon (mkNewTyConRep tycon)
335 DataType | all isNullaryDataCon data_cons -> EnumTyCon
336 | otherwise -> DataTyCon
338 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
339 (ClassDecl context class_name
340 tyvar_names fundeps class_sigs def_methods
344 (tycon_name, _, _, _) = getClassDeclSysNames name_list
345 clas = mkClass class_name tyvars fds
346 sc_theta sc_sel_ids op_items
349 tycon = mkClassTyCon tycon_name class_kind tyvars
351 clas -- Yes! It's a dictionary
354 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
356 class_kind = lookupNameEnv_NF kenv class_name
357 tyvars = mkTyClTyVars class_kind tyvar_names
358 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
359 n_fields = length sc_sel_ids + length op_items
361 flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
362 | otherwise = DataTyCon
364 -- We can find the functional dependencies right away,
365 -- and it is vital to do so. Why? Because in the next pass
366 -- we check for ambiguity in all the type signatures, and we
367 -- need the functional dependcies to be done by then
368 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
369 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
370 lookup = lookupNameEnv_NF tyvar_env
372 bogusVrcs = panic "Bogus tycon arg variances"
376 %************************************************************************
378 \subsection{Dependency analysis}
380 %************************************************************************
385 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
386 sortByDependency decls
387 = let -- CHECK FOR CLASS CYCLES
388 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
389 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
391 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
393 let -- CHECK FOR SYNONYM CYCLES
394 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
395 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
398 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
400 -- DO THE MAIN DEPENDENCY ANALYSIS
402 decl_sccs = stronglyConnComp edges
406 tycl_decls = filter (not . isIfaceSigDecl) decls
407 edges = map mkEdges tycl_decls
409 is_syn_decl (d, _, _) = isSynDecl d
412 Edges in Type/Class decls
413 ~~~~~~~~~~~~~~~~~~~~~~~~~
416 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
417 -- Find the free non-tyvar vars
418 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
420 add n fvs | isTyVarName n = fvs
421 | otherwise = n : fvs
423 ----------------------------------------------------
424 -- mk_cls_edges looks only at the context of class decls
425 -- Its used when we are figuring out if there's a cycle in the
426 -- superclass hierarchy
428 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
430 mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
431 mkClassEdges other_decl = Nothing
433 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
434 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
438 %************************************************************************
440 \subsection{Error management
442 %************************************************************************
445 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
447 typeCycleErr syn_cycles
448 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
450 classCycleErr cls_cycles
451 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
455 4 (vcat (map pp_decl decls))
458 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
460 name = tyClDeclName decl