2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcTyClsDecls]{Typecheck type and class declarations}
11 #include "HsVersions.h"
13 import HsSyn ( TyClDecl(..),
14 ConDecl(..), Sig(..), HsPred(..),
15 tyClDeclName, hsTyVarNames, tyClDeclTyVars,
16 isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
18 import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
19 import BasicTypes ( RecFlag(..), isNonRec, NewOrData(..) )
20 import HscTypes ( implicitTyThingIds )
23 import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..),
24 tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
26 import TcTyDecls ( tcTyDecl, kcConDetails )
27 import TcClassDcl ( tcClassDecl1 )
28 import TcInstDcls ( tcAddDeclCtxt )
29 import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
30 import TcMType ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
31 import TcUnify ( unifyKind )
32 import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
33 import Type ( splitTyConApp_maybe )
34 import Variance ( calcTyConArgVrcs )
35 import Class ( Class, mkClass, classTyCon )
36 import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
37 tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
38 mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon
40 import TysWiredIn ( unitTy )
41 import Subst ( substTyWith )
42 import DataCon ( dataConOrigArgTys )
43 import Var ( varName )
45 import Digraph ( stronglyConnComp, SCC(..) )
46 import Name ( Name, getSrcLoc )
50 import Maybes ( mapMaybe )
51 import ErrUtils ( Message )
55 %************************************************************************
57 \subsection{Type checking for type and class declarations}
59 %************************************************************************
64 tcTyAndClassDecls :: [RenamedTyClDecl]
65 -> TcM [TyThing] -- Returns newly defined things:
66 -- types, classes and implicit Ids
68 tcTyAndClassDecls decls
69 = tcGroups (stronglyConnComp edges)
71 edges = map mkEdges (filter isTypeOrClassDecl decls)
76 tcGroups (group:groups)
77 = tcGroup group `thenM` \ (env, new_things1) ->
79 tcGroups groups `thenM` \ new_things2 ->
80 returnM (new_things1 ++ new_things2)
85 Consider a mutually-recursive group, binding
86 a type constructor T and a class C.
88 Step 1: getInitialKind
89 Construct a KindEnv by binding T and C to a kind variable
92 In that environment, do a kind check
94 Step 3: Zonk the kinds
96 Step 4: buildTyConOrClass
97 Construct an environment binding T to a TyCon and C to a Class.
98 a) Their kinds comes from zonking the relevant kind variable
99 b) Their arity (for synonyms) comes direct from the decl
100 c) The funcional dependencies come from the decl
101 d) The rest comes a knot-tied binding of T and C, returned from Step 4
102 e) The variances of the tycons in the group is calculated from
106 In this environment, walk over the decls, constructing the TyCons and Classes.
107 This uses in a strict way items (a)-(c) above, which is why they must
108 be constructed in Step 4. Feed the results back to Step 4.
109 For this step, pass the is-recursive flag as the wimp-out flag
113 Step 6: Extend environment
114 We extend the type environment with bindings not only for the TyCons and Classes,
115 but also for their "implicit Ids" like data constructors and class selectors
117 Step 7: checkValidTyCl
118 For a recursive group only, check all the decls again, just
119 to check all the side conditions on validity. We could not
120 do this before because we were in a mutually recursive knot.
123 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
124 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
127 tcGroup :: SCC RenamedTyClDecl
128 -> TcM (TcGblEnv, -- Input env extended by types and classes only
129 [TyThing]) -- Things defined by this group
133 mappM getInitialKind decls `thenM` \ initial_kinds ->
136 tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_`
139 zonkKindEnv initial_kinds `thenM` \ final_kinds ->
142 checkLoops is_rec decls `thenM` \ is_rec_tycon ->
145 traceTc (text "starting" <+> ppr final_kinds) `thenM_`
146 fixM ( \ ~(rec_details_list, _, rec_all_tyclss) ->
149 kind_env = mkNameEnv final_kinds
150 rec_details = mkNameEnv rec_details_list
152 -- Calculate variances, and feed into buildTyConOrClass
153 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- rec_all_tyclss]
155 build_one = buildTyConOrClass is_rec_tycon kind_env
157 tyclss = map build_one decls
161 -- Extend the environment with the final
162 -- TyCons/Classes and check the decls
163 tcExtendGlobalEnv tyclss $
164 mappM tcTyClDecl1 decls `thenM` \ tycls_details ->
167 getGblEnv `thenM` \ env ->
168 returnM (tycls_details, env, tyclss)
169 ) `thenM` \ (_, env, tyclss) ->
171 -- Step 7: Check validity
172 traceTc (text "ready for validity check") `thenM_`
173 getModule `thenM` \ mod ->
175 mappM_ (checkValidTyCl mod) decls
177 traceTc (text "done") `thenM_`
179 let -- Add the tycons that come from the classes
180 -- We want them in the environment because
181 -- they are mentioned in interface files
182 implicit_tycons, implicit_ids, all_tyclss :: [TyThing]
183 implicit_tycons = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
184 all_tyclss = implicit_tycons ++ tyclss
185 implicit_ids = [AnId id | id <- implicitTyThingIds all_tyclss]
186 new_things = implicit_ids ++ all_tyclss
188 returnM (env, new_things)
192 AcyclicSCC _ -> NonRecursive
193 CyclicSCC _ -> Recursive
196 AcyclicSCC decl -> [decl]
197 CyclicSCC decls -> decls
200 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
201 | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
203 -- We do the validity check over declarations, rather than TyThings
204 -- only so that we can add a nice context with tcAddDeclCtxt
205 checkValidTyCl this_mod decl
206 = tcLookupGlobal (tcdName decl) `thenM` \ thing ->
207 if not (isLocalThing this_mod thing) then
208 -- Don't bother to check validity for non-local things
213 ATyCon tc -> checkValidTyCon tc
214 AClass cl -> checkValidClass cl
218 %************************************************************************
220 \subsection{Step 1: Initial environment}
222 %************************************************************************
225 getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
227 = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds ->
228 newKindVar `thenM` \ result_kind ->
229 returnM (tcdName decl, mk_kind arg_kinds result_kind)
231 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
235 %************************************************************************
237 \subsection{Step 2: Kind checking}
239 %************************************************************************
241 We need to kind check all types in the mutually recursive group
242 before we know the kind of the type variables. For example:
245 op :: D b => a -> b -> b
248 bop :: (Monad c) => ...
250 Here, the kind of the locally-polymorphic type variable "b"
251 depends on *all the uses of class D*. For example, the use of
252 Monad c in bop's type signature means that D must have kind Type->Type.
255 kcTyClDecl :: RenamedTyClDecl -> TcM ()
257 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
258 = kcTyClDeclBody decl $ \ result_kind ->
259 kcHsType rhs `thenM` \ rhs_kind ->
260 unifyKind result_kind rhs_kind
262 kcTyClDecl (ForeignType {}) = returnM ()
264 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
265 = kcTyClDeclBody decl $ \ result_kind ->
266 kcHsContext context `thenM_`
267 mappM_ kc_con_decl (visibleDataCons con_decls)
269 kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
270 = kcHsTyVars ex_tvs `thenM` \ kind_env ->
271 tcExtendKindEnv kind_env $
272 kcConDetails new_or_data ex_ctxt details
274 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
275 = kcTyClDeclBody decl $ \ result_kind ->
276 kcHsContext context `thenM_`
277 mappM_ kc_sig (filter isClassOpSig class_sigs)
279 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
281 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
282 -- Extend the env with bindings for the tyvars, taken from
283 -- the kind of the tycon/class. Give it to the thing inside, and
284 -- check the result kind matches
285 kcTyClDeclBody decl thing_inside
286 = tcAddDeclCtxt decl $
287 tcLookup (tcdName decl) `thenM` \ thing ->
290 AGlobal (ATyCon tc) -> tyConKind tc
291 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
293 -- For some odd reason, a class doesn't include its kind
295 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
297 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
302 %************************************************************************
304 \subsection{Step 4: Building the tycon/class}
306 %************************************************************************
310 :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
312 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
313 -> RenamedTyClDecl -> TyThing
315 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
316 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
319 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
320 tycon_kind = lookupNameEnv_NF kenv tycon_name
321 arity = length tyvar_names
322 tyvars = mkTyClTyVars tycon_kind tyvar_names
323 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
324 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
326 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
327 (TyData {tcdND = data_or_new, tcdName = tycon_name,
328 tcdTyVars = tyvar_names})
331 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
332 data_cons sel_ids flavour
333 (rec_tycon tycon_name flavour) gen_info
335 DataTyDetails ctxt data_cons sel_ids gen_info = 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_nullary data_cons -> EnumTyCon
346 | otherwise -> DataTyCon
348 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
349 all_nullary other = False -- Safe choice for unknown data types
350 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
351 -- but that looks at the *representation* arity, and that in turn
352 -- depends on deciding whether to unpack the args, and that
353 -- depends on whether it's a data type or a newtype --- so
354 -- in the recursive case we can get a loop. This version is simple!
356 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
357 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
358 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
360 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
361 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
364 clas = mkClass class_name tyvars fds
365 sc_theta sc_sel_ids op_items
368 tycon = mkClassTyCon tycon_name class_kind tyvars
370 clas -- Yes! It's a dictionary
372 (rec_tycon class_name flavour)
373 -- A class can be recursive, and in the case of newtypes
374 -- this matters. For example
375 -- class C a where { op :: C b => a -> b -> Int }
376 -- Because C has only one operation, it is represented by
377 -- a newtype, and it should be a *recursive* newtype.
378 -- [If we don't make it a recursive newtype, we'll expand the
379 -- newtype like a synonym, but that will lead toan inifinite type
381 ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name
382 = lookupNameEnv_NF rec_details class_name
384 class_kind = lookupNameEnv_NF kenv class_name
385 tyvars = mkTyClTyVars class_kind tyvar_names
386 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
388 flavour = case dataConOrigArgTys dict_con of
389 -- The tyvars in the datacon are the same as in the class
390 [rep_ty] -> NewTyCon rep_ty
393 -- We can find the functional dependencies right away,
394 -- and it is vital to do so. Why? Because in the next pass
395 -- we check for ambiguity in all the type signatures, and we
396 -- need the functional dependcies to be done by then
397 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
398 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
399 lookup = lookupNameEnv_NF tyvar_env
401 bogusVrcs = panic "Bogus tycon arg variances"
405 mkNewTyConRep :: TyCon -- The original type constructor
406 -> Type -- Chosen representation type
407 -- (guaranteed not to be another newtype)
409 -- Find the representation type for this newtype TyCon
411 -- The non-recursive newtypes are easy, because they look transparent
412 -- to splitTyConApp_maybe, but recursive ones really are represented as
413 -- TyConApps (see TypeRep).
415 -- The trick is to to deal correctly with recursive newtypes
416 -- such as newtype T = MkT T
421 -- Invariant: tc is a NewTyCon
422 -- tcs have been seen before
424 | tc `elem` tcs = unitTy
427 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
429 case splitTyConApp_maybe rep_ty of
431 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
432 | otherwise -> go1 (tc:tcs) tc' tys
434 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
437 %************************************************************************
439 \subsection{Dependency analysis}
441 %************************************************************************
446 checkLoops :: RecFlag -> [RenamedTyClDecl]
447 -> TcM (Name -> AlgTyConFlavour -> RecFlag)
448 -- Check for illegal loops,
450 -- b) superclass hierarchy
452 -- Also return a function that says which tycons are recursive.
454 -- a newtype is recursive if it is part of a recursive
455 -- group consisting only of newtype and synonyms
457 checkLoops is_rec decls
459 = returnM (\ _ _ -> NonRecursive)
461 | otherwise -- Recursive group
462 = let -- CHECK FOR CLASS CYCLES
463 cls_edges = mapMaybe mkClassEdges decls
464 cls_cycles = findCycles cls_edges
466 mapM_ (cycleErr "class") cls_cycles `thenM_`
468 let -- CHECK FOR SYNONYM CYCLES
469 syn_edges = map mkEdges (filter isSynDecl decls)
470 syn_cycles = findCycles syn_edges
472 mapM_ (cycleErr "type synonym") syn_cycles `thenM_`
474 let -- CHECK FOR NEWTYPE CYCLES
475 newtype_edges = map mkEdges (filter is_nt_cycle_decl decls)
476 newtype_cycles = findCycles newtype_edges
477 rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
479 rec_tycon name (NewTyCon _)
480 | name `elemNameSet` rec_newtypes = Recursive
481 | otherwise = NonRecursive
482 rec_tycon name other_flavour = Recursive
486 ----------------------------------------------------
487 -- A class with one op and no superclasses, or vice versa,
488 -- is treated just like a newtype.
489 -- It's a bit unclean that this test is repeated in buildTyConOrClass
490 is_nt_cycle_decl (TySynonym {}) = True
491 is_nt_cycle_decl (TyData {tcdND = NewType}) = True
492 is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1
493 is_nt_cycle_decl other = False
495 ----------------------------------------------------
496 findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
498 ----------------------------------------------------
499 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
500 mkEdges decl = (decl, tyClDeclName decl, nameSetToList (tyClDeclFVs decl))
502 ----------------------------------------------------
503 -- mk_cls_edges looks only at the context of class decls
504 -- Its used when we are figuring out if there's a cycle in the
505 -- superclass hierarchy
507 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
508 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
509 mkClassEdges other_decl = Nothing
513 %************************************************************************
515 \subsection{Error management
517 %************************************************************************
520 cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
522 cycleErr kind_of_decl decls
523 = addErrAt loc (ppr_cycle kind_of_decl decls)
525 loc = tcdLoc (head decls)
527 ppr_cycle kind_of_decl decls
528 = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
529 4 (vcat (map pp_decl decls))
531 pp_decl decl = hsep [quotes (ppr (tcdName decl)),
532 ptext SLIT("at"), ppr (tcdLoc decl)]