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 isIfaceSigDecl, 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, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
26 tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv,
28 import TcTyDecls ( tcTyDecl, kcConDetails, checkValidTyCon )
29 import TcClassDcl ( tcClassDecl1, checkValidClass )
30 import TcInstDcls ( tcAddDeclCtxt )
31 import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
32 import TcMType ( unifyKind, newKindVar, zonkKindEnv )
33 import TcType ( Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys )
34 import Variance ( calcTyConArgVrcs )
35 import Class ( Class, mkClass, classTyCon )
36 import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..),
37 tyConKind, tyConDataCons,
38 mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
40 import DataCon ( dataConOrigArgTys )
41 import Var ( varName )
43 import Digraph ( stronglyConnComp, SCC(..) )
44 import Name ( Name, getSrcLoc, isTyVarName )
48 import Maybes ( mapMaybe )
49 import ErrUtils ( Message )
50 import HsDecls ( getClassDeclSysNames )
51 import Generics ( mkTyConGenInfo )
55 %************************************************************************
57 \subsection{Type checking for type and class declarations}
59 %************************************************************************
64 tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
65 -> Module -- Current module
69 tcTyAndClassDecls unf_env this_mod decls
70 = sortByDependency decls `thenTc` \ groups ->
71 tcGroups unf_env this_mod groups
73 tcGroups unf_env this_mod []
74 = tcGetEnv `thenNF_Tc` \ env ->
77 tcGroups unf_env this_mod (group:groups)
78 = tcGroup unf_env this_mod group `thenTc` \ env ->
80 tcGroups unf_env this_mod 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 :: RecTcEnv -> Module -> SCC RenamedTyClDecl -> TcM TcEnv
128 tcGroup unf_env this_mod scc
129 = getDOptsTc `thenTc` \ dflags ->
131 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
134 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
137 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
140 traceTc (text "starting" <+> ppr final_kinds) `thenTc_`
141 fixTc ( \ ~(rec_details_list, _, _) ->
144 kind_env = mkNameEnv final_kinds
145 rec_details = mkNameEnv rec_details_list
147 tyclss, all_tyclss :: [TyThing]
148 tyclss = map (buildTyConOrClass dflags is_rec kind_env
149 rec_vrcs rec_details) decls
151 -- Add the tycons that come from the classes
152 -- We want them in the environment because
153 -- they are mentioned in interface files
154 all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
157 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
158 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
161 -- Extend the environment with the final
162 -- TyCons/Classes and check the decls
163 tcExtendGlobalEnv all_tyclss $
164 mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
167 -- Extend the environment with implicit Ids
168 tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) $
171 tcGetEnv `thenNF_Tc` \ env ->
172 returnTc (tycls_details, tyclss, env)
173 ) `thenTc` \ (_, tyclss, env) ->
176 -- Step 7: Check validity; but only for things defined in this module
177 traceTc (text "ready for validity check") `thenTc_`
178 mapTc_ checkValidTyCl (filter (isLocalThing this_mod) tyclss) `thenTc_`
179 traceTc (text "done") `thenTc_`
185 AcyclicSCC _ -> NonRecursive
186 CyclicSCC _ -> Recursive
189 AcyclicSCC decl -> [decl]
190 CyclicSCC decls -> decls
192 tcTyClDecl1 unf_env decl
193 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 unf_env decl)
194 | otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
196 checkValidTyCl (ATyCon tc) = checkValidTyCon tc
197 checkValidTyCl (AClass cl) = checkValidClass cl
201 %************************************************************************
203 \subsection{Step 1: Initial environment}
205 %************************************************************************
208 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
210 = kcHsTyVars (tyClDeclTyVars decl) `thenNF_Tc` \ arg_kinds ->
211 newKindVar `thenNF_Tc` \ result_kind ->
212 returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
214 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
218 %************************************************************************
220 \subsection{Step 2: Kind checking}
222 %************************************************************************
224 We need to kind check all types in the mutually recursive group
225 before we know the kind of the type variables. For example:
228 op :: D b => a -> b -> b
231 bop :: (Monad c) => ...
233 Here, the kind of the locally-polymorphic type variable "b"
234 depends on *all the uses of class D*. For example, the use of
235 Monad c in bop's type signature means that D must have kind Type->Type.
238 kcTyClDecl :: RenamedTyClDecl -> TcM ()
240 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
241 = kcTyClDeclBody decl $ \ result_kind ->
242 kcHsType rhs `thenTc` \ rhs_kind ->
243 unifyKind result_kind rhs_kind
245 kcTyClDecl (ForeignType {}) = returnTc ()
247 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
248 = kcTyClDeclBody decl $ \ result_kind ->
249 kcHsContext context `thenTc_`
250 mapTc_ kc_con_decl con_decls
252 kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
253 = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
254 tcExtendKindEnv kind_env $
255 kcConDetails new_or_data ex_ctxt details
257 kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
258 = kcTyClDeclBody decl $ \ result_kind ->
259 kcHsContext context `thenTc_`
260 mapTc_ kc_sig (filter isClassOpSig class_sigs)
262 kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
264 kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
265 -- Extend the env with bindings for the tyvars, taken from
266 -- the kind of the tycon/class. Give it to the thing inside, and
267 -- check the result kind matches
268 kcTyClDeclBody decl thing_inside
269 = tcAddDeclCtxt decl $
270 tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
273 AGlobal (ATyCon tc) -> tyConKind tc
274 AGlobal (AClass cl) -> tyConKind (classTyCon cl)
276 -- For some odd reason, a class doesn't include its kind
278 (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
280 tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
285 %************************************************************************
287 \subsection{Step 4: Building the tycon/class}
289 %************************************************************************
294 -> RecFlag -> NameEnv Kind
295 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
296 -> RenamedTyClDecl -> TyThing
298 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
299 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
302 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
303 tycon_kind = lookupNameEnv_NF kenv tycon_name
304 arity = length tyvar_names
305 tyvars = mkTyClTyVars tycon_kind tyvar_names
306 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
307 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
309 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
310 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
311 tcdNCons = nconstrs, tcdSysNames = sys_names})
314 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
315 data_cons nconstrs sel_ids
316 flavour is_rec gen_info
318 gen_info | not (dopt Opt_Generics dflags) = Nothing
319 | otherwise = mkTyConGenInfo tycon sys_names
321 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
323 tycon_kind = lookupNameEnv_NF kenv tycon_name
324 tyvars = mkTyClTyVars tycon_kind tyvar_names
325 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
327 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
328 -- so flavour has to be able to answer this question without consulting rec_details
329 flavour = case data_or_new of
330 NewType -> NewTyCon (mkNewTyConRep tycon)
331 DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
332 | otherwise -> DataTyCon
333 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
334 -- but that looks at the *representation* arity, and that in turn
335 -- depends on deciding whether to unpack the args, and that
336 -- depends on whether it's a data type or a newtype --- so
337 -- in the recursive case we can get a loop. This version is simple!
339 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
340 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
341 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
343 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
344 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
345 tcdFDs = fundeps, tcdSysNames = name_list} )
348 (tycon_name, _, _, _) = getClassDeclSysNames name_list
349 clas = mkClass class_name tyvars fds
350 sc_theta sc_sel_ids op_items
353 tycon = mkClassTyCon tycon_name class_kind tyvars
355 clas -- Yes! It's a dictionary
358 -- A class can be recursive, and in the case of newtypes
359 -- this matters. For example
360 -- class C a where { op :: C b => a -> b -> Int }
361 -- Because C has only one operation, it is represented by
362 -- a newtype, and it should be a *recursive* newtype.
363 -- [If we don't make it a recursive newtype, we'll expand the
364 -- newtype like a synonym, but that will lead toan inifinite type
366 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
368 class_kind = lookupNameEnv_NF kenv class_name
369 tyvars = mkTyClTyVars class_kind tyvar_names
370 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
372 flavour = case dataConOrigArgTys dict_con of
373 -- The tyvars in the datacon are the same as in the class
374 [rep_ty] -> NewTyCon rep_ty
377 -- We can find the functional dependencies right away,
378 -- and it is vital to do so. Why? Because in the next pass
379 -- we check for ambiguity in all the type signatures, and we
380 -- need the functional dependcies to be done by then
381 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
382 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
383 lookup = lookupNameEnv_NF tyvar_env
385 bogusVrcs = panic "Bogus tycon arg variances"
389 mkNewTyConRep :: TyCon -- The original type constructor
390 -> Type -- Chosen representation type
391 -- Find the representation type for this newtype TyCon
392 -- See notes on newypes in types/TypeRep about newtypes.
393 mkNewTyConRep tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
397 %************************************************************************
399 \subsection{Dependency analysis}
401 %************************************************************************
406 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
407 sortByDependency decls
408 = let -- CHECK FOR CLASS CYCLES
409 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
410 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
412 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
414 let -- CHECK FOR SYNONYM CYCLES
415 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
416 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
419 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
421 -- DO THE MAIN DEPENDENCY ANALYSIS
423 decl_sccs = stronglyConnComp edges
427 tycl_decls = filter (not . isIfaceSigDecl) decls
428 edges = map mkEdges tycl_decls
430 is_syn_decl (d, _, _) = isSynDecl d
433 Edges in Type/Class decls
434 ~~~~~~~~~~~~~~~~~~~~~~~~~
437 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
438 -- Find the free non-tyvar vars
439 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
441 add n fvs | isTyVarName n = fvs
442 | otherwise = n : fvs
444 ----------------------------------------------------
445 -- mk_cls_edges looks only at the context of class decls
446 -- Its used when we are figuring out if there's a cycle in the
447 -- superclass hierarchy
449 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
451 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
452 mkClassEdges other_decl = Nothing
454 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
455 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
459 %************************************************************************
461 \subsection{Error management
463 %************************************************************************
466 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
468 typeCycleErr syn_cycles
469 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
471 classCycleErr cls_cycles
472 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
476 4 (vcat (map pp_decl decls))
479 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
481 name = tyClDeclName decl