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(..), isRec )
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. Feed the results back to Step 4.
107 For this step, pass the is-recursive flag as the wimp-out flag
111 Step 6: tcTyClDecl1 again
112 For a recursive group only, check all the decls again, just
113 but this time with the wimp flag off. Now we can check things
114 like whether a function argument is an unboxed tuple, looking
115 through type synonyms properly. We can't do that in Step 5.
117 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
118 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
121 tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
123 = getDOptsTc `thenTc` \ dflags ->
125 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
128 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
131 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
134 fixTc ( \ ~(rec_details_list, _) ->
137 kind_env = mkNameEnv final_kinds
138 rec_details = mkNameEnv rec_details_list
140 tyclss, all_tyclss :: [(Name, TyThing)]
141 tyclss = map (buildTyConOrClass dflags is_rec kind_env
142 rec_vrcs rec_details) decls
144 -- Add the tycons that come from the classes
145 -- We want them in the environment because
146 -- they are mentioned in interface files
147 all_tyclss = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
148 let tycon = classTyCon clas
151 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
152 rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
155 tcExtendGlobalEnv all_tyclss $
156 mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details ->
159 tcGetEnv `thenNF_Tc` \ env ->
160 returnTc (tycls_details, env)
161 ) `thenTc` \ (_, env) ->
164 -- For a recursive group, check all the types again,
165 -- this time with the wimp flag off
166 (if isRec is_rec then
167 tcSetEnv env (mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls)
175 AcyclicSCC _ -> NonRecursive
176 CyclicSCC _ -> Recursive
179 AcyclicSCC decl -> [decl]
180 CyclicSCC decls -> decls
182 tcTyClDecl1 is_rec unf_env decl
183 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
184 | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec decl)
188 %************************************************************************
190 \subsection{Step 1: Initial environment}
192 %************************************************************************
195 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
196 getInitialKind (TySynonym name tyvars _ _)
197 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
198 newKindVar `thenNF_Tc` \ result_kind ->
199 returnNF_Tc (name, mk_kind arg_kinds result_kind)
201 getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
202 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
203 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
205 getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
206 = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
207 returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
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 tycon_name hs_tyvars rhs loc)
236 = tcAddDeclCtxt decl $
237 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
238 kcHsType rhs `thenTc` \ rhs_kind ->
239 unifyKind result_kind rhs_kind
241 kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _)
242 = tcAddDeclCtxt decl $
243 kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
244 kcHsContext context `thenTc_`
245 mapTc_ kc_con_decl con_decls
247 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
249 kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
250 tcExtendKindEnv kind_env $
251 kcConDetails new_or_data ex_ctxt details
253 kcTyClDecl decl@(ClassDecl context class_name
254 hs_tyvars fundeps class_sigs
256 = tcAddDeclCtxt decl $
257 kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
258 kcHsContext context `thenTc_`
259 mapTc_ kc_sig (filter isClassOpSig class_sigs)
261 kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
263 kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
264 -> (Kind -> TcM a) -- Thing inside
266 -- Extend the env with bindings for the tyvars, taken from
267 -- the kind of the tycon/class. Give it to the thing inside, and
268 -- check the result kind matches
269 kcTyClDeclBody tc_name hs_tyvars thing_inside
270 = tcLookup tc_name `thenNF_Tc` \ thing ->
273 AGlobal (ATyCon tc) -> tyConKind tc
274 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
276 -- For some odd reason, a class doesn't include its kind
278 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
280 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
284 %************************************************************************
286 \subsection{Step 4: Building the tycon/class}
288 %************************************************************************
293 -> RecFlag -> NameEnv Kind
294 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
295 -> RenamedTyClDecl -> (Name, TyThing)
296 -- Can't fail; the only reason it's in the monad
297 -- is so it can zonk the kinds
299 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
300 (TySynonym tycon_name tyvar_names rhs src_loc)
301 = (tycon_name, ATyCon tycon)
303 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
304 tycon_kind = lookupNameEnv_NF kenv tycon_name
305 arity = length tyvar_names
306 tyvars = mkTyClTyVars tycon_kind tyvar_names
307 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
308 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
310 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
311 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
312 = (tycon_name, ATyCon tycon)
314 tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
316 flavour is_rec gen_info
318 gen_info | not (dopt Opt_Generics dflags) = Nothing
319 | otherwise = mkTyConGenInfo tycon name1 name2
321 DataTyDetails ctxt data_cons = lookupNameEnv_NF rec_details tycon_name
323 tycon_kind = lookupNameEnv_NF kenv tycon_name
324 tyvars = mkTyClTyVars tycon_kind tyvar_names
325 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
327 flavour = case data_or_new of
328 NewType -> NewTyCon (mkNewTyConRep tycon)
329 DataType | all isNullaryDataCon data_cons -> EnumTyCon
330 | otherwise -> DataTyCon
332 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
333 (ClassDecl context class_name
334 tyvar_names fundeps class_sigs def_methods
336 = (class_name, AClass clas)
338 (tycon_name, _, _, _) = getClassDeclSysNames name_list
339 clas = mkClass class_name tyvars fds
340 sc_theta sc_sel_ids op_items
343 tycon = mkClassTyCon tycon_name class_kind tyvars
345 clas -- Yes! It's a dictionary
348 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
350 class_kind = lookupNameEnv_NF kenv class_name
351 tyvars = mkTyClTyVars class_kind tyvar_names
352 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
353 n_fields = length sc_sel_ids + length op_items
355 flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
356 | otherwise = DataTyCon
358 -- We can find the functional dependencies right away,
359 -- and it is vital to do so. Why? Because in the next pass
360 -- we check for ambiguity in all the type signatures, and we
361 -- need the functional dependcies to be done by then
362 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
363 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
364 lookup = lookupNameEnv_NF tyvar_env
366 bogusVrcs = panic "Bogus tycon arg variances"
370 %************************************************************************
372 \subsection{Dependency analysis}
374 %************************************************************************
379 sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
380 sortByDependency decls
381 = let -- CHECK FOR CLASS CYCLES
382 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
383 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
385 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
387 let -- CHECK FOR SYNONYM CYCLES
388 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
389 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
392 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
394 -- DO THE MAIN DEPENDENCY ANALYSIS
396 decl_sccs = stronglyConnComp edges
400 tycl_decls = [d | TyClD d <- decls, not (isIfaceSigDecl d)]
401 edges = map mkEdges tycl_decls
403 is_syn_decl (d, _, _) = isSynDecl d
406 Edges in Type/Class decls
407 ~~~~~~~~~~~~~~~~~~~~~~~~~
410 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
411 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
413 add n fvs | isTyVarName n = fvs
414 | otherwise = n : fvs
416 ----------------------------------------------------
417 -- mk_cls_edges looks only at the context of class decls
418 -- Its used when we are figuring out if there's a cycle in the
419 -- superclass hierarchy
421 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
423 mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
424 mkClassEdges other_decl = Nothing
426 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
427 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
431 %************************************************************************
433 \subsection{Error management
435 %************************************************************************
438 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
440 typeCycleErr syn_cycles
441 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
443 classCycleErr cls_cycles
444 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
448 4 (vcat (map pp_decl decls))
451 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
453 name = tyClDeclName decl