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(..), isRec )
21 import HscTypes ( implicitTyThingIds )
24 import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
25 tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
26 import TcTyDecls ( tcTyDecl1, kcConDetails )
27 import TcClassDcl ( tcClassDecl1 )
28 import TcInstDcls ( tcAddDeclCtxt )
29 import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
30 import TcMType ( unifyKind, newKindVar, zonkKindEnv )
31 import TcType ( Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys )
32 import Variance ( calcTyConArgVrcs )
33 import Class ( Class, mkClass, classTyCon )
34 import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..),
35 tyConKind, tyConDataCons,
36 mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
38 import DataCon ( dataConOrigArgTys )
39 import Var ( varName )
41 import Digraph ( stronglyConnComp, SCC(..) )
42 import Name ( Name, getSrcLoc, isTyVarName )
46 import Maybes ( mapMaybe )
47 import ErrUtils ( Message )
48 import HsDecls ( getClassDeclSysNames )
49 import Generics ( mkTyConGenInfo )
53 %************************************************************************
55 \subsection{Type checking for type and class declarations}
57 %************************************************************************
62 tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
66 tcTyAndClassDecls unf_env decls
67 = sortByDependency decls `thenTc` \ groups ->
68 tcGroups unf_env groups
71 = tcGetEnv `thenNF_Tc` \ env ->
74 tcGroups unf_env (group:groups)
75 = tcGroup unf_env group `thenTc` \ env ->
77 tcGroups unf_env groups
82 Consider a mutually-recursive group, binding
83 a type constructor T and a class C.
85 Step 1: getInitialKind
86 Construct a KindEnv by binding T and C to a kind variable
89 In that environment, do a kind check
91 Step 3: Zonk the kinds
93 Step 4: buildTyConOrClass
94 Construct an environment binding T to a TyCon and C to a Class.
95 a) Their kinds comes from zonking the relevant kind variable
96 b) Their arity (for synonyms) comes direct from the decl
97 c) The funcional dependencies come from the decl
98 d) The rest comes a knot-tied binding of T and C, returned from Step 4
99 e) The variances of the tycons in the group is calculated from
103 In this environment, walk over the decls, constructing the TyCons and Classes.
104 This uses in a strict way items (a)-(c) above, which is why they must
105 be constructed in Step 4. Feed the results back to Step 4.
106 For this step, pass the is-recursive flag as the wimp-out flag
110 Step 6: tcTyClDecl1 again
111 For a recursive group only, check all the decls again, just
112 but this time with the wimp flag off. Now we can check things
113 like whether a function argument is an unlifted tuple, looking
114 through type synonyms properly. We can't do that in Step 5.
116 Step 7: Extend environment
117 We extend the type environment with bindings not only for the TyCons and Classes,
118 but also for their "implicit Ids" like data constructors and class selectors
120 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
121 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
124 tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
126 = getDOptsTc `thenTc` \ dflags ->
128 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
131 tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
134 zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
137 traceTc (text "starting" <+> ppr final_kinds) `thenTc_`
138 fixTc ( \ ~(rec_details_list, _, _) ->
141 kind_env = mkNameEnv final_kinds
142 rec_details = mkNameEnv rec_details_list
144 tyclss, all_tyclss :: [TyThing]
145 tyclss = map (buildTyConOrClass dflags is_rec kind_env
146 rec_vrcs rec_details) decls
148 -- Add the tycons that come from the classes
149 -- We want them in the environment because
150 -- they are mentioned in interface files
151 all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
154 -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
155 rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
158 tcExtendGlobalEnv all_tyclss $
159 mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details ->
162 tcGetEnv `thenNF_Tc` \ env ->
163 returnTc (tycls_details, all_tyclss, env)
164 ) `thenTc` \ (_, all_tyclss, env) ->
168 traceTc (text "ready for pass 2" <+> ppr (isRec is_rec)) `thenTc_`
171 -- For a recursive group, check all the types again,
172 -- this time with the wimp flag off
173 (if isRec is_rec then
174 mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
179 traceTc (text "done") `thenTc_`
182 -- Extend the environment with the final TyCons/Classes
183 -- and their implicit Ids
184 tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
188 AcyclicSCC _ -> NonRecursive
189 CyclicSCC _ -> Recursive
192 AcyclicSCC decl -> [decl]
193 CyclicSCC decls -> decls
195 tcTyClDecl1 is_rec unf_env decl
196 | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
197 | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec unf_env decl)
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)
284 %************************************************************************
286 \subsection{Step 4: Building the tycon/class}
288 %************************************************************************
293 -> RecFlag -> NameEnv Kind
294 -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
295 -> RenamedTyClDecl -> TyThing
297 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
298 (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
301 tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
302 tycon_kind = lookupNameEnv_NF kenv tycon_name
303 arity = length tyvar_names
304 tyvars = mkTyClTyVars tycon_kind tyvar_names
305 SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
306 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
308 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
309 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
310 tcdNCons = nconstrs, tcdSysNames = sys_names})
313 tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
314 data_cons nconstrs sel_ids
315 flavour is_rec gen_info
317 gen_info | not (dopt Opt_Generics dflags) = Nothing
318 | otherwise = mkTyConGenInfo tycon sys_names
320 DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
322 tycon_kind = lookupNameEnv_NF kenv tycon_name
323 tyvars = mkTyClTyVars tycon_kind tyvar_names
324 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
326 -- Watch out! mkTyConApp asks whether the tycon is a NewType,
327 -- so flavour has to be able to answer this question without consulting rec_details
328 flavour = case data_or_new of
329 NewType -> NewTyCon (mkNewTyConRep tycon)
330 DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
331 | otherwise -> DataTyCon
332 -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
333 -- but that looks at the *representation* arity, and that in turn
334 -- depends on deciding whether to unpack the args, and that
335 -- depends on whether it's a data type or a newtype --- so
336 -- in the recursive case we can get a loop. This version is simple!
338 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
339 (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
340 = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
342 buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
343 (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
344 tcdFDs = fundeps, tcdSysNames = name_list} )
347 (tycon_name, _, _, _) = getClassDeclSysNames name_list
348 clas = mkClass class_name tyvars fds
349 sc_theta sc_sel_ids op_items
352 tycon = mkClassTyCon tycon_name class_kind tyvars
354 clas -- Yes! It's a dictionary
357 -- A class can be recursive, and in the case of newtypes
358 -- this matters. For example
359 -- class C a where { op :: C b => a -> b -> Int }
360 -- Because C has only one operation, it is represented by
361 -- a newtype, and it should be a *recursive* newtype.
362 -- [If we don't make it a recursive newtype, we'll expand the
363 -- newtype like a synonym, but that will lead toan inifinite type
365 ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
367 class_kind = lookupNameEnv_NF kenv class_name
368 tyvars = mkTyClTyVars class_kind tyvar_names
369 argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
371 flavour = case dataConOrigArgTys dict_con of
372 -- The tyvars in the datacon are the same as in the class
373 [rep_ty] -> NewTyCon rep_ty
376 -- We can find the functional dependencies right away,
377 -- and it is vital to do so. Why? Because in the next pass
378 -- we check for ambiguity in all the type signatures, and we
379 -- need the functional dependcies to be done by then
380 fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
381 tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars]
382 lookup = lookupNameEnv_NF tyvar_env
384 bogusVrcs = panic "Bogus tycon arg variances"
388 mkNewTyConRep :: TyCon -- The original type constructor
389 -> Type -- Chosen representation type
390 -- Find the representation type for this newtype TyCon
391 -- For a recursive type constructor we give an error thunk,
392 -- because we never look at the rep in that case
393 -- (see notes on newypes in types/TypeRep
396 | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc)
397 | otherwise = head (dataConOrigArgTys (head (tyConDataCons tc)))
401 %************************************************************************
403 \subsection{Dependency analysis}
405 %************************************************************************
410 sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
411 sortByDependency decls
412 = let -- CHECK FOR CLASS CYCLES
413 cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
414 cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
416 checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
418 let -- CHECK FOR SYNONYM CYCLES
419 syn_sccs = stronglyConnComp (filter is_syn_decl edges)
420 syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
423 checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
425 -- DO THE MAIN DEPENDENCY ANALYSIS
427 decl_sccs = stronglyConnComp edges
431 tycl_decls = filter (not . isIfaceSigDecl) decls
432 edges = map mkEdges tycl_decls
434 is_syn_decl (d, _, _) = isSynDecl d
437 Edges in Type/Class decls
438 ~~~~~~~~~~~~~~~~~~~~~~~~~
441 tyClDeclFTVs :: RenamedTyClDecl -> [Name]
442 -- Find the free non-tyvar vars
443 tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
445 add n fvs | isTyVarName n = fvs
446 | otherwise = n : fvs
448 ----------------------------------------------------
449 -- mk_cls_edges looks only at the context of class decls
450 -- Its used when we are figuring out if there's a cycle in the
451 -- superclass hierarchy
453 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
455 mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
456 mkClassEdges other_decl = Nothing
458 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
459 mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
463 %************************************************************************
465 \subsection{Error management
467 %************************************************************************
470 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
472 typeCycleErr syn_cycles
473 = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
475 classCycleErr cls_cycles
476 = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
480 4 (vcat (map pp_decl decls))
483 = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
485 name = tyClDeclName decl