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, tyClDeclTyVars,
17 isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
19 import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
20 import BasicTypes ( RecFlag(..), NewOrData(..) )
21 import HscTypes ( implicitTyThingIds )
22 import Module ( Module )
25 import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
26 tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv,
28 import TcTyDecls ( tcTyDecl, kcConDetails, checkValidTyCon )
29 import TcClassDcl ( tcClassDecl1, checkValidClass )
30 import TcInstDcls ( tcAddDeclCtxt )
31 import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
32 import TcMType ( newKindVar, zonkKindEnv )
33 import TcUnify ( unifyKind )
34 import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
35 import Type ( splitTyConApp_maybe )
36 import Variance ( calcTyConArgVrcs )
37 import Class ( Class, mkClass, classTyCon )
38 import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..),
39 tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
40 mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
42 import TysWiredIn ( unitTy )
43 import Subst ( substTyWith )
44 import DataCon ( dataConOrigArgTys )
45 import Var ( varName )
47 import Digraph ( stronglyConnComp, SCC(..) )
48 import Name ( Name, getSrcLoc, isTyVarName )
52 import Maybes ( mapMaybe )
53 import ErrUtils ( Message )
54 import HsDecls ( getClassDeclSysNames )
55 import Generics ( mkTyConGenInfo )
59 %************************************************************************
61 \subsection{Type checking for type and class declarations}
63 %************************************************************************
68 tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
69 -> Module -- Current module
73 tcTyAndClassDecls unf_env this_mod decls
74 = sortByDependency decls `thenTc` \ groups ->
75 tcGroups unf_env this_mod groups
77 tcGroups unf_env this_mod []
78 = tcGetEnv `thenNF_Tc` \ env ->
81 tcGroups unf_env this_mod (group:groups)
82 = tcGroup unf_env this_mod group `thenTc` \ env ->
84 tcGroups unf_env this_mod groups
89 Consider a mutually-recursive group, binding
90 a type constructor T and a class C.
92 Step 1: getInitialKind
93 Construct a KindEnv by binding T and C to a kind variable
96 In that environment, do a kind check
98 Step 3: Zonk the kinds
100 Step 4: buildTyConOrClass
101 Construct an environment binding T to a TyCon and C to a Class.
102 a) Their kinds comes from zonking the relevant kind variable
103 b) Their arity (for synonyms) comes direct from the decl
104 c) The funcional dependencies come from the decl
105 d) The rest comes a knot-tied binding of T and C, returned from Step 4
106 e) The variances of the tycons in the group is calculated from
110 In this environment, walk over the decls, constructing the TyCons and Classes.
111 This uses in a strict way items (a)-(c) above, which is why they must
112 be constructed in Step 4. Feed the results back to Step 4.
113 For this step, pass the is-recursive flag as the wimp-out flag
117 Step 6: Extend environment
118 We extend the type environment with bindings not only for the TyCons and Classes,
119 but also for their "implicit Ids" like data constructors and class selectors
121 Step 7: checkValidTyCl
122 For a recursive group only, check all the decls again, just
123 to check all the side conditions on validity. We could not
124 do this before because we were in a mutually recursive knot.
127 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
128 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
131 tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl -> TcM TcEnv
132 tcGroup unf_env this_mod scc
133 = getDOptsTc `thenNF_Tc` \ dflags ->
135 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
138 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
141 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
144 traceTc (text "starting" <+> ppr final_kinds) `thenTc_`
145 fixTc ( \ ~(rec_details_list, _, _) ->
148 kind_env = mkNameEnv final_kinds
149 rec_details = mkNameEnv rec_details_list
151 tyclss, all_tyclss :: [TyThing]
152 tyclss = map (buildTyConOrClass dflags is_rec kind_env
153 rec_vrcs rec_details) decls
155 -- Add the tycons that come from the classes
156 -- We want them in the environment because
157 -- they are mentioned in interface files
158 all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
161 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
162 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
165 -- Extend the environment with the final
166 -- TyCons/Classes and check the decls
167 tcExtendGlobalEnv all_tyclss $
168 mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
171 -- Extend the environment with implicit Ids
172 tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) $
175 tcGetEnv `thenNF_Tc` \ env ->
176 returnTc (tycls_details, tyclss, env)
177 ) `thenTc` \ (_, tyclss, env) ->
180 -- Step 7: Check validity
181 traceTc (text "ready for validity check") `thenTc_`
183 mapTc_ (checkValidTyCl this_mod) decls
185 traceTc (text "done") `thenTc_`
191 AcyclicSCC _ -> NonRecursive
192 CyclicSCC _ -> Recursive
195 AcyclicSCC decl -> [decl]
196 CyclicSCC decls -> decls
198 tcTyClDecl1 unf_env decl
199 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 unf_env decl)
200 | otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
202 checkValidTyCl this_mod decl
203 = tcLookup (tcdName decl) `thenNF_Tc` \ (AGlobal thing) ->
204 if not (isLocalThing this_mod thing) then
205 -- Don't bother to check validity for non-local things
210 ATyCon tc -> checkValidTyCon tc
211 AClass cl -> checkValidClass cl
215 %************************************************************************
217 \subsection{Step 1: Initial environment}
219 %************************************************************************
222 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
224 = kcHsTyVars (tyClDeclTyVars decl) `thenNF_Tc` \ arg_kinds ->
225 newKindVar `thenNF_Tc` \ result_kind ->
226 returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
228 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
232 %************************************************************************
234 \subsection{Step 2: Kind checking}
236 %************************************************************************
238 We need to kind check all types in the mutually recursive group
239 before we know the kind of the type variables. For example:
242 op :: D b => a -> b -> b
245 bop :: (Monad c) => ...
247 Here, the kind of the locally-polymorphic type variable "b"
248 depends on *all the uses of class D*. For example, the use of
249 Monad c in bop's type signature means that D must have kind Type->Type.
252 kcTyClDecl :: RenamedTyClDecl -> TcM ()
254 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
255 = kcTyClDeclBody decl $ \ result_kind ->
256 kcHsType rhs `thenTc` \ rhs_kind ->
257 unifyKind result_kind rhs_kind
259 kcTyClDecl (ForeignType {}) = returnTc ()
261 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
262 = kcTyClDeclBody decl $ \ result_kind ->
263 kcHsContext context `thenTc_`
264 mapTc_ kc_con_decl con_decls
266 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
267 = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
268 tcExtendKindEnv kind_env $
269 kcConDetails new_or_data ex_ctxt details
271 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
272 = kcTyClDeclBody decl $ \ result_kind ->
273 kcHsContext context `thenTc_`
274 mapTc_ kc_sig (filter isClassOpSig class_sigs)
276 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
278 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
279 -- Extend the env with bindings for the tyvars, taken from
280 -- the kind of the tycon/class. Give it to the thing inside, and
281 -- check the result kind matches
282 kcTyClDeclBody decl thing_inside
283 = tcAddDeclCtxt decl $
284 tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
287 AGlobal (ATyCon tc) -> tyConKind tc
288 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
290 -- For some odd reason, a class doesn't include its kind
292 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
294 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
299 %************************************************************************
301 \subsection{Step 4: Building the tycon/class}
303 %************************************************************************
308 -> RecFlag -> NameEnv Kind
309 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
310 -> RenamedTyClDecl -> TyThing
312 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
313 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
316 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
317 tycon_kind = lookupNameEnv_NF kenv tycon_name
318 arity = length tyvar_names
319 tyvars = mkTyClTyVars tycon_kind tyvar_names
320 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
321 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
323 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
324 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
325 tcdNCons = nconstrs, tcdSysNames = sys_names})
328 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
329 data_cons nconstrs sel_ids
330 flavour is_rec gen_info
332 gen_info | not (dopt Opt_Generics dflags) = Nothing
333 | otherwise = mkTyConGenInfo tycon sys_names
335 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
337 tycon_kind = lookupNameEnv_NF kenv tycon_name
338 tyvars = mkTyClTyVars tycon_kind tyvar_names
339 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
341 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
342 -- so flavour has to be able to answer this question without consulting rec_details
343 flavour = case data_or_new of
344 NewType -> NewTyCon (mkNewTyConRep tycon)
345 DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
346 | otherwise -> DataTyCon
347 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
348 -- but that looks at the *representation* arity, and that in turn
349 -- depends on deciding whether to unpack the args, and that
350 -- depends on whether it's a data type or a newtype --- so
351 -- in the recursive case we can get a loop. This version is simple!
353 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
354 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
355 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
357 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
358 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
359 tcdFDs = fundeps, tcdSysNames = name_list} )
362 (tycon_name, _, _, _) = getClassDeclSysNames name_list
363 clas = mkClass class_name tyvars fds
364 sc_theta sc_sel_ids op_items
367 tycon = mkClassTyCon tycon_name class_kind tyvars
369 clas -- Yes! It's a dictionary
372 -- A class can be recursive, and in the case of newtypes
373 -- this matters. For example
374 -- class C a where { op :: C b => a -> b -> Int }
375 -- Because C has only one operation, it is represented by
376 -- a newtype, and it should be a *recursive* newtype.
377 -- [If we don't make it a recursive newtype, we'll expand the
378 -- newtype like a synonym, but that will lead toan inifinite type
380 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
382 class_kind = lookupNameEnv_NF kenv class_name
383 tyvars = mkTyClTyVars class_kind tyvar_names
384 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
386 flavour = case dataConOrigArgTys dict_con of
387 -- The tyvars in the datacon are the same as in the class
388 [rep_ty] -> NewTyCon rep_ty
391 -- We can find the functional dependencies right away,
392 -- and it is vital to do so. Why? Because in the next pass
393 -- we check for ambiguity in all the type signatures, and we
394 -- need the functional dependcies to be done by then
395 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
396 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
397 lookup = lookupNameEnv_NF tyvar_env
399 bogusVrcs = panic "Bogus tycon arg variances"
403 mkNewTyConRep :: TyCon -- The original type constructor
404 -> Type -- Chosen representation type
405 -- (guaranteed not to be another newtype)
407 -- Find the representation type for this newtype TyCon
409 -- The non-recursive newtypes are easy, because they look transparent
410 -- to splitTyConApp_maybe, but recursive ones really are represented as
411 -- TyConApps (see TypeRep).
413 -- The trick is to to deal correctly with recursive newtypes
414 -- such as newtype T = MkT T
419 -- Invariant: tc is a NewTyCon
420 -- tcs have been seen before
422 | tc `elem` tcs = unitTy
425 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
427 case splitTyConApp_maybe rep_ty of
429 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
430 | otherwise -> go1 (tc:tcs) tc' tys
432 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
435 %************************************************************************
437 \subsection{Dependency analysis}
439 %************************************************************************
444 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
445 sortByDependency decls
446 = let -- CHECK FOR CLASS CYCLES
447 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
448 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
450 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
452 let -- CHECK FOR SYNONYM CYCLES
453 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
454 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
457 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
459 -- DO THE MAIN DEPENDENCY ANALYSIS
461 decl_sccs = stronglyConnComp edges
465 tycl_decls = filter (not . isIfaceSigDecl) decls
466 edges = map mkEdges tycl_decls
468 is_syn_decl (d, _, _) = isSynDecl d
471 Edges in Type/Class decls
472 ~~~~~~~~~~~~~~~~~~~~~~~~~
475 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
476 -- Find the free non-tyvar vars
477 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
479 add n fvs | isTyVarName n = fvs
480 | otherwise = n : fvs
482 ----------------------------------------------------
483 -- mk_cls_edges looks only at the context of class decls
484 -- Its used when we are figuring out if there's a cycle in the
485 -- superclass hierarchy
487 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
489 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
490 mkClassEdges other_decl = Nothing
492 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
493 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
497 %************************************************************************
499 \subsection{Error management
501 %************************************************************************
504 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
506 typeCycleErr syn_cycles
507 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
509 classCycleErr cls_cycles
510 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
514 4 (vcat (map pp_decl decls))
517 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
519 name = tyClDeclName decl