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,
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(..), DataConDetails(..), visibleDataCons,
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
71 -> TcM [TyThing] -- Returns newly defined things:
72 -- types, classes and implicit Ids
74 tcTyAndClassDecls unf_env this_mod decls
75 = sortByDependency decls `thenTc` \ groups ->
76 tcGroups unf_env this_mod groups
78 tcGroups unf_env this_mod []
79 = tcGetEnv `thenNF_Tc` \ env ->
82 tcGroups unf_env this_mod (group:groups)
83 = tcGroup unf_env this_mod group `thenTc` \ (env, new_things1) ->
85 tcGroups unf_env this_mod groups `thenTc` \ new_things2 ->
86 returnTc (new_things1 ++ new_things2)
91 Consider a mutually-recursive group, binding
92 a type constructor T and a class C.
94 Step 1: getInitialKind
95 Construct a KindEnv by binding T and C to a kind variable
98 In that environment, do a kind check
100 Step 3: Zonk the kinds
102 Step 4: buildTyConOrClass
103 Construct an environment binding T to a TyCon and C to a Class.
104 a) Their kinds comes from zonking the relevant kind variable
105 b) Their arity (for synonyms) comes direct from the decl
106 c) The funcional dependencies come from the decl
107 d) The rest comes a knot-tied binding of T and C, returned from Step 4
108 e) The variances of the tycons in the group is calculated from
112 In this environment, walk over the decls, constructing the TyCons and Classes.
113 This uses in a strict way items (a)-(c) above, which is why they must
114 be constructed in Step 4. Feed the results back to Step 4.
115 For this step, pass the is-recursive flag as the wimp-out flag
119 Step 6: Extend environment
120 We extend the type environment with bindings not only for the TyCons and Classes,
121 but also for their "implicit Ids" like data constructors and class selectors
123 Step 7: checkValidTyCl
124 For a recursive group only, check all the decls again, just
125 to check all the side conditions on validity. We could not
126 do this before because we were in a mutually recursive knot.
129 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
130 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
133 tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl
134 -> TcM (TcEnv, -- Input env extended by types and classes only
135 [TyThing]) -- Things defined by this group
137 tcGroup unf_env this_mod scc
138 = getDOptsTc `thenNF_Tc` \ dflags ->
140 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
143 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
146 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
149 traceTc (text "starting" <+> ppr final_kinds) `thenTc_`
150 fixTc ( \ ~(rec_details_list, _, _) ->
153 kind_env = mkNameEnv final_kinds
154 rec_details = mkNameEnv rec_details_list
156 tyclss, all_tyclss :: [TyThing]
157 tyclss = map (buildTyConOrClass dflags is_rec kind_env
158 rec_vrcs rec_details) decls
160 -- Add the tycons that come from the classes
161 -- We want them in the environment because
162 -- they are mentioned in interface files
163 all_tyclss = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
166 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
167 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
170 -- Extend the environment with the final
171 -- TyCons/Classes and check the decls
172 tcExtendGlobalEnv all_tyclss $
173 mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
176 tcGetEnv `thenNF_Tc` \ env ->
177 returnTc (tycls_details, env, all_tyclss)
178 ) `thenTc` \ (_, env, all_tyclss) ->
180 -- Step 7: Check validity
181 traceTc (text "ready for validity check") `thenTc_`
183 mapTc_ (checkValidTyCl this_mod) decls
185 traceTc (text "done") `thenTc_`
188 implicit_things = [AnId id | id <- implicitTyThingIds all_tyclss]
189 new_things = all_tyclss ++ implicit_things
191 returnTc (env, new_things)
195 AcyclicSCC _ -> NonRecursive
196 CyclicSCC _ -> Recursive
199 AcyclicSCC decl -> [decl]
200 CyclicSCC decls -> decls
202 tcTyClDecl1 unf_env decl
203 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
204 | otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
206 -- We do the validity check over declarations, rather than TyThings
207 -- only so that we can add a nice context with tcAddDeclCtxt
208 checkValidTyCl this_mod decl
209 = tcLookup (tcdName decl) `thenNF_Tc` \ (AGlobal thing) ->
210 if not (isLocalThing this_mod thing) then
211 -- Don't bother to check validity for non-local things
216 ATyCon tc -> checkValidTyCon tc
217 AClass cl -> checkValidClass cl
221 %************************************************************************
223 \subsection{Step 1: Initial environment}
225 %************************************************************************
228 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
230 = kcHsTyVars (tyClDeclTyVars decl) `thenNF_Tc` \ arg_kinds ->
231 newKindVar `thenNF_Tc` \ result_kind ->
232 returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
234 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
238 %************************************************************************
240 \subsection{Step 2: Kind checking}
242 %************************************************************************
244 We need to kind check all types in the mutually recursive group
245 before we know the kind of the type variables. For example:
248 op :: D b => a -> b -> b
251 bop :: (Monad c) => ...
253 Here, the kind of the locally-polymorphic type variable "b"
254 depends on *all the uses of class D*. For example, the use of
255 Monad c in bop's type signature means that D must have kind Type->Type.
258 kcTyClDecl :: RenamedTyClDecl -> TcM ()
260 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
261 = kcTyClDeclBody decl $ \ result_kind ->
262 kcHsType rhs `thenTc` \ rhs_kind ->
263 unifyKind result_kind rhs_kind
265 kcTyClDecl (ForeignType {}) = returnTc ()
267 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
268 = kcTyClDeclBody decl $ \ result_kind ->
269 kcHsContext context `thenTc_`
270 mapTc_ kc_con_decl (visibleDataCons con_decls)
272 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
273 = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
274 tcExtendKindEnv kind_env $
275 kcConDetails new_or_data ex_ctxt details
277 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
278 = kcTyClDeclBody decl $ \ result_kind ->
279 kcHsContext context `thenTc_`
280 mapTc_ kc_sig (filter isClassOpSig class_sigs)
282 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
284 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
285 -- Extend the env with bindings for the tyvars, taken from
286 -- the kind of the tycon/class. Give it to the thing inside, and
287 -- check the result kind matches
288 kcTyClDeclBody decl thing_inside
289 = tcAddDeclCtxt decl $
290 tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
293 AGlobal (ATyCon tc) -> tyConKind tc
294 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
296 -- For some odd reason, a class doesn't include its kind
298 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
300 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
305 %************************************************************************
307 \subsection{Step 4: Building the tycon/class}
309 %************************************************************************
314 -> RecFlag -> NameEnv Kind
315 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
316 -> RenamedTyClDecl -> TyThing
318 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
319 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
322 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
323 tycon_kind = lookupNameEnv_NF kenv tycon_name
324 arity = length tyvar_names
325 tyvars = mkTyClTyVars tycon_kind tyvar_names
326 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
327 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
329 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
330 (TyData {tcdND = data_or_new, tcdName = tycon_name,
331 tcdTyVars = tyvar_names, tcdSysNames = sys_names})
334 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
336 flavour is_rec gen_info
337 -- It's not strictly necesary to mark newtypes as
338 -- recursive if the loop is broken via a data type.
339 -- But I'm not sure it's worth the hassle of discovering that.
341 gen_info | not (dopt Opt_Generics dflags) = Nothing
342 | otherwise = mkTyConGenInfo tycon sys_names
344 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
346 tycon_kind = lookupNameEnv_NF kenv tycon_name
347 tyvars = mkTyClTyVars tycon_kind tyvar_names
348 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
350 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
351 -- so flavour has to be able to answer this question without consulting rec_details
352 flavour = case data_or_new of
353 NewType -> NewTyCon (mkNewTyConRep tycon)
354 DataType | all_nullary data_cons -> EnumTyCon
355 | otherwise -> DataTyCon
357 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
358 all_nullary other = False -- Safe choice for unknown data types
359 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
360 -- but that looks at the *representation* arity, and that in turn
361 -- depends on deciding whether to unpack the args, and that
362 -- depends on whether it's a data type or a newtype --- so
363 -- in the recursive case we can get a loop. This version is simple!
365 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
366 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
367 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
369 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
370 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
371 tcdFDs = fundeps, tcdSysNames = name_list} )
374 (tycon_name, _, _, _) = getClassDeclSysNames name_list
375 clas = mkClass class_name tyvars fds
376 sc_theta sc_sel_ids op_items
379 tycon = mkClassTyCon tycon_name class_kind tyvars
381 clas -- Yes! It's a dictionary
384 -- A class can be recursive, and in the case of newtypes
385 -- this matters. For example
386 -- class C a where { op :: C b => a -> b -> Int }
387 -- Because C has only one operation, it is represented by
388 -- a newtype, and it should be a *recursive* newtype.
389 -- [If we don't make it a recursive newtype, we'll expand the
390 -- newtype like a synonym, but that will lead toan inifinite type
392 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
394 class_kind = lookupNameEnv_NF kenv class_name
395 tyvars = mkTyClTyVars class_kind tyvar_names
396 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
398 flavour = case dataConOrigArgTys dict_con of
399 -- The tyvars in the datacon are the same as in the class
400 [rep_ty] -> NewTyCon rep_ty
403 -- We can find the functional dependencies right away,
404 -- and it is vital to do so. Why? Because in the next pass
405 -- we check for ambiguity in all the type signatures, and we
406 -- need the functional dependcies to be done by then
407 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
408 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
409 lookup = lookupNameEnv_NF tyvar_env
411 bogusVrcs = panic "Bogus tycon arg variances"
415 mkNewTyConRep :: TyCon -- The original type constructor
416 -> Type -- Chosen representation type
417 -- (guaranteed not to be another newtype)
419 -- Find the representation type for this newtype TyCon
421 -- The non-recursive newtypes are easy, because they look transparent
422 -- to splitTyConApp_maybe, but recursive ones really are represented as
423 -- TyConApps (see TypeRep).
425 -- The trick is to to deal correctly with recursive newtypes
426 -- such as newtype T = MkT T
431 -- Invariant: tc is a NewTyCon
432 -- tcs have been seen before
434 | tc `elem` tcs = unitTy
437 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
439 case splitTyConApp_maybe rep_ty of
441 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
442 | otherwise -> go1 (tc:tcs) tc' tys
444 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
447 %************************************************************************
449 \subsection{Dependency analysis}
451 %************************************************************************
456 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
457 sortByDependency decls
458 = let -- CHECK FOR CLASS CYCLES
459 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
460 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
462 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
464 let -- CHECK FOR SYNONYM CYCLES
465 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
466 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
469 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
471 -- DO THE MAIN DEPENDENCY ANALYSIS
473 decl_sccs = stronglyConnComp edges
477 tycl_decls = filter (not . isIfaceSigDecl) decls
478 edges = map mkEdges tycl_decls
480 is_syn_decl (d, _, _) = isSynDecl d
483 Edges in Type/Class decls
484 ~~~~~~~~~~~~~~~~~~~~~~~~~
487 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
488 -- Find the free non-tyvar vars
489 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
491 add n fvs | isTyVarName n = fvs
492 | otherwise = n : fvs
494 ----------------------------------------------------
495 -- mk_cls_edges looks only at the context of class decls
496 -- Its used when we are figuring out if there's a cycle in the
497 -- superclass hierarchy
499 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
501 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
502 mkClassEdges other_decl = Nothing
504 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
505 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
509 %************************************************************************
511 \subsection{Error management
513 %************************************************************************
516 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
518 typeCycleErr syn_cycles
519 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
521 classCycleErr cls_cycles
522 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
526 4 (vcat (map pp_decl decls))
529 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
531 name = tyClDeclName decl