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 ( implicitTyThings )
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 TcGblEnv -- Returns extended environment
66 tcTyAndClassDecls decls
67 = tcGroups (stronglyConnComp edges)
69 edges = map mkEdges (filter isTypeOrClassDecl decls)
71 tcGroups [] = getGblEnv
73 tcGroups (group:groups)
74 = tcGroup group `thenM` \ env ->
81 Consider a mutually-recursive group, binding
82 a type constructor T and a class C.
84 Step 1: getInitialKind
85 Construct a KindEnv by binding T and C to a kind variable
88 In that environment, do a kind check
90 Step 3: Zonk the kinds
92 Step 4: buildTyConOrClass
93 Construct an environment binding T to a TyCon and C to a Class.
94 a) Their kinds comes from zonking the relevant kind variable
95 b) Their arity (for synonyms) comes direct from the decl
96 c) The funcional dependencies come from the decl
97 d) The rest comes a knot-tied binding of T and C, returned from Step 4
98 e) The variances of the tycons in the group is calculated from
102 In this environment, walk over the decls, constructing the TyCons and Classes.
103 This uses in a strict way items (a)-(c) above, which is why they must
104 be constructed in Step 4. Feed the results back to Step 4.
105 For this step, pass the is-recursive flag as the wimp-out flag
109 Step 6: Extend environment
110 We extend the type environment with bindings not only for the TyCons and Classes,
111 but also for their "implicit Ids" like data constructors and class selectors
113 Step 7: checkValidTyCl
114 For a recursive group only, check all the decls again, just
115 to check all the side conditions on validity. We could not
116 do this before because we were in a mutually recursive knot.
119 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
120 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
123 tcGroup :: SCC RenamedTyClDecl
124 -> TcM TcGblEnv -- Input env extended by types and classes
125 -- and their implicit Ids,DataCons
129 mappM getInitialKind decls `thenM` \ initial_kinds ->
132 tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_`
135 zonkKindEnv initial_kinds `thenM` \ final_kinds ->
137 -- Check for loops; if any are found, bale out now
138 -- because the compiler itself will loop otherwise!
139 checkNoErrs (checkLoops scc) `thenM` \ is_rec_tycon ->
142 traceTc (text "starting" <+> ppr final_kinds) `thenM_`
143 fixM ( \ ~(rec_details_list, _, rec_all_tyclss) ->
146 kind_env = mkNameEnv final_kinds
147 rec_details = mkNameEnv rec_details_list
149 -- Calculate variances, and feed into buildTyConOrClass
150 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- rec_all_tyclss]
152 build_one = buildTyConOrClass is_rec_tycon kind_env
154 tyclss = map build_one decls
158 -- Extend the environment with the final
159 -- TyCons/Classes and check the decls
160 tcExtendGlobalEnv tyclss $
161 mappM tcTyClDecl1 decls `thenM` \ tycls_details ->
164 getGblEnv `thenM` \ env ->
165 returnM (tycls_details, env, tyclss)
166 ) `thenM` \ (_, env, tyclss) ->
168 -- Step 7: Check validity
171 traceTc (text "ready for validity check") `thenM_`
172 getModule `thenM` \ mod ->
173 mappM_ (checkValidTyCl mod) decls `thenM_`
174 traceTc (text "done") `thenM_`
176 let -- Add the tycons that come from the classes
177 -- We want them in the environment because
178 -- they are mentioned in interface files
179 implicit_things = implicitTyThings tyclss
181 traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_`
182 tcExtendGlobalEnv implicit_things getGblEnv
186 AcyclicSCC decl -> [decl]
187 CyclicSCC decls -> decls
190 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
191 | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
193 -- We do the validity check over declarations, rather than TyThings
194 -- only so that we can add a nice context with tcAddDeclCtxt
195 checkValidTyCl this_mod decl
196 = tcLookupGlobal (tcdName decl) `thenM` \ thing ->
197 if not (isLocalThing this_mod thing) then
198 -- Don't bother to check validity for non-local things
203 ATyCon tc -> checkValidTyCon tc
204 AClass cl -> checkValidClass cl
208 %************************************************************************
210 \subsection{Step 1: Initial environment}
212 %************************************************************************
215 getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
217 = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds ->
218 newKindVar `thenM` \ result_kind ->
219 returnM (tcdName decl, mk_kind arg_kinds result_kind)
221 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
225 %************************************************************************
227 \subsection{Step 2: Kind checking}
229 %************************************************************************
231 We need to kind check all types in the mutually recursive group
232 before we know the kind of the type variables. For example:
235 op :: D b => a -> b -> b
238 bop :: (Monad c) => ...
240 Here, the kind of the locally-polymorphic type variable "b"
241 depends on *all the uses of class D*. For example, the use of
242 Monad c in bop's type signature means that D must have kind Type->Type.
245 kcTyClDecl :: RenamedTyClDecl -> TcM ()
247 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
248 = kcTyClDeclBody decl $ \ result_kind ->
249 kcHsType rhs `thenM` \ rhs_kind ->
250 unifyKind result_kind rhs_kind
252 kcTyClDecl (ForeignType {}) = returnM ()
254 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
255 = kcTyClDeclBody decl $ \ result_kind ->
256 kcHsContext context `thenM_`
257 mappM_ kc_con_decl (visibleDataCons con_decls)
259 kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
260 = kcHsTyVars ex_tvs `thenM` \ kind_env ->
261 tcExtendKindEnv kind_env $
262 kcConDetails new_or_data ex_ctxt details
264 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
265 = kcTyClDeclBody decl $ \ result_kind ->
266 kcHsContext context `thenM_`
267 mappM_ kc_sig (filter isClassOpSig class_sigs)
269 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
271 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
272 -- Extend the env with bindings for the tyvars, taken from
273 -- the kind of the tycon/class. Give it to the thing inside, and
274 -- check the result kind matches
275 kcTyClDeclBody decl thing_inside
276 = tcAddDeclCtxt decl $
277 tcLookup (tcdName decl) `thenM` \ thing ->
280 AGlobal (ATyCon tc) -> tyConKind tc
281 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
283 -- For some odd reason, a class doesn't include its kind
285 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
287 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
292 %************************************************************************
294 \subsection{Step 4: Building the tycon/class}
296 %************************************************************************
300 :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
302 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
303 -> RenamedTyClDecl -> TyThing
305 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
306 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
309 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
310 tycon_kind = lookupNameEnv_NF kenv tycon_name
311 arity = length tyvar_names
312 tyvars = mkTyClTyVars tycon_kind tyvar_names
313 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
314 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
316 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
317 (TyData {tcdND = data_or_new, tcdName = tycon_name,
318 tcdTyVars = tyvar_names})
321 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
322 data_cons sel_ids flavour
323 (rec_tycon tycon_name flavour) gen_info
325 DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name
327 tycon_kind = lookupNameEnv_NF kenv tycon_name
328 tyvars = mkTyClTyVars tycon_kind tyvar_names
329 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
331 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
332 -- so flavour has to be able to answer this question without consulting rec_details
333 flavour = case data_or_new of
334 NewType -> NewTyCon (mkNewTyConRep tycon)
335 DataType | all_nullary data_cons -> EnumTyCon
336 | otherwise -> DataTyCon
338 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
339 all_nullary other = False -- Safe choice for unknown data types
340 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
341 -- but that looks at the *representation* arity, and that in turn
342 -- depends on deciding whether to unpack the args, and that
343 -- depends on whether it's a data type or a newtype --- so
344 -- in the recursive case we can get a loop. This version is simple!
346 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
347 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
348 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
350 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
351 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
354 clas = mkClass class_name tyvars fds
355 sc_theta sc_sel_ids op_items
358 tycon = mkClassTyCon tycon_name class_kind tyvars
360 clas -- Yes! It's a dictionary
362 (rec_tycon class_name flavour)
363 -- A class can be recursive, and in the case of newtypes
364 -- this matters. For example
365 -- class C a where { op :: C b => a -> b -> Int }
366 -- Because C has only one operation, it is represented by
367 -- a newtype, and it should be a *recursive* newtype.
368 -- [If we don't make it a recursive newtype, we'll expand the
369 -- newtype like a synonym, but that will lead toan inifinite type
371 ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name
372 = lookupNameEnv_NF rec_details class_name
374 class_kind = lookupNameEnv_NF kenv class_name
375 tyvars = mkTyClTyVars class_kind tyvar_names
376 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
378 flavour = case dataConOrigArgTys dict_con of
379 -- The tyvars in the datacon are the same as in the class
380 [rep_ty] -> NewTyCon rep_ty
383 -- We can find the functional dependencies right away,
384 -- and it is vital to do so. Why? Because in the next pass
385 -- we check for ambiguity in all the type signatures, and we
386 -- need the functional dependcies to be done by then
387 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
388 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
389 lookup = lookupNameEnv_NF tyvar_env
391 bogusVrcs = panic "Bogus tycon arg variances"
395 mkNewTyConRep :: TyCon -- The original type constructor
396 -> Type -- Chosen representation type
397 -- (guaranteed not to be another newtype)
399 -- Find the representation type for this newtype TyCon
400 -- Remember that the representation type is the ultimate representation
401 -- type, looking through other newtypes.
403 -- The non-recursive newtypes are easy, because they look transparent
404 -- to splitTyConApp_maybe, but recursive ones really are represented as
405 -- TyConApps (see TypeRep).
407 -- The trick is to to deal correctly with recursive newtypes
408 -- such as newtype T = MkT T
413 -- Invariant: tc is a NewTyCon
414 -- tcs have been seen before
416 | tc `elem` tcs = unitTy
419 rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
421 case splitTyConApp_maybe rep_ty of
423 Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
424 | otherwise -> go1 (tc:tcs) tc' tys
426 go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
429 %************************************************************************
431 \subsection{Dependency analysis}
433 %************************************************************************
438 checkLoops :: SCC RenamedTyClDecl
439 -> TcM (Name -> AlgTyConFlavour -> RecFlag)
440 -- Check for illegal loops,
442 -- b) superclass hierarchy
444 -- Also return a function that says which tycons are recursive.
446 -- a newtype is recursive if it is part of a recursive
447 -- group consisting only of newtype and synonyms
449 checkLoops (AcyclicSCC _)
450 = returnM (\ _ _ -> NonRecursive)
452 checkLoops (CyclicSCC decls)
453 = let -- CHECK FOR CLASS CYCLES
454 cls_edges = mapMaybe mkClassEdges decls
455 cls_cycles = findCycles cls_edges
457 mapM_ (cycleErr "class") cls_cycles `thenM_`
459 let -- CHECK FOR SYNONYM CYCLES
460 syn_edges = map mkEdges (filter isSynDecl decls)
461 syn_cycles = findCycles syn_edges
463 mapM_ (cycleErr "type synonym") syn_cycles `thenM_`
465 let -- CHECK FOR NEWTYPE CYCLES
466 newtype_edges = map mkEdges (filter is_nt_cycle_decl decls)
467 newtype_cycles = findCycles newtype_edges
468 rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
470 rec_tycon name (NewTyCon _)
471 | name `elemNameSet` rec_newtypes = Recursive
472 | otherwise = NonRecursive
473 rec_tycon name other_flavour = Recursive
477 ----------------------------------------------------
478 -- A class with one op and no superclasses, or vice versa,
479 -- is treated just like a newtype.
480 -- It's a bit unclean that this test is repeated in buildTyConOrClass
481 is_nt_cycle_decl (TySynonym {}) = True
482 is_nt_cycle_decl (TyData {tcdND = NewType}) = True
483 is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1
484 is_nt_cycle_decl other = False
486 ----------------------------------------------------
487 findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
489 ----------------------------------------------------
490 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
491 mkEdges decl = (decl, tyClDeclName decl, nameSetToList (tyClDeclFVs decl))
493 ----------------------------------------------------
494 -- mk_cls_edges looks only at the context of class decls
495 -- Its used when we are figuring out if there's a cycle in the
496 -- superclass hierarchy
498 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
504 %************************************************************************
506 \subsection{Error management
508 %************************************************************************
511 cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
513 cycleErr kind_of_decl decls
514 = addErrAt loc (ppr_cycle kind_of_decl decls)
516 loc = tcdLoc (head decls)
518 ppr_cycle kind_of_decl decls
519 = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
520 4 (vcat (map pp_decl decls))
522 pp_decl decl = hsep [quotes (ppr (tcdName decl)),
523 ptext SLIT("at"), ppr (tcdLoc decl)]