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 isTypeOrClassDecl, 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, TcTyThing(..), TyThing(..), TyThingDetails(..),
26 tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
28 import TcTyDecls ( tcTyDecl, kcConDetails )
29 import TcClassDcl ( tcClassDecl1 )
30 import TcInstDcls ( tcAddDeclCtxt )
31 import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
32 import TcMType ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
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 :: Module -- Current module
70 -> TcM [TyThing] -- Returns newly defined things:
71 -- types, classes and implicit Ids
73 tcTyAndClassDecls this_mod decls
74 = sortByDependency decls `thenTc` \ groups ->
75 tcGroups this_mod groups
80 tcGroups this_mod (group:groups)
81 = tcGroup this_mod group `thenTc` \ (env, new_things1) ->
83 tcGroups this_mod groups `thenTc` \ new_things2 ->
84 returnTc (new_things1 ++ new_things2)
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 :: Module -> SCC RenamedTyClDecl
132 -> TcM (TcEnv, -- Input env extended by types and classes only
133 [TyThing]) -- Things defined by this group
136 = getDOptsTc `thenNF_Tc` \ dflags ->
138 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
141 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
144 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
147 traceTc (text "starting" <+> ppr final_kinds) `thenTc_`
148 fixTc ( \ ~(rec_details_list, _, _) ->
151 kind_env = mkNameEnv final_kinds
152 rec_details = mkNameEnv rec_details_list
154 tyclss, all_tyclss :: [TyThing]
155 tyclss = map (buildTyConOrClass dflags is_rec kind_env
156 rec_vrcs rec_details) decls
158 -- Add the tycons that come from the classes
159 -- We want them in the environment because
160 -- they are mentioned in interface files
161 all_tyclss = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
164 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
165 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
168 -- Extend the environment with the final
169 -- TyCons/Classes and check the decls
170 tcExtendGlobalEnv all_tyclss $
171 mapTc tcTyClDecl1 decls `thenTc` \ tycls_details ->
174 tcGetEnv `thenNF_Tc` \ env ->
175 returnTc (tycls_details, env, all_tyclss)
176 ) `thenTc` \ (_, env, all_tyclss) ->
178 -- Step 7: Check validity
179 traceTc (text "ready for validity check") `thenTc_`
181 mapTc_ (checkValidTyCl this_mod) decls
183 traceTc (text "done") `thenTc_`
186 implicit_things = [AnId id | id <- implicitTyThingIds all_tyclss]
187 new_things = all_tyclss ++ implicit_things
189 returnTc (env, new_things)
193 AcyclicSCC _ -> NonRecursive
194 CyclicSCC _ -> Recursive
197 AcyclicSCC decl -> [decl]
198 CyclicSCC decls -> decls
201 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
202 | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
204 -- We do the validity check over declarations, rather than TyThings
205 -- only so that we can add a nice context with tcAddDeclCtxt
206 checkValidTyCl this_mod decl
207 = tcLookup (tcdName decl) `thenNF_Tc` \ (AGlobal thing) ->
208 if not (isLocalThing this_mod thing) then
209 -- Don't bother to check validity for non-local things
214 ATyCon tc -> checkValidTyCon tc
215 AClass cl -> checkValidClass cl
219 %************************************************************************
221 \subsection{Step 1: Initial environment}
223 %************************************************************************
226 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
228 = kcHsTyVars (tyClDeclTyVars decl) `thenNF_Tc` \ arg_kinds ->
229 newKindVar `thenNF_Tc` \ result_kind ->
230 returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
232 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
236 %************************************************************************
238 \subsection{Step 2: Kind checking}
240 %************************************************************************
242 We need to kind check all types in the mutually recursive group
243 before we know the kind of the type variables. For example:
246 op :: D b => a -> b -> b
249 bop :: (Monad c) => ...
251 Here, the kind of the locally-polymorphic type variable "b"
252 depends on *all the uses of class D*. For example, the use of
253 Monad c in bop's type signature means that D must have kind Type->Type.
256 kcTyClDecl :: RenamedTyClDecl -> TcM ()
258 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
259 = kcTyClDeclBody decl $ \ result_kind ->
260 kcHsType rhs `thenTc` \ rhs_kind ->
261 unifyKind result_kind rhs_kind
263 kcTyClDecl (ForeignType {}) = returnTc ()
265 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
266 = kcTyClDeclBody decl $ \ result_kind ->
267 kcHsContext context `thenTc_`
268 mapTc_ kc_con_decl (visibleDataCons con_decls)
270 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
271 = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
272 tcExtendKindEnv kind_env $
273 kcConDetails new_or_data ex_ctxt details
275 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
276 = kcTyClDeclBody decl $ \ result_kind ->
277 kcHsContext context `thenTc_`
278 mapTc_ kc_sig (filter isClassOpSig class_sigs)
280 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
282 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
283 -- Extend the env with bindings for the tyvars, taken from
284 -- the kind of the tycon/class. Give it to the thing inside, and
285 -- check the result kind matches
286 kcTyClDeclBody decl thing_inside
287 = tcAddDeclCtxt decl $
288 tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
291 AGlobal (ATyCon tc) -> tyConKind tc
292 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
294 -- For some odd reason, a class doesn't include its kind
296 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
298 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
303 %************************************************************************
305 \subsection{Step 4: Building the tycon/class}
307 %************************************************************************
312 -> RecFlag -> NameEnv Kind
313 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
314 -> RenamedTyClDecl -> TyThing
316 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
317 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
320 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
321 tycon_kind = lookupNameEnv_NF kenv tycon_name
322 arity = length tyvar_names
323 tyvars = mkTyClTyVars tycon_kind tyvar_names
324 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
325 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
327 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
328 (TyData {tcdND = data_or_new, tcdName = tycon_name,
329 tcdTyVars = tyvar_names, tcdSysNames = sys_names})
332 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
334 flavour is_rec gen_info
335 -- It's not strictly necesary to mark newtypes as
336 -- recursive if the loop is broken via a data type.
337 -- But I'm not sure it's worth the hassle of discovering that.
339 gen_info | not (dopt Opt_Generics dflags) = Nothing
340 | otherwise = mkTyConGenInfo tycon sys_names
342 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
344 tycon_kind = lookupNameEnv_NF kenv tycon_name
345 tyvars = mkTyClTyVars tycon_kind tyvar_names
346 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
348 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
349 -- so flavour has to be able to answer this question without consulting rec_details
350 flavour = case data_or_new of
351 NewType -> NewTyCon (mkNewTyConRep tycon)
352 DataType | all_nullary data_cons -> EnumTyCon
353 | otherwise -> DataTyCon
355 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
356 all_nullary other = False -- Safe choice for unknown data types
357 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
358 -- but that looks at the *representation* arity, and that in turn
359 -- depends on deciding whether to unpack the args, and that
360 -- depends on whether it's a data type or a newtype --- so
361 -- in the recursive case we can get a loop. This version is simple!
363 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
364 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
365 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
367 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
368 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
369 tcdFDs = fundeps, tcdSysNames = name_list} )
372 (tycon_name, _, _, _) = getClassDeclSysNames name_list
373 clas = mkClass class_name tyvars fds
374 sc_theta sc_sel_ids op_items
377 tycon = mkClassTyCon tycon_name class_kind tyvars
379 clas -- Yes! It's a dictionary
382 -- A class can be recursive, and in the case of newtypes
383 -- this matters. For example
384 -- class C a where { op :: C b => a -> b -> Int }
385 -- Because C has only one operation, it is represented by
386 -- a newtype, and it should be a *recursive* newtype.
387 -- [If we don't make it a recursive newtype, we'll expand the
388 -- newtype like a synonym, but that will lead toan inifinite type
390 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
392 class_kind = lookupNameEnv_NF kenv class_name
393 tyvars = mkTyClTyVars class_kind tyvar_names
394 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
396 flavour = case dataConOrigArgTys dict_con of
397 -- The tyvars in the datacon are the same as in the class
398 [rep_ty] -> NewTyCon rep_ty
401 -- We can find the functional dependencies right away,
402 -- and it is vital to do so. Why? Because in the next pass
403 -- we check for ambiguity in all the type signatures, and we
404 -- need the functional dependcies to be done by then
405 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
406 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
407 lookup = lookupNameEnv_NF tyvar_env
409 bogusVrcs = panic "Bogus tycon arg variances"
413 mkNewTyConRep :: TyCon -- The original type constructor
414 -> Type -- Chosen representation type
415 -- (guaranteed not to be another newtype)
417 -- Find the representation type for this newtype TyCon
419 -- The non-recursive newtypes are easy, because they look transparent
420 -- to splitTyConApp_maybe, but recursive ones really are represented as
421 -- TyConApps (see TypeRep).
423 -- The trick is to to deal correctly with recursive newtypes
424 -- such as newtype T = MkT T
429 -- Invariant: tc is a NewTyCon
430 -- tcs have been seen before
432 | tc `elem` tcs = unitTy
435 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
437 case splitTyConApp_maybe rep_ty of
439 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
440 | otherwise -> go1 (tc:tcs) tc' tys
442 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
445 %************************************************************************
447 \subsection{Dependency analysis}
449 %************************************************************************
454 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
455 sortByDependency decls
456 = let -- CHECK FOR CLASS CYCLES
457 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
458 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
460 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
462 let -- CHECK FOR SYNONYM CYCLES
463 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
464 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
467 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
469 -- DO THE MAIN DEPENDENCY ANALYSIS
471 decl_sccs = stronglyConnComp edges
475 tycl_decls = filter isTypeOrClassDecl decls
476 edges = map mkEdges tycl_decls
478 is_syn_decl (d, _, _) = isSynDecl d
481 Edges in Type/Class decls
482 ~~~~~~~~~~~~~~~~~~~~~~~~~
485 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
486 -- Find the free non-tyvar vars
487 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
489 add n fvs | isTyVarName n = fvs
490 | otherwise = n : fvs
492 ----------------------------------------------------
493 -- mk_cls_edges looks only at the context of class decls
494 -- Its used when we are figuring out if there's a cycle in the
495 -- superclass hierarchy
497 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
499 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
500 mkClassEdges other_decl = Nothing
502 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
503 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
507 %************************************************************************
509 \subsection{Error management
511 %************************************************************************
514 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
516 typeCycleErr syn_cycles
517 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
519 classCycleErr cls_cycles
520 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
524 4 (vcat (map pp_decl decls))
527 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
529 name = tyClDeclName decl