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 RnEnv ( lookupSysName )
20 import BasicTypes ( RecFlag(..), NewOrData(..) )
21 import HscTypes ( implicitTyThings )
24 import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..),
25 tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
27 import TcTyDecls ( tcTyDecl, kcConDetails )
28 import TcClassDcl ( tcClassDecl1 )
29 import TcInstDcls ( tcAddDeclCtxt )
30 import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
31 import TcMType ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
32 import TcUnify ( unifyKind )
33 import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
34 import Type ( splitTyConApp_maybe )
35 import Variance ( calcTyConArgVrcs )
36 import Class ( Class, mkClass, classTyCon )
37 import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
38 tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
39 mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon
41 import TysWiredIn ( unitTy )
42 import Subst ( substTyWith )
43 import DataCon ( dataConOrigArgTys )
44 import Var ( varName )
45 import OccName ( mkClassTyConOcc )
47 import Digraph ( stronglyConnComp, SCC(..) )
52 import Maybes ( mapMaybe, orElse, catMaybes )
56 %************************************************************************
58 \subsection{Type checking for type and class declarations}
60 %************************************************************************
65 tcTyAndClassDecls :: [RenamedTyClDecl]
66 -> TcM TcGblEnv -- Returns extended environment
68 tcTyAndClassDecls decls
69 = do { edge_map <- mkEdgeMap tc_decls ;
70 let { edges = mkEdges edge_map tc_decls } ;
71 tcGroups edge_map (stronglyConnComp edges) }
73 tc_decls = filter isTypeOrClassDecl decls
75 tcGroups edge_map [] = getGblEnv
77 tcGroups edge_map (group:groups)
78 = tcGroup edge_map group `thenM` \ env ->
80 tcGroups edge_map groups
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 :: EdgeMap -> SCC RenamedTyClDecl
128 -> TcM TcGblEnv -- Input env extended by types and classes
129 -- and their implicit Ids,DataCons
133 mappM getInitialKind decls `thenM` \ initial_kinds ->
136 tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_`
139 zonkKindEnv initial_kinds `thenM` \ final_kinds ->
141 -- Check for loops; if any are found, bale out now
142 -- because the compiler itself will loop otherwise!
143 checkNoErrs (checkLoops edge_map scc) `thenM` \ is_rec_tycon ->
146 traceTc (text "starting" <+> ppr final_kinds) `thenM_`
147 fixM ( \ ~(rec_details_list, _, _) ->
150 kind_env = mkNameEnv final_kinds
151 rec_details = mkNameEnv rec_details_list
153 -- Calculate variances, and feed into buildTyConOrClass
154 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- tyclss]
156 build_one = buildTyConOrClass is_rec_tycon kind_env
158 tyclss = map build_one decls
162 -- Extend the environment with the final
163 -- TyCons/Classes and check the decls
164 tcExtendGlobalEnv tyclss $
165 mappM tcTyClDecl1 decls `thenM` \ tycls_details ->
168 getGblEnv `thenM` \ env ->
169 returnM (tycls_details, env, tyclss)
170 ) `thenM` \ (_, env, tyclss) ->
172 -- Step 7: Check validity
175 traceTc (text "ready for validity check") `thenM_`
176 getModule `thenM` \ mod ->
177 mappM_ (checkValidTyCl mod) decls `thenM_`
178 traceTc (text "done") `thenM_`
180 let -- Add the tycons that come from the classes
181 -- We want them in the environment because
182 -- they are mentioned in interface files
183 implicit_things = implicitTyThings tyclss
185 traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_`
186 tcExtendGlobalEnv implicit_things getGblEnv
190 AcyclicSCC decl -> [decl]
191 CyclicSCC decls -> decls
194 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
195 | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
197 -- We do the validity check over declarations, rather than TyThings
198 -- only so that we can add a nice context with tcAddDeclCtxt
199 checkValidTyCl this_mod decl
200 = tcLookupGlobal (tcdName decl) `thenM` \ thing ->
201 if not (isLocalThing this_mod thing) then
202 -- Don't bother to check validity for non-local things
207 ATyCon tc -> checkValidTyCon tc
208 AClass cl -> checkValidClass cl
212 %************************************************************************
214 \subsection{Step 1: Initial environment}
216 %************************************************************************
219 getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
221 = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds ->
222 newKindVar `thenM` \ result_kind ->
223 returnM (tcdName decl, mk_kind arg_kinds result_kind)
225 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
229 %************************************************************************
231 \subsection{Step 2: Kind checking}
233 %************************************************************************
235 We need to kind check all types in the mutually recursive group
236 before we know the kind of the type variables. For example:
239 op :: D b => a -> b -> b
242 bop :: (Monad c) => ...
244 Here, the kind of the locally-polymorphic type variable "b"
245 depends on *all the uses of class D*. For example, the use of
246 Monad c in bop's type signature means that D must have kind Type->Type.
249 kcTyClDecl :: RenamedTyClDecl -> TcM ()
251 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
252 = kcTyClDeclBody decl $ \ result_kind ->
253 kcHsType rhs `thenM` \ rhs_kind ->
254 unifyKind result_kind rhs_kind
256 kcTyClDecl (ForeignType {}) = returnM ()
258 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
259 = kcTyClDeclBody decl $ \ result_kind ->
260 kcHsContext context `thenM_`
261 mappM_ kc_con_decl (visibleDataCons con_decls)
263 kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
264 = kcHsTyVars ex_tvs `thenM` \ kind_env ->
265 tcExtendKindEnv kind_env $
266 kcConDetails new_or_data ex_ctxt details
268 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
269 = kcTyClDeclBody decl $ \ result_kind ->
270 kcHsContext context `thenM_`
271 mappM_ kc_sig (filter isClassOpSig class_sigs)
273 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
275 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
276 -- Extend the env with bindings for the tyvars, taken from
277 -- the kind of the tycon/class. Give it to the thing inside, and
278 -- check the result kind matches
279 kcTyClDeclBody decl thing_inside
280 = tcAddDeclCtxt decl $
281 tcLookup (tcdName decl) `thenM` \ thing ->
284 AGlobal (ATyCon tc) -> tyConKind tc
285 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
287 -- For some odd reason, a class doesn't include its kind
289 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
291 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
296 %************************************************************************
298 \subsection{Step 4: Building the tycon/class}
300 %************************************************************************
304 :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
306 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
307 -> RenamedTyClDecl -> TyThing
309 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
310 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
313 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
314 tycon_kind = lookupNameEnv_NF kenv tycon_name
315 arity = length tyvar_names
316 tyvars = mkTyClTyVars tycon_kind tyvar_names
317 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
318 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
320 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
321 (TyData {tcdND = data_or_new, tcdName = tycon_name,
322 tcdTyVars = tyvar_names})
325 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
326 data_cons sel_ids flavour
327 (rec_tycon tycon_name flavour) gen_info
329 DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name
331 tycon_kind = lookupNameEnv_NF kenv tycon_name
332 tyvars = mkTyClTyVars tycon_kind tyvar_names
333 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
335 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
336 -- so flavour has to be able to answer this question without consulting rec_details
337 flavour = case data_or_new of
338 NewType -> NewTyCon (mkNewTyConRep tycon)
339 DataType | all_nullary data_cons -> EnumTyCon
340 | otherwise -> DataTyCon
342 all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
343 all_nullary other = False -- Safe choice for unknown data types
344 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
345 -- but that looks at the *representation* arity, and that in turn
346 -- depends on deciding whether to unpack the args, and that
347 -- depends on whether it's a data type or a newtype --- so
348 -- in the recursive case we can get a loop. This version is simple!
350 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
351 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
352 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
354 buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
355 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
358 clas = mkClass class_name tyvars fds
359 sc_theta sc_sel_ids op_items
362 tycon = mkClassTyCon tycon_name class_kind tyvars
364 clas -- Yes! It's a dictionary
366 (rec_tycon class_name flavour)
367 -- A class can be recursive, and in the case of newtypes
368 -- this matters. For example
369 -- class C a where { op :: C b => a -> b -> Int }
370 -- Because C has only one operation, it is represented by
371 -- a newtype, and it should be a *recursive* newtype.
372 -- [If we don't make it a recursive newtype, we'll expand the
373 -- newtype like a synonym, but that will lead toan inifinite type
375 ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name
376 = lookupNameEnv_NF rec_details class_name
378 class_kind = lookupNameEnv_NF kenv class_name
379 tyvars = mkTyClTyVars class_kind tyvar_names
380 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
382 flavour = case dataConOrigArgTys dict_con of
383 -- The tyvars in the datacon are the same as in the class
384 [rep_ty] -> NewTyCon rep_ty
387 -- We can find the functional dependencies right away,
388 -- and it is vital to do so. Why? Because in the next pass
389 -- we check for ambiguity in all the type signatures, and we
390 -- need the functional dependcies to be done by then
391 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
392 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
393 lookup = lookupNameEnv_NF tyvar_env
395 bogusVrcs = panic "Bogus tycon arg variances"
399 mkNewTyConRep :: TyCon -- The original type constructor
400 -> Type -- Chosen representation type
401 -- (guaranteed not to be another newtype)
403 -- Find the representation type for this newtype TyCon
404 -- Remember that the representation type is the ultimate representation
405 -- type, looking through other newtypes.
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 :: EdgeMap -> SCC RenamedTyClDecl
443 -> TcM (Name -> AlgTyConFlavour -> RecFlag)
444 -- Check for illegal loops in a single strongly-connected component
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 edge_map (AcyclicSCC _)
454 = returnM (\ _ _ -> NonRecursive)
456 checkLoops edge_map (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 = mkEdges edge_map (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 = mkEdges edge_map (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 -- Building edges for SCC analysis
496 -- When building the edges, we treat the 'main name' of the declaration as the
497 -- key for the node, but when dealing with External Core we may come across
498 -- references to one of the implicit names for the declaration. For example:
499 -- class Eq a where ....
500 -- data :TSig a = :TSig (:TEq a) ....
501 -- The first decl is sucked in from an interface file; the second
502 -- is in an External Core file, generated from a class decl for Sig.
503 -- We have to recognise that the reference to :TEq represents a
504 -- dependency on the class Eq declaration, else the SCC stuff won't work right.
506 -- This complication can only happen when consuming an External Core file
508 -- Solution: keep an "EdgeMap" (bad name) that maps :TEq -> Eq.
509 -- Don't worry about data constructors, because we're only building
510 -- SCCs for type and class declarations here. So the tiresome mapping
511 -- is need only to map [class tycon -> class]
513 type EdgeMap = NameEnv Name
515 mkEdgeMap :: [RenamedTyClDecl] -> TcM EdgeMap
516 mkEdgeMap decls = do { mb_pairs <- mapM mk_mb_pair decls ;
517 return (mkNameEnv (catMaybes mb_pairs)) }
519 mk_mb_pair (ClassDecl { tcdName = cls_name })
520 = do { tc_name <- lookupSysName cls_name mkClassTyConOcc ;
521 return (Just (tc_name, cls_name)) }
522 mk_mb_pair other = return Nothing
524 mkEdges :: EdgeMap -> [RenamedTyClDecl] -> [(RenamedTyClDecl, Name, [Name])]
525 -- We use the EdgeMap to map any implicit names to
526 -- the 'main name' for the declaration
527 mkEdges edge_map decls
528 = [ (decl, tyClDeclName decl, get_refs decl) | decl <- decls ]
530 get_refs decl = [ lookupNameEnv edge_map n `orElse` n
531 | n <- nameSetToList (tyClDeclFVs decl) ]
533 ----------------------------------------------------
534 -- mk_cls_edges looks only at the context of class decls
535 -- Its used when we are figuring out if there's a cycle in the
536 -- superclass hierarchy
538 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
539 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
540 mkClassEdges other_decl = Nothing
544 %************************************************************************
546 \subsection{Error management
548 %************************************************************************
551 cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
553 cycleErr kind_of_decl decls
554 = addErrAt loc (ppr_cycle kind_of_decl decls)
556 loc = tcdLoc (head decls)
558 ppr_cycle kind_of_decl decls
559 = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
560 4 (vcat (map pp_decl decls))
562 pp_decl decl = hsep [quotes (ppr (tcdName decl)),
563 ptext SLIT("at"), ppr (tcdLoc decl)]