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
338 gen_info | not (dopt Opt_Generics dflags) = Nothing
339 | otherwise = mkTyConGenInfo tycon sys_names
341 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
343 tycon_kind = lookupNameEnv_NF kenv tycon_name
344 tyvars = mkTyClTyVars tycon_kind tyvar_names
345 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
347 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
348 -- so flavour has to be able to answer this question without consulting rec_details
349 flavour = case data_or_new of
350 NewType -> NewTyCon (mkNewTyConRep tycon)
351 DataType | all_nullary data_cons -> EnumTyCon
352 | otherwise -> DataTyCon
354 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
355 all_nullary other = False -- Safe choice for unknown data types
356 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
357 -- but that looks at the *representation* arity, and that in turn
358 -- depends on deciding whether to unpack the args, and that
359 -- depends on whether it's a data type or a newtype --- so
360 -- in the recursive case we can get a loop. This version is simple!
362 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
363 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
364 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
366 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
367 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
368 tcdFDs = fundeps, tcdSysNames = name_list} )
371 (tycon_name, _, _, _) = getClassDeclSysNames name_list
372 clas = mkClass class_name tyvars fds
373 sc_theta sc_sel_ids op_items
376 tycon = mkClassTyCon tycon_name class_kind tyvars
378 clas -- Yes! It's a dictionary
381 -- A class can be recursive, and in the case of newtypes
382 -- this matters. For example
383 -- class C a where { op :: C b => a -> b -> Int }
384 -- Because C has only one operation, it is represented by
385 -- a newtype, and it should be a *recursive* newtype.
386 -- [If we don't make it a recursive newtype, we'll expand the
387 -- newtype like a synonym, but that will lead toan inifinite type
389 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
391 class_kind = lookupNameEnv_NF kenv class_name
392 tyvars = mkTyClTyVars class_kind tyvar_names
393 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
395 flavour = case dataConOrigArgTys dict_con of
396 -- The tyvars in the datacon are the same as in the class
397 [rep_ty] -> NewTyCon rep_ty
400 -- We can find the functional dependencies right away,
401 -- and it is vital to do so. Why? Because in the next pass
402 -- we check for ambiguity in all the type signatures, and we
403 -- need the functional dependcies to be done by then
404 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
405 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
406 lookup = lookupNameEnv_NF tyvar_env
408 bogusVrcs = panic "Bogus tycon arg variances"
412 mkNewTyConRep :: TyCon -- The original type constructor
413 -> Type -- Chosen representation type
414 -- (guaranteed not to be another newtype)
416 -- Find the representation type for this newtype TyCon
418 -- The non-recursive newtypes are easy, because they look transparent
419 -- to splitTyConApp_maybe, but recursive ones really are represented as
420 -- TyConApps (see TypeRep).
422 -- The trick is to to deal correctly with recursive newtypes
423 -- such as newtype T = MkT T
428 -- Invariant: tc is a NewTyCon
429 -- tcs have been seen before
431 | tc `elem` tcs = unitTy
434 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
436 case splitTyConApp_maybe rep_ty of
438 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
439 | otherwise -> go1 (tc:tcs) tc' tys
441 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
444 %************************************************************************
446 \subsection{Dependency analysis}
448 %************************************************************************
453 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
454 sortByDependency decls
455 = let -- CHECK FOR CLASS CYCLES
456 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
457 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
459 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
461 let -- CHECK FOR SYNONYM CYCLES
462 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
463 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
466 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
468 -- DO THE MAIN DEPENDENCY ANALYSIS
470 decl_sccs = stronglyConnComp edges
474 tycl_decls = filter (not . isIfaceSigDecl) decls
475 edges = map mkEdges tycl_decls
477 is_syn_decl (d, _, _) = isSynDecl d
480 Edges in Type/Class decls
481 ~~~~~~~~~~~~~~~~~~~~~~~~~
484 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
485 -- Find the free non-tyvar vars
486 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
488 add n fvs | isTyVarName n = fvs
489 | otherwise = n : fvs
491 ----------------------------------------------------
492 -- mk_cls_edges looks only at the context of class decls
493 -- Its used when we are figuring out if there's a cycle in the
494 -- superclass hierarchy
496 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
498 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
499 mkClassEdges other_decl = Nothing
501 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
502 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
506 %************************************************************************
508 \subsection{Error management
510 %************************************************************************
513 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
515 typeCycleErr syn_cycles
516 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
518 classCycleErr cls_cycles
519 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
523 4 (vcat (map pp_decl decls))
526 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
528 name = tyClDeclName decl