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(..), BangType(..), HsBang(..),
15 tyClDeclTyVars, getBangType, getBangStrictness
17 import RnHsSyn ( RenamedTyClDecl, RenamedConDecl )
18 import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
19 import HscTypes ( implicitTyThings )
20 import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon )
22 import TcEnv ( TcTyThing(..), TyThing(..),
23 tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
24 tcExtendRecEnv, tcLookupTyVar )
25 import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcCycleErrs )
26 import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
27 import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType,
28 kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext )
29 import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
30 UserTypeCtxt(..), SourceTyCtxt(..) )
31 import TcUnify ( unifyKind )
32 import TcType ( TcKind, ThetaType, TcType,
33 mkArrowKind, liftedTypeKind,
34 tcSplitSigmaTy, tcEqType )
35 import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
36 import FieldLabel ( fieldLabelName, fieldLabelType )
37 import Generics ( validGenericMethodType, canDoGenerics )
38 import Class ( Class, className, classTyCon, DefMeth(..), classBigSig )
39 import TyCon ( TyCon, ArgVrcs, DataConDetails(..),
40 tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
41 tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName )
42 import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
43 import Var ( TyVar, idType, idName )
44 import Name ( Name, getSrcLoc )
46 import Util ( zipLazy, isSingleton, notNull )
47 import ListSetOps ( equivClasses )
48 import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) )
52 %************************************************************************
54 \subsection{Type checking for type and class declarations}
56 %************************************************************************
60 Consider a mutually-recursive group, binding
61 a type constructor T and a class C.
63 Step 1: getInitialKind
64 Construct a KindEnv by binding T and C to a kind variable
67 In that environment, do a kind check
69 Step 3: Zonk the kinds
71 Step 4: buildTyConOrClass
72 Construct an environment binding T to a TyCon and C to a Class.
73 a) Their kinds comes from zonking the relevant kind variable
74 b) Their arity (for synonyms) comes direct from the decl
75 c) The funcional dependencies come from the decl
76 d) The rest comes a knot-tied binding of T and C, returned from Step 4
77 e) The variances of the tycons in the group is calculated from
81 In this environment, walk over the decls, constructing the TyCons and Classes.
82 This uses in a strict way items (a)-(c) above, which is why they must
83 be constructed in Step 4. Feed the results back to Step 4.
84 For this step, pass the is-recursive flag as the wimp-out flag
88 Step 6: Extend environment
89 We extend the type environment with bindings not only for the TyCons and Classes,
90 but also for their "implicit Ids" like data constructors and class selectors
92 Step 7: checkValidTyCl
93 For a recursive group only, check all the decls again, just
94 to check all the side conditions on validity. We could not
95 do this before because we were in a mutually recursive knot.
98 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
99 @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
102 tcTyAndClassDecls :: [RenamedTyClDecl]
103 -> TcM TcGblEnv -- Input env extended by types and classes
104 -- and their implicit Ids,DataCons
105 tcTyAndClassDecls decls
106 = do { -- First check for cyclic type synonysm or classes
107 -- See notes with checkCycleErrs
110 ; tyclss <- fixM (\ rec_tyclss ->
111 do { lcl_things <- mappM getInitialKind decls
112 -- Extend the local env with kinds, and
113 -- the global env with the knot-tied results
114 ; let { gbl_things = mkGlobalThings decls rec_tyclss }
115 ; tcExtendRecEnv gbl_things lcl_things $ do
117 -- The local type environment is populated with
118 -- {"T" -> ARecTyCon k, ...}
119 -- and the global type envt with
120 -- {"T" -> ATyCon T, ...}
121 -- where k is T's (unzonked) kind
122 -- T is the loop-tied TyCon itself
123 -- We must populate the environment with the loop-tied T's right
124 -- away, because the kind checker may "fault in" some type
125 -- constructors that recursively mention T
127 -- Kind-check the declarations, returning kind-annotated decls
128 { kc_decls <- mappM kcTyClDecl decls
130 -- Calculate variances and rec-flag
131 ; let { calc_vrcs = calcTyConArgVrcs rec_tyclss
132 ; calc_rec = calcRecFlags rec_tyclss }
134 ; mappM (tcTyClDecl calc_vrcs calc_rec) kc_decls
136 -- Finished with knot-tying now
137 -- Extend the environment with the finished things
138 ; tcExtendGlobalEnv tyclss $ do
140 -- Perform the validity check
141 { traceTc (text "ready for validity check")
142 ; mappM_ checkValidTyCl decls
143 ; traceTc (text "done")
145 -- Add the implicit things;
146 -- we want them in the environment because
147 -- they may be mentioned in interface files
148 ; let { implicit_things = concatMap implicitTyThings tyclss }
149 ; traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things))
150 ; tcExtendGlobalEnv implicit_things getGblEnv
153 mkGlobalThings :: [RenamedTyClDecl] -- The decls
154 -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls
156 -- Driven by the Decls, and treating the TyThings lazily
157 -- make a TypeEnv for the new things
158 mkGlobalThings decls things
159 = map mk_thing (decls `zipLazy` things)
161 mk_thing (ClassDecl {tcdName = name}, ~(AClass cl)) = (name, AClass cl)
162 mk_thing (decl, ~(ATyCon tc)) = (tcdName decl, ATyCon tc)
166 %************************************************************************
170 %************************************************************************
172 We need to kind check all types in the mutually recursive group
173 before we know the kind of the type variables. For example:
176 op :: D b => a -> b -> b
179 bop :: (Monad c) => ...
181 Here, the kind of the locally-polymorphic type variable "b"
182 depends on *all the uses of class D*. For example, the use of
183 Monad c in bop's type signature means that D must have kind Type->Type.
186 ------------------------------------------------------------------------
187 getInitialKind :: TyClDecl Name -> TcM (Name, TcTyThing)
189 -- Note the lazy pattern match on the ATyCon etc
190 -- Exactly the same reason as the zipLay above
192 getInitialKind (TyData {tcdName = name})
193 = newKindVar `thenM` \ kind ->
194 returnM (name, ARecTyCon kind)
196 getInitialKind (TySynonym {tcdName = name})
197 = newKindVar `thenM` \ kind ->
198 returnM (name, ARecTyCon kind)
200 getInitialKind (ClassDecl {tcdName = name})
201 = newKindVar `thenM` \ kind ->
202 returnM (name, ARecClass kind)
205 ------------------------------------------------------------------------
206 kcTyClDecl :: RenamedTyClDecl -> TcM RenamedTyClDecl
208 kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
209 = do { res_kind <- newKindVar
210 ; kcTyClDeclBody decl res_kind $ \ tvs' ->
211 do { rhs' <- kcCheckHsType rhs res_kind
212 ; return (decl {tcdTyVars = tvs', tcdSynRhs = rhs'}) } }
214 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
215 = kcTyClDeclBody decl liftedTypeKind $ \ tvs' ->
216 do { ctxt' <- kcHsContext ctxt
217 ; cons' <- mappM kc_con_decl cons
218 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }
220 kc_con_decl (ConDecl name ex_tvs ex_ctxt details loc)
221 = kcHsTyVars ex_tvs $ \ ex_tvs' ->
222 do { ex_ctxt' <- kcHsContext ex_ctxt
223 ; details' <- kc_con_details details
224 ; return (ConDecl name ex_tvs' ex_ctxt' details' loc)}
226 kc_con_details (PrefixCon btys)
227 = do { btys' <- mappM kc_arg_ty btys ; return (PrefixCon btys') }
228 kc_con_details (InfixCon bty1 bty2)
229 = do { bty1' <- kc_arg_ty bty1; bty2' <- kc_arg_ty bty2; return (InfixCon bty1' bty2') }
230 kc_con_details (RecCon fields)
231 = do { fields' <- mappM kc_field fields; return (RecCon fields') }
233 kc_field (fld, bty) = do { bty' <- kc_arg_ty bty ; return (fld, bty') }
235 kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') }
236 kc_arg_ty_body = case new_or_data of
237 DataType -> kcHsSigType
238 NewType -> kcHsLiftedSigType
239 -- Can't allow an unlifted type for newtypes, because we're effectively
240 -- going to remove the constructor while coercing it to a lifted type.
242 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})
243 = kcTyClDeclBody decl liftedTypeKind $ \ tvs' ->
244 do { ctxt' <- kcHsContext ctxt
245 ; sigs' <- mappM kc_sig sigs
246 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
248 kc_sig (Sig nm op_ty loc) = do { op_ty' <- kcHsLiftedSigType op_ty
249 ; return (Sig nm op_ty' loc) }
250 kc_sig other_sig = return other_sig
252 kcTyClDecl decl@(ForeignType {})
255 kcTyClDeclBody :: RenamedTyClDecl -> TcKind
256 -> ([HsTyVarBndr Name] -> TcM a)
258 -- Extend the env with bindings for the tyvars, taken from
259 -- the kind of the tycon/class. Give it to the thing inside, and
260 -- check the result kind matches
261 kcTyClDeclBody decl res_kind thing_inside
262 = tcAddDeclCtxt decl $
263 kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs ->
264 do { tc_ty_thing <- tcLookup (tcdName decl)
265 ; let { tc_kind = case tc_ty_thing of
269 ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind)
271 ; thing_inside kinded_tvs }
273 kindedTyVarKind (KindedTyVar _ k) = k
277 %************************************************************************
279 \subsection{Type checking}
281 %************************************************************************
284 tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag)
285 -> RenamedTyClDecl -> TcM TyThing
287 tcTyClDecl calc_vrcs calc_isrec decl
288 = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
290 tcTyClDecl1 calc_vrcs calc_isrec
291 (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
292 = tcTyVarBndrs tvs $ \ tvs' -> do
293 { rhs_ty' <- tcHsKindedType rhs_ty
294 ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) }
296 arg_vrcs = calc_vrcs tc_name
298 tcTyClDecl1 calc_vrcs calc_isrec
299 (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
300 tcdName = tc_name, tcdCons = cons})
301 = tcTyVarBndrs tvs $ \ tvs' -> do
302 { ctxt' <- tcHsKindedContext ctxt
303 ; want_generic <- doptM Opt_Generics
304 ; tycon <- fixM (\ tycon -> do
305 { cons' <- mappM (tcConDecl new_or_data tycon tvs' ctxt') cons
306 ; buildAlgTyCon new_or_data tc_name tvs' ctxt'
307 (DataCons cons') arg_vrcs is_rec
308 (want_generic && canDoGenerics cons')
310 ; return (ATyCon tycon)
313 arg_vrcs = calc_vrcs tc_name
314 is_rec = calc_isrec tc_name
316 tcTyClDecl1 calc_vrcs calc_isrec
317 (ClassDecl {tcdName = class_name, tcdTyVars = tvs,
318 tcdCtxt = ctxt, tcdMeths = meths,
319 tcdFDs = fundeps, tcdSigs = sigs} )
320 = tcTyVarBndrs tvs $ \ tvs' -> do
321 { ctxt' <- tcHsKindedContext ctxt
322 ; fds' <- mappM tc_fundep fundeps
323 ; sig_stuff <- tcClassSigs class_name sigs meths
324 ; clas <- fixM (\ clas ->
325 let -- This little knot is just so we can get
326 -- hold of the name of the class TyCon, which we
327 -- need to look up its recursiveness and variance
328 tycon_name = tyConName (classTyCon clas)
329 tc_isrec = calc_isrec tycon_name
330 tc_vrcs = calc_vrcs tycon_name
332 buildClass class_name tvs' ctxt' fds'
333 sig_stuff tc_isrec tc_vrcs)
334 ; return (AClass clas) }
336 tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
337 ; tvs2' <- mappM tcLookupTyVar tvs2 ;
338 ; return (tvs1', tvs2') }
341 tcTyClDecl1 calc_vrcs calc_isrec
342 (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name})
343 = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
345 -----------------------------------
346 tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType
347 -> RenamedConDecl -> TcM DataCon
349 tcConDecl new_or_data tycon tyvars ctxt
350 (ConDecl name ex_tvs ex_ctxt details src_loc)
351 = addSrcLoc src_loc $
352 tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do
353 { ex_ctxt' <- tcHsKindedContext ex_ctxt
354 ; unbox_strict <- doptM Opt_UnboxStrictFields
356 tc_datacon field_lbls btys
357 = do { arg_tys <- mappM (tcHsKindedType . getBangType) btys
359 (argStrictness unbox_strict tycon btys arg_tys)
361 tyvars ctxt ex_tvs' ex_ctxt'
364 PrefixCon btys -> tc_datacon [] btys
365 InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2]
366 RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name)
367 ; let { (field_names, btys) = unzip fields }
368 ; tc_datacon field_names btys } }
370 argStrictness :: Bool -- True <=> -funbox-strict_fields
371 -> TyCon -> [BangType Name]
372 -> [TcType] -> [StrictnessMark]
373 argStrictness unbox_strict tycon btys arg_tys
374 = zipWith (chooseBoxingStrategy unbox_strict tycon)
376 (map getBangStrictness btys ++ repeat HsNoBang)
378 -- We attempt to unbox/unpack a strict field when either:
379 -- (i) The field is marked '!!', or
380 -- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
382 chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
383 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
385 HsNoBang -> NotMarkedStrict
386 HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
387 HsUnbox | can_unbox -> MarkedUnboxed
388 other -> MarkedStrict
390 can_unbox = case splitTyConApp_maybe arg_ty of
392 Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
393 isProductTyCon arg_tycon
396 %************************************************************************
398 \subsection{Dependency analysis}
400 %************************************************************************
402 Validity checking is done once the mutually-recursive knot has been
403 tied, so we can look at things freely.
406 checkCycleErrs :: [TyClDecl Name] -> TcM ()
407 checkCycleErrs tyclss
408 | null syn_cycles && null cls_cycles
411 = do { mappM_ recSynErr syn_cycles
412 ; mappM_ recClsErr cls_cycles
413 ; failM } -- Give up now, because later checkValidTyCl
414 -- will loop if the synonym is recursive
416 (syn_cycles, cls_cycles) = calcCycleErrs tyclss
418 checkValidTyCl :: RenamedTyClDecl -> TcM ()
419 -- We do the validity check over declarations, rather than TyThings
420 -- only so that we can add a nice context with tcAddDeclCtxt
422 = tcAddDeclCtxt decl $
423 do { thing <- tcLookupGlobal (tcdName decl)
424 ; traceTc (text "Validity of" <+> ppr thing)
426 ATyCon tc -> checkValidTyCon tc
427 AClass cl -> checkValidClass cl
428 ; traceTc (text "Done validity of" <+> ppr thing)
431 -------------------------
432 checkValidTyCon :: TyCon -> TcM ()
435 = checkValidType syn_ctxt syn_rhs
437 = -- Check the context on the data decl
438 checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_`
440 -- Check arg types of data constructors
441 mappM_ checkValidDataCon data_cons `thenM_`
443 -- Check that fields with the same name share a type
444 mappM_ check_fields groups
447 syn_ctxt = TySynCtxt name
449 (_, syn_rhs) = getSynTyConDefn tc
450 data_cons = tyConDataCons tc
452 fields = [field | con <- data_cons, field <- dataConFieldLabels con]
453 groups = equivClasses cmp_name fields
454 cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
456 check_fields fields@(first_field_label : other_fields)
457 -- These fields all have the same name, but are from
458 -- different constructors in the data type
459 = -- Check that all the fields in the group have the same type
460 -- NB: this check assumes that all the constructors of a given
461 -- data type use the same type variables
462 checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
464 field_ty = fieldLabelType first_field_label
465 field_name = fieldLabelName first_field_label
466 other_tys = map fieldLabelType other_fields
468 -------------------------------
469 checkValidDataCon :: DataCon -> TcM ()
470 checkValidDataCon con
471 = addErrCtxt (dataConCtxt con) (
472 checkValidType ctxt (idType (dataConWrapId con)) `thenM_`
473 -- This checks the argument types and
474 -- ambiguity of the existential context (if any)
475 checkFreeness ex_tvs ex_theta)
477 ctxt = ConArgCtxt (dataConName con)
478 (_, _, ex_tvs, ex_theta, _, _) = dataConSig con
481 -------------------------------
482 checkValidClass :: Class -> TcM ()
484 = do { -- CHECK ARITY 1 FOR HASKELL 1.4
485 gla_exts <- doptM Opt_GlasgowExts
487 -- Check that the class is unary, unless GlaExs
488 ; checkTc (notNull tyvars) (nullaryClassErr cls)
489 ; checkTc (gla_exts || unary) (classArityErr cls)
491 -- Check the super-classes
492 ; checkValidTheta (ClassSCCtxt (className cls)) theta
494 -- Check the class operations
495 ; mappM_ check_op op_stuff
497 -- Check that if the class has generic methods, then the
498 -- class has only one parameter. We can't do generic
499 -- multi-parameter type classes!
500 ; checkTc (unary || no_generics) (genericMultiParamErr cls)
503 (tyvars, theta, _, op_stuff) = classBigSig cls
504 unary = isSingleton tyvars
505 no_generics = null [() | (_, GenDefMeth) <- op_stuff]
507 check_op (sel_id, dm)
508 = addErrCtxt (classOpCtxt sel_id) (
509 checkValidTheta SigmaCtxt (tail theta) `thenM_`
510 -- The 'tail' removes the initial (C a) from the
511 -- class itself, leaving just the method type
513 checkValidType (FunSigCtxt op_name) tau `thenM_`
515 -- Check that for a generic method, the type of
516 -- the method is sufficiently simple
517 checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
518 (badGenericMethodType op_name op_ty)
521 op_name = idName sel_id
522 op_ty = idType sel_id
523 (_,theta,tau) = tcSplitSigmaTy op_ty
527 ---------------------------------------------------------------------
528 fieldTypeMisMatch field_name
529 = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
531 dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
532 nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
534 (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con
535 ex_part | null ex_tvs = empty
536 | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
537 -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
538 -- data T a = Eq a => T a a
539 -- So we make sure to print it
541 fields = dataConFieldLabels con
542 arg_part | null fields = sep (map pprParendType arg_tys)
543 | otherwise = braces (sep (punctuate comma
544 [ ppr n <+> dcolon <+> ppr ty
545 | (n,ty) <- fields `zip` arg_tys]))
547 classOpCtxt sel_id = sep [ptext SLIT("When checking the class method:"),
548 nest 2 (ppr sel_id <+> dcolon <+> ppr (idType sel_id))]
551 = ptext SLIT("No parameters for class") <+> quotes (ppr cls)
554 = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
555 parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
557 genericMultiParamErr clas
558 = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
559 ptext SLIT("cannot have generic methods")
561 badGenericMethodType op op_ty
562 = hang (ptext SLIT("Generic method type is too complex"))
563 4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
564 ptext SLIT("You can only use type variables, arrows, and tuples")])
567 = addSrcLoc (getSrcLoc (head tcs)) $
568 addErr (sep [ptext SLIT("Cycle in type synonym declarations:"),
569 nest 2 (vcat (map ppr_thing tcs))])
572 = addSrcLoc (getSrcLoc (head clss)) $
573 addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"),
574 nest 2 (vcat (map ppr_thing clss))])
576 ppr_thing :: Name -> SDoc
577 ppr_thing n = ppr n <+> parens (ppr (getSrcLoc n))
581 = ptext SLIT("Can't combine named fields with locally-quantified type variables")
583 (ptext SLIT("In the declaration of data constructor") <+> ppr name)