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(..), HsConDetails(..), HsTyVarBndr(..),
14 ConDecl(..), Sig(..), NewOrData(..), ResType(..),
15 tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs,
16 LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
18 import HsTypes ( HsBang(..), getBangStrictness )
19 import BasicTypes ( RecFlag(..), StrictnessMark(..) )
20 import HscTypes ( implicitTyThings, ModDetails )
21 import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
22 mkDataTyConRhs, mkNewTyConRhs )
24 import TcEnv ( TyThing(..),
25 tcLookupLocated, tcLookupLocatedGlobal,
26 tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
27 tcExtendRecEnv, tcLookupTyVar )
28 import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
29 import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
30 import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
31 kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext,
32 kcHsSigType, tcHsBangType, tcLHsConResTy, tcDataKindSig )
33 import TcMType ( newKindVar, checkValidTheta, checkValidType,
35 UserTypeCtxt(..), SourceTyCtxt(..) )
36 import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy,
37 mkArrowKind, liftedTypeKind, mkTyVarTys,
38 tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
39 import Type ( splitTyConApp_maybe,
40 -- pprParendType, pprThetaArrow
42 import Kind ( mkArrowKinds, splitKindFunTys )
43 import Generics ( validGenericMethodType, canDoGenerics )
44 import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
45 import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
46 tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
47 tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
48 import DataCon ( DataCon, dataConWrapId, dataConName,
49 dataConFieldLabels, dataConTyCon,
50 dataConTyVars, dataConFieldType, dataConResTys )
51 import Var ( TyVar, idType, idName )
52 import VarSet ( elemVarSet, mkVarSet )
53 import Name ( Name, getSrcLoc )
55 import Maybe ( isJust )
56 import Maybes ( expectJust )
57 import Unify ( tcMatchTys, tcMatchTyX )
58 import Util ( zipLazy, isSingleton, notNull, sortLe )
59 import List ( partition )
60 import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
61 import ListSetOps ( equivClasses )
62 import List ( delete )
63 import Digraph ( SCC(..) )
64 import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
65 Opt_UnboxStrictFields ) )
69 %************************************************************************
71 \subsection{Type checking for type and class declarations}
73 %************************************************************************
77 Consider a mutually-recursive group, binding
78 a type constructor T and a class C.
80 Step 1: getInitialKind
81 Construct a KindEnv by binding T and C to a kind variable
84 In that environment, do a kind check
86 Step 3: Zonk the kinds
88 Step 4: buildTyConOrClass
89 Construct an environment binding T to a TyCon and C to a Class.
90 a) Their kinds comes from zonking the relevant kind variable
91 b) Their arity (for synonyms) comes direct from the decl
92 c) The funcional dependencies come from the decl
93 d) The rest comes a knot-tied binding of T and C, returned from Step 4
94 e) The variances of the tycons in the group is calculated from
98 In this environment, walk over the decls, constructing the TyCons and Classes.
99 This uses in a strict way items (a)-(c) above, which is why they must
100 be constructed in Step 4. Feed the results back to Step 4.
101 For this step, pass the is-recursive flag as the wimp-out flag
105 Step 6: Extend environment
106 We extend the type environment with bindings not only for the TyCons and Classes,
107 but also for their "implicit Ids" like data constructors and class selectors
109 Step 7: checkValidTyCl
110 For a recursive group only, check all the decls again, just
111 to check all the side conditions on validity. We could not
112 do this before because we were in a mutually recursive knot.
115 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
116 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
119 tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
120 -> TcM TcGblEnv -- Input env extended by types and classes
121 -- and their implicit Ids,DataCons
122 tcTyAndClassDecls boot_details decls
123 = do { -- First check for cyclic type synonysm or classes
124 -- See notes with checkCycleErrs
127 ; traceTc (text "tcTyAndCl" <+> ppr mod)
128 ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
129 do { let { -- Calculate variances and rec-flag
130 ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls
131 ; alg_decls = alg_decls_pre ++
132 concat [tcdATs decl -- add AT decls
133 | declLoc <- alg_decls_pre
134 , let decl = unLoc declLoc
135 , isClassDecl decl] }
137 -- Extend the global env with the knot-tied results
138 -- for data types and classes
140 -- We must populate the environment with the loop-tied T's right
141 -- away, because the kind checker may "fault in" some type
142 -- constructors that recursively mention T
143 ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss }
144 ; tcExtendRecEnv gbl_things $ do
146 -- Kind-check the declarations
147 { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
149 ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
150 ; calc_rec = calcRecFlags boot_details rec_alg_tyclss
151 ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) }
152 -- Type-check the type synonyms, and extend the envt
153 ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
154 ; tcExtendGlobalEnv syn_tycons $ do
156 -- Type-check the data types and classes
157 { alg_tyclss <- mappM tc_decl kc_alg_decls
158 ; return (syn_tycons, alg_tyclss)
160 -- Finished with knot-tying now
161 -- Extend the environment with the finished things
162 ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
164 -- Perform the validity check
165 { traceTc (text "ready for validity check")
166 ; mappM_ (addLocM checkValidTyCl) decls
167 ; traceTc (text "done")
169 -- Add the implicit things;
170 -- we want them in the environment because
171 -- they may be mentioned in interface files
172 ; let { implicit_things = concatMap implicitTyThings alg_tyclss }
173 ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things))
174 ; tcExtendGlobalEnv implicit_things getGblEnv
177 mkGlobalThings :: [LTyClDecl Name] -- The decls
178 -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls
180 -- Driven by the Decls, and treating the TyThings lazily
181 -- make a TypeEnv for the new things
182 mkGlobalThings decls things
183 = map mk_thing (decls `zipLazy` things)
185 mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
187 mk_thing (L _ decl, ~(ATyCon tc))
188 = (tcdName decl, ATyCon tc)
192 %************************************************************************
196 %************************************************************************
198 We need to kind check all types in the mutually recursive group
199 before we know the kind of the type variables. For example:
202 op :: D b => a -> b -> b
205 bop :: (Monad c) => ...
207 Here, the kind of the locally-polymorphic type variable "b"
208 depends on *all the uses of class D*. For example, the use of
209 Monad c in bop's type signature means that D must have kind Type->Type.
211 However type synonyms work differently. They can have kinds which don't
212 just involve (->) and *:
213 type R = Int# -- Kind #
214 type S a = Array# a -- Kind * -> #
215 type T a b = (# a,b #) -- Kind * -> * -> (# a,b #)
216 So we must infer their kinds from their right-hand sides *first* and then
217 use them, whereas for the mutually recursive data types D we bring into
218 scope kind bindings D -> k, where k is a kind variable, and do inference.
221 kcTyClDecls syn_decls alg_decls
222 = do { -- First extend the kind env with each data
223 -- type and class, mapping them to a type variable
224 alg_kinds <- mappM getInitialKind alg_decls
225 ; tcExtendKindEnv alg_kinds $ do
227 -- Now kind-check the type synonyms, in dependency order
228 -- We do these differently to data type and classes,
229 -- because a type synonym can be an unboxed type
231 -- and a kind variable can't unify with UnboxedTypeKind
232 -- So we infer their kinds in dependency order
233 { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
234 ; tcExtendKindEnv syn_kinds $ do
236 -- Now kind-check the data type and class declarations,
237 -- returning kind-annotated decls
238 { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) alg_decls
240 ; return (kc_syn_decls, kc_alg_decls) }}}
242 ------------------------------------------------------------------------
243 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
244 -- Only for data type and class declarations
245 -- Get as much info as possible from the data or class decl,
246 -- so as to maximise usefulness of error messages
247 getInitialKind (L _ decl)
248 = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
249 ; res_kind <- mk_res_kind decl
250 ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
252 mk_arg_kind (UserTyVar _) = newKindVar
253 mk_arg_kind (KindedTyVar _ kind) = return kind
255 mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
256 -- On GADT-style declarations we allow a kind signature
257 -- data T :: *->* where { ... }
258 mk_res_kind other = return liftedTypeKind
262 kcSynDecls :: [SCC (LTyClDecl Name)]
263 -> TcM ([LTyClDecl Name], -- Kind-annotated decls
264 [(Name,TcKind)]) -- Kind bindings
267 kcSynDecls (group : groups)
268 = do { (decl, nk) <- kcSynDecl group
269 ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
270 ; return (decl:decls, nk:nks) }
273 kcSynDecl :: SCC (LTyClDecl Name)
274 -> TcM (LTyClDecl Name, -- Kind-annotated decls
275 (Name,TcKind)) -- Kind bindings
276 kcSynDecl (AcyclicSCC ldecl@(L loc decl))
277 = tcAddDeclCtxt decl $
278 kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
279 do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
280 <+> brackets (ppr k_tvs))
281 ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl)
282 ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
283 ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs
284 ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
285 (unLoc (tcdLName decl), tc_kind)) })
287 kcSynDecl (CyclicSCC decls)
288 = do { recSynErr decls; failM } -- Fail here to avoid error cascade
289 -- of out-of-scope tycons
291 kindedTyVarKind (L _ (KindedTyVar _ k)) = k
293 ------------------------------------------------------------------------
294 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
295 -- Not used for type synonyms (see kcSynDecl)
297 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
298 = kcTyClDeclBody decl $ \ tvs' ->
299 do { ctxt' <- kcHsContext ctxt
300 ; cons' <- mappM (wrapLocM kc_con_decl) cons
301 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }
303 kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do
304 kcHsTyVars ex_tvs $ \ex_tvs' -> do
305 ex_ctxt' <- kcHsContext ex_ctxt
306 details' <- kc_con_details details
308 ResTyH98 -> return ResTyH98
309 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
310 return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
312 kc_con_details (PrefixCon btys)
313 = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
314 kc_con_details (InfixCon bty1 bty2)
315 = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') }
316 kc_con_details (RecCon fields)
317 = do { fields' <- mappM kc_field fields; return (RecCon fields') }
319 kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
321 kc_larg_ty bty = case new_or_data of
322 DataType -> kcHsSigType bty
323 NewType -> kcHsLiftedSigType bty
324 -- Can't allow an unlifted type for newtypes, because we're effectively
325 -- going to remove the constructor while coercing it to a lifted type.
326 -- And newtypes can't be bang'd
329 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})
330 = kcTyClDeclBody decl $ \ tvs' ->
331 do { is_boot <- tcIsHsBoot
332 ; ctxt' <- kcHsContext ctxt
333 ; sigs' <- mappM (wrapLocM kc_sig) sigs
334 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
336 kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
337 ; return (TypeSig nm op_ty') }
338 kc_sig other_sig = return other_sig
340 kcTyClDecl decl@(ForeignType {})
343 kcTyClDeclBody :: TyClDecl Name
344 -> ([LHsTyVarBndr Name] -> TcM a)
346 -- getInitialKind has made a suitably-shaped kind for the type or class
347 -- Unpack it, and attribute those kinds to the type variables
348 -- Extend the env with bindings for the tyvars, taken from
349 -- the kind of the tycon/class. Give it to the thing inside, and
350 -- check the result kind matches
351 kcTyClDeclBody decl thing_inside
352 = tcAddDeclCtxt decl $
353 do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
354 ; let tc_kind = case tc_ty_thing of { AThing k -> k }
355 (kinds, _) = splitKindFunTys tc_kind
356 hs_tvs = tcdTyVars decl
357 kinded_tvs = ASSERT( length kinds >= length hs_tvs )
358 [ L loc (KindedTyVar (hsTyVarName tv) k)
359 | (L loc tv, k) <- zip hs_tvs kinds]
360 ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
364 %************************************************************************
366 \subsection{Type checking}
368 %************************************************************************
371 tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing]
372 tcSynDecls calc_vrcs [] = return []
373 tcSynDecls calc_vrcs (decl : decls)
374 = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl
375 ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls)
376 ; return (syn_tc : syn_tcs) }
379 (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
380 = tcTyVarBndrs tvs $ \ tvs' -> do
381 { traceTc (text "tcd1" <+> ppr tc_name)
382 ; rhs_ty' <- tcHsKindedType rhs_ty
383 ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) }
386 tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
387 -> TyClDecl Name -> TcM TyThing
389 tcTyClDecl calc_vrcs calc_isrec decl
390 = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
392 tcTyClDecl1 calc_vrcs calc_isrec
393 (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
394 tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
395 = tcTyVarBndrs tvs $ \ tvs' -> do
396 { extra_tvs <- tcDataKindSig mb_ksig
397 ; let final_tvs = tvs' ++ extra_tvs
398 ; stupid_theta <- tcHsKindedContext ctxt
399 ; want_generic <- doptM Opt_Generics
400 ; unbox_strict <- doptM Opt_UnboxStrictFields
401 ; gla_exts <- doptM Opt_GlasgowExts
402 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
404 -- Check that we don't use GADT syntax in H98 world
405 ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
407 -- Check that there's at least one condecl,
408 -- or else we're reading an interface file, or -fglasgow-exts
409 ; checkTc (not (null cons) || gla_exts || is_boot)
410 (emptyConDeclsErr tc_name)
412 -- Check that a newtype has exactly one constructor
413 ; checkTc (new_or_data == DataType || isSingleton cons)
414 (newtypeConError tc_name (length cons))
416 ; tycon <- fixM (\ tycon -> do
417 { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
421 | null cons && is_boot -- In a hs-boot file, empty cons means
422 = AbstractTyCon -- "don't know"; hence Abstract
424 = case new_or_data of
425 DataType -> mkDataTyConRhs data_cons
426 NewType -> ASSERT( isSingleton data_cons )
427 mkNewTyConRhs tycon (head data_cons)
428 ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec
429 (want_generic && canDoGenerics data_cons)
431 ; return (ATyCon tycon)
434 arg_vrcs = calc_vrcs tc_name
435 is_rec = calc_isrec tc_name
436 h98_syntax = case cons of -- All constructors have same shape
437 L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
440 tcTyClDecl1 calc_vrcs calc_isrec
441 (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
442 tcdCtxt = ctxt, tcdMeths = meths,
443 tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
444 = tcTyVarBndrs tvs $ \ tvs' -> do
445 { ctxt' <- tcHsKindedContext ctxt
446 ; fds' <- mappM (addLocM tc_fundep) fundeps
447 -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak
448 ; sig_stuff <- tcClassSigs class_name sigs meths
449 ; clas <- fixM (\ clas ->
450 let -- This little knot is just so we can get
451 -- hold of the name of the class TyCon, which we
452 -- need to look up its recursiveness and variance
453 tycon_name = tyConName (classTyCon clas)
454 tc_isrec = calc_isrec tycon_name
455 tc_vrcs = calc_vrcs tycon_name
457 buildClass class_name tvs' ctxt' fds'
458 sig_stuff tc_isrec tc_vrcs)
459 ; return (AClass clas) }
461 tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
462 ; tvs2' <- mappM tcLookupTyVar tvs2 ;
463 ; return (tvs1', tvs2') }
466 tcTyClDecl1 calc_vrcs calc_isrec
467 (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
468 = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
470 -----------------------------------
471 tcConDecl :: Bool -- True <=> -funbox-strict_fields
472 -> NewOrData -> TyCon -> [TyVar]
473 -> ConDecl Name -> TcM DataCon
475 tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes
476 (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
477 = do { let tc_datacon field_lbls arg_ty
478 = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
479 ; buildDataCon (unLoc name) False {- Prefix -}
480 True {- Vanilla -} [NotMarkedStrict]
481 (map unLoc field_lbls)
483 tycon (mkTyVarTys tc_tvs) }
485 -- Check that a newtype has no existential stuff
486 ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
489 PrefixCon [arg_ty] -> tc_datacon [] arg_ty
490 RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
491 other -> failWithTc (newtypeFieldErr name (length (hsConArgs details)))
492 -- Check that the constructor has exactly one field
495 tcConDecl unbox_strict DataType tycon tc_tvs -- Data types
496 (ConDecl name _ tvs ctxt details res_ty)
497 = tcTyVarBndrs tvs $ \ tvs' -> do
498 { ctxt' <- tcHsKindedContext ctxt
499 ; (data_tc, res_ty_args) <- tcResultType tycon tc_tvs res_ty
501 con_tvs = case res_ty of
502 ResTyH98 -> tc_tvs ++ tvs'
503 ResTyGADT _ -> tryVanilla tvs' res_ty_args
505 -- Vanilla iff result type matches the quantified vars exactly,
506 -- and there is no existential context
507 -- Must check the context too because of implicit params; e.g.
508 -- data T = (?x::Int) => MkT Int
509 is_vanilla = res_ty_args `tcEqTypes` mkTyVarTys con_tvs
512 tc_datacon is_infix field_lbls btys
513 = do { let bangs = map getBangStrictness btys
514 ; arg_tys <- mappM tcHsBangType btys
515 ; buildDataCon (unLoc name) is_infix is_vanilla
516 (argStrictness unbox_strict tycon bangs arg_tys)
517 (map unLoc field_lbls)
518 con_tvs ctxt' arg_tys
519 data_tc res_ty_args }
520 -- NB: we put data_tc, the type constructor gotten from the constructor
521 -- type signature into the data constructor; that way
522 -- checkValidDataCon can complain if it's wrong.
525 PrefixCon btys -> tc_datacon False [] btys
526 InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
527 RecCon fields -> tc_datacon False field_names btys
529 (field_names, btys) = unzip fields
533 tcResultType :: TyCon -> [TyVar] -> ResType Name -> TcM (TyCon, [TcType])
534 tcResultType tycon tvs ResTyH98 = return (tycon, mkTyVarTys tvs)
535 tcResultType _ _ (ResTyGADT res_ty) = tcLHsConResTy res_ty
537 tryVanilla :: [TyVar] -> [TcType] -> [TyVar]
538 -- (tryVanilla tvs tys) returns a permutation of tvs.
539 -- It tries to re-order the tvs so that it exactly
540 -- matches the [Type], if that is possible
541 tryVanilla tvs (ty:tys) | Just tv <- tcGetTyVar_maybe ty -- The type is a tyvar
542 , tv `elem` tvs -- That tyvar is in the list
543 = tv : tryVanilla (delete tv tvs) tys
544 tryVanilla tvs tys = tvs -- Fall through case
548 argStrictness :: Bool -- True <=> -funbox-strict_fields
550 -> [TcType] -> [StrictnessMark]
551 argStrictness unbox_strict tycon bangs arg_tys
552 = ASSERT( length bangs == length arg_tys )
553 zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs
555 -- We attempt to unbox/unpack a strict field when either:
556 -- (i) The field is marked '!!', or
557 -- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
559 chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
560 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
562 HsNoBang -> NotMarkedStrict
563 HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
564 HsUnbox | can_unbox -> MarkedUnboxed
565 other -> MarkedStrict
567 can_unbox = case splitTyConApp_maybe arg_ty of
569 Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
570 isProductTyCon arg_tycon
573 %************************************************************************
575 \subsection{Dependency analysis}
577 %************************************************************************
579 Validity checking is done once the mutually-recursive knot has been
580 tied, so we can look at things freely.
583 checkCycleErrs :: [LTyClDecl Name] -> TcM ()
584 checkCycleErrs tyclss
588 = do { mappM_ recClsErr cls_cycles
589 ; failM } -- Give up now, because later checkValidTyCl
590 -- will loop if the synonym is recursive
592 cls_cycles = calcClassCycles tyclss
594 checkValidTyCl :: TyClDecl Name -> TcM ()
595 -- We do the validity check over declarations, rather than TyThings
596 -- only so that we can add a nice context with tcAddDeclCtxt
598 = tcAddDeclCtxt decl $
599 do { thing <- tcLookupLocatedGlobal (tcdLName decl)
600 ; traceTc (text "Validity of" <+> ppr thing)
602 ATyCon tc -> checkValidTyCon tc
603 AClass cl -> checkValidClass cl
604 ; traceTc (text "Done validity of" <+> ppr thing)
607 -------------------------
608 -- For data types declared with record syntax, we require
609 -- that each constructor that has a field 'f'
610 -- (a) has the same result type
611 -- (b) has the same type for 'f'
612 -- module alpha conversion of the quantified type variables
613 -- of the constructor.
615 checkValidTyCon :: TyCon -> TcM ()
618 = checkValidType syn_ctxt syn_rhs
620 = -- Check the context on the data decl
621 checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_`
623 -- Check arg types of data constructors
624 mappM_ (checkValidDataCon tc) data_cons `thenM_`
626 -- Check that fields with the same name share a type
627 mappM_ check_fields groups
630 syn_ctxt = TySynCtxt name
632 syn_rhs = synTyConRhs tc
633 data_cons = tyConDataCons tc
635 groups = equivClasses cmp_fld (concatMap get_fields data_cons)
636 cmp_fld (f1,_) (f2,_) = f1 `compare` f2
637 get_fields con = dataConFieldLabels con `zip` repeat con
638 -- dataConFieldLabels may return the empty list, which is fine
640 -- Note: The complicated checkOne logic below is there to accomodate
641 -- for different return types. Add res_ty to the mix,
642 -- comparing them in two steps, all for good error messages.
643 -- Plan: Use Unify.tcMatchTys to compare the first candidate's
644 -- result type against other candidates' types (check bothways).
645 -- If they magically agrees, take the substitution and
646 -- apply them to the latter ones, and see if they match perfectly.
647 -- check_fields fields@((first_field_label, field_ty) : other_fields)
648 check_fields fields@((label, con1) : other_fields)
649 -- These fields all have the same name, but are from
650 -- different constructors in the data type
651 = recoverM (return ()) $ mapM_ checkOne other_fields
652 -- Check that all the fields in the group have the same type
653 -- NB: this check assumes that all the constructors of a given
654 -- data type use the same type variables
656 tvs1 = mkVarSet (dataConTyVars con1)
657 res1 = dataConResTys con1
658 fty1 = dataConFieldType con1 label
660 checkOne (_, con2) -- Do it bothways to ensure they are structurally identical
661 = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2
662 ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 }
664 tvs2 = mkVarSet (dataConTyVars con2)
665 res2 = dataConResTys con2
666 fty2 = dataConFieldType con2 label
668 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
669 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
670 ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
672 mb_subst1 = tcMatchTys tvs1 res1 res2
673 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
675 -------------------------------
676 checkValidDataCon :: TyCon -> DataCon -> TcM ()
677 checkValidDataCon tc con
678 = setSrcSpan (srcLocSpan (getSrcLoc con)) $
679 addErrCtxt (dataConCtxt con) $
680 do { checkTc (dataConTyCon con == tc) (badDataConTyCon con)
681 ; checkValidType ctxt (idType (dataConWrapId con)) }
683 -- This checks the argument types and
684 -- ambiguity of the existential context (if any)
686 -- Note [Sept 04] Now that tvs is all the tvs, this
687 -- test doesn't actually check anything
688 -- ; checkFreeness tvs ex_theta }
690 ctxt = ConArgCtxt (dataConName con)
691 -- (tvs, ex_theta, _, _, _) = dataConSig con
694 -------------------------------
695 checkValidClass :: Class -> TcM ()
697 = do { -- CHECK ARITY 1 FOR HASKELL 1.4
698 gla_exts <- doptM Opt_GlasgowExts
700 -- Check that the class is unary, unless GlaExs
701 ; checkTc (notNull tyvars) (nullaryClassErr cls)
702 ; checkTc (gla_exts || unary) (classArityErr cls)
704 -- Check the super-classes
705 ; checkValidTheta (ClassSCCtxt (className cls)) theta
707 -- Check the class operations
708 ; mappM_ (check_op gla_exts) op_stuff
710 -- Check that if the class has generic methods, then the
711 -- class has only one parameter. We can't do generic
712 -- multi-parameter type classes!
713 ; checkTc (unary || no_generics) (genericMultiParamErr cls)
715 -- Check that the class has no associated types, unless GlaExs
716 ; checkTc (gla_exts || no_ats) (badATDecl cls)
719 (tyvars, theta, _, op_stuff) = classBigSig cls
720 unary = isSingleton tyvars
721 no_generics = null [() | (_, GenDefMeth) <- op_stuff]
722 no_ats = True -- !!!TODO: determine whether the class has ATs -=chak
724 check_op gla_exts (sel_id, dm)
725 = addErrCtxt (classOpCtxt sel_id tau) $ do
726 { checkValidTheta SigmaCtxt (tail theta)
727 -- The 'tail' removes the initial (C a) from the
728 -- class itself, leaving just the method type
730 ; checkValidType (FunSigCtxt op_name) tau
732 -- Check that the type mentions at least one of
733 -- the class type variables
734 ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars)
735 (noClassTyVarErr cls sel_id)
737 -- Check that for a generic method, the type of
738 -- the method is sufficiently simple
739 ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
740 (badGenericMethodType op_name op_ty)
743 op_name = idName sel_id
744 op_ty = idType sel_id
745 (_,theta1,tau1) = tcSplitSigmaTy op_ty
746 (_,theta2,tau2) = tcSplitSigmaTy tau1
747 (theta,tau) | gla_exts = (theta1 ++ theta2, tau2)
748 | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
749 -- Ugh! The function might have a type like
750 -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
751 -- With -fglasgow-exts, we want to allow this, even though the inner
752 -- forall has an (Eq a) constraint. Whereas in general, each constraint
753 -- in the context of a for-all must mention at least one quantified
754 -- type variable. What a mess!
757 ---------------------------------------------------------------------
758 resultTypeMisMatch field_name con1 con2
759 = vcat [sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
760 ptext SLIT("have a common field") <+> quotes (ppr field_name) <> comma],
761 nest 2 $ ptext SLIT("but have different result types")]
762 fieldTypeMisMatch field_name con1 con2
763 = sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
764 ptext SLIT("give different types for field"), quotes (ppr field_name)]
766 dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con)
768 classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
769 nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
772 = ptext SLIT("No parameters for class") <+> quotes (ppr cls)
775 = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
776 parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
778 noClassTyVarErr clas op
779 = sep [ptext SLIT("The class method") <+> quotes (ppr op),
780 ptext SLIT("mentions none of the type variables of the class") <+>
781 ppr clas <+> hsep (map ppr (classTyVars clas))]
783 genericMultiParamErr clas
784 = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
785 ptext SLIT("cannot have generic methods")
787 badGenericMethodType op op_ty
788 = hang (ptext SLIT("Generic method type is too complex"))
789 4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
790 ptext SLIT("You can only use type variables, arrows, lists, and tuples")])
793 = setSrcSpan (getLoc (head sorted_decls)) $
794 addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
795 nest 2 (vcat (map ppr_decl sorted_decls))])
797 sorted_decls = sortLocated syn_decls
798 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
801 = setSrcSpan (getLoc (head sorted_decls)) $
802 addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
803 nest 2 (vcat (map ppr_decl sorted_decls))])
805 sorted_decls = sortLocated cls_decls
806 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
808 sortLocated :: [Located a] -> [Located a]
809 sortLocated things = sortLe le things
811 le (L l1 _) (L l2 _) = l1 <= l2
813 badDataConTyCon data_con
814 = hang (ptext SLIT("Data constructor") <+> quotes (ppr data_con) <+>
815 ptext SLIT("returns type") <+> quotes (ppr (dataConTyCon data_con)))
816 2 (ptext SLIT("instead of its parent type"))
819 = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
820 , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
822 newtypeConError tycon n
823 = sep [ptext SLIT("A newtype must have exactly one constructor,"),
824 nest 2 $ ptext SLIT("but") <+> quotes (ppr tycon) <+> ptext SLIT("has") <+> speakN n ]
827 = sep [ptext SLIT("A newtype constructor cannot have an existential context,"),
828 nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")]
830 newtypeFieldErr con_name n_flds
831 = sep [ptext SLIT("The constructor of a newtype must have exactly one field"),
832 nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
835 = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name)
836 , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ]
838 emptyConDeclsErr tycon
839 = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
840 nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]