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(..),
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 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, tcdTyVars = tyvar_names,
331 tcdNCons = nconstrs, tcdSysNames = sys_names})
334 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
335 data_cons nconstrs sel_ids
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 (null . dataConOrigArgTys) data_cons -> EnumTyCon
352 | otherwise -> DataTyCon
353 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
354 -- but that looks at the *representation* arity, and that in turn
355 -- depends on deciding whether to unpack the args, and that
356 -- depends on whether it's a data type or a newtype --- so
357 -- in the recursive case we can get a loop. This version is simple!
359 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
360 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
361 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
363 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
364 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
365 tcdFDs = fundeps, tcdSysNames = name_list} )
368 (tycon_name, _, _, _) = getClassDeclSysNames name_list
369 clas = mkClass class_name tyvars fds
370 sc_theta sc_sel_ids op_items
373 tycon = mkClassTyCon tycon_name class_kind tyvars
375 clas -- Yes! It's a dictionary
378 -- A class can be recursive, and in the case of newtypes
379 -- this matters. For example
380 -- class C a where { op :: C b => a -> b -> Int }
381 -- Because C has only one operation, it is represented by
382 -- a newtype, and it should be a *recursive* newtype.
383 -- [If we don't make it a recursive newtype, we'll expand the
384 -- newtype like a synonym, but that will lead toan inifinite type
386 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
388 class_kind = lookupNameEnv_NF kenv class_name
389 tyvars = mkTyClTyVars class_kind tyvar_names
390 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
392 flavour = case dataConOrigArgTys dict_con of
393 -- The tyvars in the datacon are the same as in the class
394 [rep_ty] -> NewTyCon rep_ty
397 -- We can find the functional dependencies right away,
398 -- and it is vital to do so. Why? Because in the next pass
399 -- we check for ambiguity in all the type signatures, and we
400 -- need the functional dependcies to be done by then
401 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
402 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
403 lookup = lookupNameEnv_NF tyvar_env
405 bogusVrcs = panic "Bogus tycon arg variances"
409 mkNewTyConRep :: TyCon -- The original type constructor
410 -> Type -- Chosen representation type
411 -- (guaranteed not to be another newtype)
413 -- Find the representation type for this newtype TyCon
415 -- The non-recursive newtypes are easy, because they look transparent
416 -- to splitTyConApp_maybe, but recursive ones really are represented as
417 -- TyConApps (see TypeRep).
419 -- The trick is to to deal correctly with recursive newtypes
420 -- such as newtype T = MkT T
425 -- Invariant: tc is a NewTyCon
426 -- tcs have been seen before
428 | tc `elem` tcs = unitTy
431 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
433 case splitTyConApp_maybe rep_ty of
435 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
436 | otherwise -> go1 (tc:tcs) tc' tys
438 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
441 %************************************************************************
443 \subsection{Dependency analysis}
445 %************************************************************************
450 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
451 sortByDependency decls
452 = let -- CHECK FOR CLASS CYCLES
453 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
454 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
456 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
458 let -- CHECK FOR SYNONYM CYCLES
459 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
460 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
463 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
465 -- DO THE MAIN DEPENDENCY ANALYSIS
467 decl_sccs = stronglyConnComp edges
471 tycl_decls = filter (not . isIfaceSigDecl) decls
472 edges = map mkEdges tycl_decls
474 is_syn_decl (d, _, _) = isSynDecl d
477 Edges in Type/Class decls
478 ~~~~~~~~~~~~~~~~~~~~~~~~~
481 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
482 -- Find the free non-tyvar vars
483 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
485 add n fvs | isTyVarName n = fvs
486 | otherwise = n : fvs
488 ----------------------------------------------------
489 -- mk_cls_edges looks only at the context of class decls
490 -- Its used when we are figuring out if there's a cycle in the
491 -- superclass hierarchy
493 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
495 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
496 mkClassEdges other_decl = Nothing
498 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
499 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
503 %************************************************************************
505 \subsection{Error management
507 %************************************************************************
510 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
512 typeCycleErr syn_cycles
513 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
515 classCycleErr cls_cycles
516 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
520 4 (vcat (map pp_decl decls))
523 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
525 name = tyClDeclName decl