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(..), 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(..) )
50 import Maybes ( mapMaybe )
54 %************************************************************************
56 \subsection{Type checking for type and class declarations}
58 %************************************************************************
63 tcTyAndClassDecls :: [RenamedTyClDecl]
64 -> TcM [TyThing] -- Returns newly defined things:
65 -- types, classes and implicit Ids
67 tcTyAndClassDecls decls
68 = tcGroups (stronglyConnComp edges)
70 edges = map mkEdges (filter isTypeOrClassDecl decls)
75 tcGroups (group:groups)
76 = tcGroup group `thenM` \ (env, new_things1) ->
78 tcGroups groups `thenM` \ new_things2 ->
79 returnM (new_things1 ++ new_things2)
84 Consider a mutually-recursive group, binding
85 a type constructor T and a class C.
87 Step 1: getInitialKind
88 Construct a KindEnv by binding T and C to a kind variable
91 In that environment, do a kind check
93 Step 3: Zonk the kinds
95 Step 4: buildTyConOrClass
96 Construct an environment binding T to a TyCon and C to a Class.
97 a) Their kinds comes from zonking the relevant kind variable
98 b) Their arity (for synonyms) comes direct from the decl
99 c) The funcional dependencies come from the decl
100 d) The rest comes a knot-tied binding of T and C, returned from Step 4
101 e) The variances of the tycons in the group is calculated from
105 In this environment, walk over the decls, constructing the TyCons and Classes.
106 This uses in a strict way items (a)-(c) above, which is why they must
107 be constructed in Step 4. Feed the results back to Step 4.
108 For this step, pass the is-recursive flag as the wimp-out flag
112 Step 6: Extend environment
113 We extend the type environment with bindings not only for the TyCons and Classes,
114 but also for their "implicit Ids" like data constructors and class selectors
116 Step 7: checkValidTyCl
117 For a recursive group only, check all the decls again, just
118 to check all the side conditions on validity. We could not
119 do this before because we were in a mutually recursive knot.
122 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
123 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
126 tcGroup :: SCC RenamedTyClDecl
127 -> TcM (TcGblEnv, -- Input env extended by types and classes only
128 [TyThing]) -- Things defined by this group
132 mappM getInitialKind decls `thenM` \ initial_kinds ->
135 tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_`
138 zonkKindEnv initial_kinds `thenM` \ final_kinds ->
140 -- Check for loops; if any are found, bale out now
141 -- because the compiler itself will loop otherwise!
142 checkNoErrs (checkLoops scc) `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 decl -> [decl]
193 CyclicSCC decls -> decls
196 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
197 | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
199 -- We do the validity check over declarations, rather than TyThings
200 -- only so that we can add a nice context with tcAddDeclCtxt
201 checkValidTyCl this_mod decl
202 = tcLookupGlobal (tcdName decl) `thenM` \ thing ->
203 if not (isLocalThing this_mod thing) then
204 -- Don't bother to check validity for non-local things
209 ATyCon tc -> checkValidTyCon tc
210 AClass cl -> checkValidClass cl
214 %************************************************************************
216 \subsection{Step 1: Initial environment}
218 %************************************************************************
221 getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
223 = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds ->
224 newKindVar `thenM` \ result_kind ->
225 returnM (tcdName decl, mk_kind arg_kinds result_kind)
227 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
231 %************************************************************************
233 \subsection{Step 2: Kind checking}
235 %************************************************************************
237 We need to kind check all types in the mutually recursive group
238 before we know the kind of the type variables. For example:
241 op :: D b => a -> b -> b
244 bop :: (Monad c) => ...
246 Here, the kind of the locally-polymorphic type variable "b"
247 depends on *all the uses of class D*. For example, the use of
248 Monad c in bop's type signature means that D must have kind Type->Type.
251 kcTyClDecl :: RenamedTyClDecl -> TcM ()
253 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
254 = kcTyClDeclBody decl $ \ result_kind ->
255 kcHsType rhs `thenM` \ rhs_kind ->
256 unifyKind result_kind rhs_kind
258 kcTyClDecl (ForeignType {}) = returnM ()
260 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
261 = kcTyClDeclBody decl $ \ result_kind ->
262 kcHsContext context `thenM_`
263 mappM_ kc_con_decl (visibleDataCons con_decls)
265 kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
266 = kcHsTyVars ex_tvs `thenM` \ kind_env ->
267 tcExtendKindEnv kind_env $
268 kcConDetails new_or_data ex_ctxt details
270 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
271 = kcTyClDeclBody decl $ \ result_kind ->
272 kcHsContext context `thenM_`
273 mappM_ kc_sig (filter isClassOpSig class_sigs)
275 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
277 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
278 -- Extend the env with bindings for the tyvars, taken from
279 -- the kind of the tycon/class. Give it to the thing inside, and
280 -- check the result kind matches
281 kcTyClDeclBody decl thing_inside
282 = tcAddDeclCtxt decl $
283 tcLookup (tcdName decl) `thenM` \ thing ->
286 AGlobal (ATyCon tc) -> tyConKind tc
287 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
289 -- For some odd reason, a class doesn't include its kind
291 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
293 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
298 %************************************************************************
300 \subsection{Step 4: Building the tycon/class}
302 %************************************************************************
306 :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
308 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
309 -> RenamedTyClDecl -> TyThing
311 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
312 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
315 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
316 tycon_kind = lookupNameEnv_NF kenv tycon_name
317 arity = length tyvar_names
318 tyvars = mkTyClTyVars tycon_kind tyvar_names
319 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
320 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
322 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
323 (TyData {tcdND = data_or_new, tcdName = tycon_name,
324 tcdTyVars = tyvar_names})
327 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
328 data_cons sel_ids flavour
329 (rec_tycon tycon_name flavour) gen_info
331 DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name
333 tycon_kind = lookupNameEnv_NF kenv tycon_name
334 tyvars = mkTyClTyVars tycon_kind tyvar_names
335 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
337 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
338 -- so flavour has to be able to answer this question without consulting rec_details
339 flavour = case data_or_new of
340 NewType -> NewTyCon (mkNewTyConRep tycon)
341 DataType | all_nullary data_cons -> EnumTyCon
342 | otherwise -> DataTyCon
344 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
345 all_nullary other = False -- Safe choice for unknown data types
346 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
347 -- but that looks at the *representation* arity, and that in turn
348 -- depends on deciding whether to unpack the args, and that
349 -- depends on whether it's a data type or a newtype --- so
350 -- in the recursive case we can get a loop. This version is simple!
352 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
353 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
354 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
356 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
357 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
360 clas = mkClass class_name tyvars fds
361 sc_theta sc_sel_ids op_items
364 tycon = mkClassTyCon tycon_name class_kind tyvars
366 clas -- Yes! It's a dictionary
368 (rec_tycon class_name flavour)
369 -- A class can be recursive, and in the case of newtypes
370 -- this matters. For example
371 -- class C a where { op :: C b => a -> b -> Int }
372 -- Because C has only one operation, it is represented by
373 -- a newtype, and it should be a *recursive* newtype.
374 -- [If we don't make it a recursive newtype, we'll expand the
375 -- newtype like a synonym, but that will lead toan inifinite type
377 ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name
378 = lookupNameEnv_NF rec_details class_name
380 class_kind = lookupNameEnv_NF kenv class_name
381 tyvars = mkTyClTyVars class_kind tyvar_names
382 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
384 flavour = case dataConOrigArgTys dict_con of
385 -- The tyvars in the datacon are the same as in the class
386 [rep_ty] -> NewTyCon rep_ty
389 -- We can find the functional dependencies right away,
390 -- and it is vital to do so. Why? Because in the next pass
391 -- we check for ambiguity in all the type signatures, and we
392 -- need the functional dependcies to be done by then
393 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
394 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
395 lookup = lookupNameEnv_NF tyvar_env
397 bogusVrcs = panic "Bogus tycon arg variances"
401 mkNewTyConRep :: TyCon -- The original type constructor
402 -> Type -- Chosen representation type
403 -- (guaranteed not to be another newtype)
405 -- Find the representation type for this newtype TyCon
407 -- The non-recursive newtypes are easy, because they look transparent
408 -- to splitTyConApp_maybe, but recursive ones really are represented as
409 -- TyConApps (see TypeRep).
411 -- The trick is to to deal correctly with recursive newtypes
412 -- such as newtype T = MkT T
417 -- Invariant: tc is a NewTyCon
418 -- tcs have been seen before
420 | tc `elem` tcs = unitTy
423 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
425 case splitTyConApp_maybe rep_ty of
427 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
428 | otherwise -> go1 (tc:tcs) tc' tys
430 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
433 %************************************************************************
435 \subsection{Dependency analysis}
437 %************************************************************************
442 checkLoops :: SCC RenamedTyClDecl
443 -> TcM (Name -> AlgTyConFlavour -> RecFlag)
444 -- Check for illegal loops,
446 -- b) superclass hierarchy
448 -- Also return a function that says which tycons are recursive.
450 -- a newtype is recursive if it is part of a recursive
451 -- group consisting only of newtype and synonyms
453 checkLoops (AcyclicSCC _)
454 = returnM (\ _ _ -> NonRecursive)
456 checkLoops (CyclicSCC decls)
457 = let -- CHECK FOR CLASS CYCLES
458 cls_edges = mapMaybe mkClassEdges decls
459 cls_cycles = findCycles cls_edges
461 mapM_ (cycleErr "class") cls_cycles `thenM_`
463 let -- CHECK FOR SYNONYM CYCLES
464 syn_edges = map mkEdges (filter isSynDecl decls)
465 syn_cycles = findCycles syn_edges
467 mapM_ (cycleErr "type synonym") syn_cycles `thenM_`
469 let -- CHECK FOR NEWTYPE CYCLES
470 newtype_edges = map mkEdges (filter is_nt_cycle_decl decls)
471 newtype_cycles = findCycles newtype_edges
472 rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
474 rec_tycon name (NewTyCon _)
475 | name `elemNameSet` rec_newtypes = Recursive
476 | otherwise = NonRecursive
477 rec_tycon name other_flavour = Recursive
481 ----------------------------------------------------
482 -- A class with one op and no superclasses, or vice versa,
483 -- is treated just like a newtype.
484 -- It's a bit unclean that this test is repeated in buildTyConOrClass
485 is_nt_cycle_decl (TySynonym {}) = True
486 is_nt_cycle_decl (TyData {tcdND = NewType}) = True
487 is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1
488 is_nt_cycle_decl other = False
490 ----------------------------------------------------
491 findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
493 ----------------------------------------------------
494 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
495 mkEdges decl = (decl, tyClDeclName decl, nameSetToList (tyClDeclFVs decl))
497 ----------------------------------------------------
498 -- mk_cls_edges looks only at the context of class decls
499 -- Its used when we are figuring out if there's a cycle in the
500 -- superclass hierarchy
502 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
503 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
504 mkClassEdges other_decl = Nothing
508 %************************************************************************
510 \subsection{Error management
512 %************************************************************************
515 cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
517 cycleErr kind_of_decl decls
518 = addErrAt loc (ppr_cycle kind_of_decl decls)
520 loc = tcdLoc (head decls)
522 ppr_cycle kind_of_decl decls
523 = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
524 4 (vcat (map pp_decl decls))
526 pp_decl decl = hsep [quotes (ppr (tcdName decl)),
527 ptext SLIT("at"), ppr (tcdLoc decl)]