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(..),
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, 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)
205 = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds ->
206 newKindVar `thenNF_Tc` \ result_kind ->
207 returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
209 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
213 %************************************************************************
215 \subsection{Step 2: Kind checking}
217 %************************************************************************
219 We need to kind check all types in the mutually recursive group
220 before we know the kind of the type variables. For example:
223 op :: D b => a -> b -> b
226 bop :: (Monad c) => ...
228 Here, the kind of the locally-polymorphic type variable "b"
229 depends on *all the uses of class D*. For example, the use of
230 Monad c in bop's type signature means that D must have kind Type->Type.
233 kcTyClDecl :: RenamedTyClDecl -> TcM ()
235 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
236 = kcTyClDeclBody decl $ \ result_kind ->
237 kcHsType rhs `thenTc` \ rhs_kind ->
238 unifyKind result_kind rhs_kind
240 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
241 = kcTyClDeclBody decl $ \ result_kind ->
242 kcHsContext context `thenTc_`
243 mapTc_ kc_con_decl con_decls
245 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
246 = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
247 tcExtendKindEnv kind_env $
248 kcConDetails new_or_data ex_ctxt details
250 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
251 = kcTyClDeclBody decl $ \ result_kind ->
252 kcHsContext context `thenTc_`
253 mapTc_ kc_sig (filter isClassOpSig class_sigs)
255 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsBoxedSigType op_ty
257 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
258 -- Extend the env with bindings for the tyvars, taken from
259 -- the kind of the tycon/class. Give it to the thing inside, and
260 -- check the result kind matches
261 kcTyClDeclBody decl thing_inside
262 = tcAddDeclCtxt decl $
263 tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
266 AGlobal (ATyCon tc) -> tyConKind tc
267 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
269 -- For some odd reason, a class doesn't include its kind
271 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tcdTyVars decl)) kind
273 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
277 %************************************************************************
279 \subsection{Step 4: Building the tycon/class}
281 %************************************************************************
286 -> RecFlag -> NameEnv Kind
287 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
288 -> RenamedTyClDecl -> TyThing
290 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
291 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
294 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
295 tycon_kind = lookupNameEnv_NF kenv tycon_name
296 arity = length tyvar_names
297 tyvars = mkTyClTyVars tycon_kind tyvar_names
298 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
299 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
301 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
302 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
303 tcdNCons = nconstrs, tcdSysNames = sys_names})
306 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
307 data_cons nconstrs sel_ids
308 flavour is_rec gen_info
310 gen_info | not (dopt Opt_Generics dflags) = Nothing
311 | otherwise = mkTyConGenInfo tycon sys_names
313 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
315 tycon_kind = lookupNameEnv_NF kenv tycon_name
316 tyvars = mkTyClTyVars tycon_kind tyvar_names
317 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
319 flavour = case data_or_new of
320 NewType -> NewTyCon (mkNewTyConRep tycon)
321 DataType | all isNullaryDataCon data_cons -> EnumTyCon
322 | otherwise -> DataTyCon
324 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
325 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
326 tcdFDs = fundeps, tcdSysNames = name_list} )
329 (tycon_name, _, _, _) = getClassDeclSysNames name_list
330 clas = mkClass class_name tyvars fds
331 sc_theta sc_sel_ids op_items
334 tycon = mkClassTyCon tycon_name class_kind tyvars
336 clas -- Yes! It's a dictionary
339 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
341 class_kind = lookupNameEnv_NF kenv class_name
342 tyvars = mkTyClTyVars class_kind tyvar_names
343 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
344 n_fields = length sc_sel_ids + length op_items
346 flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
347 | otherwise = DataTyCon
349 -- We can find the functional dependencies right away,
350 -- and it is vital to do so. Why? Because in the next pass
351 -- we check for ambiguity in all the type signatures, and we
352 -- need the functional dependcies to be done by then
353 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
354 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
355 lookup = lookupNameEnv_NF tyvar_env
357 bogusVrcs = panic "Bogus tycon arg variances"
361 %************************************************************************
363 \subsection{Dependency analysis}
365 %************************************************************************
370 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
371 sortByDependency decls
372 = let -- CHECK FOR CLASS CYCLES
373 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
374 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
376 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
378 let -- CHECK FOR SYNONYM CYCLES
379 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
380 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
383 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
385 -- DO THE MAIN DEPENDENCY ANALYSIS
387 decl_sccs = stronglyConnComp edges
391 tycl_decls = filter (not . isIfaceSigDecl) decls
392 edges = map mkEdges tycl_decls
394 is_syn_decl (d, _, _) = isSynDecl d
397 Edges in Type/Class decls
398 ~~~~~~~~~~~~~~~~~~~~~~~~~
401 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
402 -- Find the free non-tyvar vars
403 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
405 add n fvs | isTyVarName n = fvs
406 | otherwise = n : fvs
408 ----------------------------------------------------
409 -- mk_cls_edges looks only at the context of class decls
410 -- Its used when we are figuring out if there's a cycle in the
411 -- superclass hierarchy
413 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
415 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt])
416 mkClassEdges other_decl = Nothing
418 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
419 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
423 %************************************************************************
425 \subsection{Error management
427 %************************************************************************
430 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
432 typeCycleErr syn_cycles
433 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
435 classCycleErr cls_cycles
436 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
440 4 (vcat (map pp_decl decls))
443 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
445 name = tyClDeclName decl