2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcClassDcl]{Typechecking class declarations}
7 module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
12 InPat(..), HsBinds(..), GRHSs(..),
13 HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
14 unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
17 import HsPragmas ( ClassPragmas(..) )
18 import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
19 import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas,
20 RenamedClassOpSig, RenamedMonoBinds,
21 RenamedContext, RenamedHsDecl, RenamedSig
23 import TcHsSyn ( TcMonoBinds )
25 import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
26 import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
27 tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
30 import TcBinds ( tcBindWithSigs, tcPragmaSigs )
31 import TcUnify ( unifyKinds )
33 import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
34 tcContext, checkSigTyVars, sigCtxt, mkTcSig
36 import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
37 import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
38 import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
39 import FieldLabel ( firstFieldLabelTag )
40 import Bag ( unionManyBags )
41 import Class ( mkClass, classBigSig, Class )
42 import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
43 import MkId ( mkSuperDictSelId, mkDataConId,
44 mkMethodSelId, mkDefaultMethodId
46 import DataCon ( mkDataCon )
48 getIdUnfolding, idType, idName
50 import CoreUnfold ( getUnfoldingTemplate )
52 import Name ( Name, isLocallyDefined, NamedThing(..) )
54 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
55 mkSigmaTy, mkForAllTys, Type, ThetaType,
56 boxedTypeKind, mkArrowKind
58 import Var ( tyVarKind, TyVar )
59 import VarSet ( mkVarSet )
60 import TyCon ( mkAlgTyCon )
61 import Unique ( Unique, Uniquable(..) )
63 import Maybes ( seqMaybe )
66 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
67 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
68 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
76 Every class implicitly declares a new data type, corresponding to dictionaries
77 of that class. So, for example:
79 class (D a) => C a where
81 op2 :: forall b. Ord b => a -> b -> b
83 would implicitly declare
85 data CDict a = CDict (D a)
87 (forall b. Ord b => a -> b -> b)
89 (We could use a record decl, but that means changing more of the existing apparatus.
92 For classes with just one superclass+method, we use a newtype decl instead:
95 op :: forallb. a -> b -> b
99 newtype CDict a = CDict (forall b. a -> b -> b)
101 Now DictTy in Type is just a form of type synomym:
102 DictTy c t = TyConTy CDict `AppTy` t
104 Death to "ExpandingDicts".
107 %************************************************************************
109 \subsection{Kind checking}
111 %************************************************************************
114 kcClassDecl (ClassDecl context class_name
115 tyvar_names class_sigs def_methods pragmas
116 tycon_name datacon_name src_loc)
117 = -- CHECK ARITY 1 FOR HASKELL 1.4
118 checkTc (opt_GlasgowExts || length tyvar_names == 1)
119 (classArityErr class_name) `thenTc_`
121 -- Get the (mutable) class kind
122 tcLookupTy class_name `thenNF_Tc` \ (kind, _, _) ->
124 -- Make suitable tyvars and do kind checking
125 -- The net effect is to mutate the class kind
126 tcExtendTopTyVarScope kind tyvar_names $ \ _ _ ->
127 tcContext context `thenTc_`
128 mapTc kc_sig class_sigs `thenTc_`
132 kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
136 %************************************************************************
138 \subsection{Type checking}
140 %************************************************************************
143 tcClassDecl1 rec_env rec_inst_mapper
144 (ClassDecl context class_name
145 tyvar_names class_sigs def_methods pragmas
146 tycon_name datacon_name src_loc)
147 = -- LOOK THINGS UP IN THE ENVIRONMENT
148 tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) ->
149 tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
150 -- The class kind is by now immutable
153 -- traceTc (text "tcClassCtxt" <+> ppr class_name) `thenTc_`
154 tcClassContext class_name rec_class tyvars context pragmas
155 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
156 -- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_`
158 -- CHECK THE CLASS SIGNATURES,
159 mapTc (tcClassSig rec_env rec_class tyvars) class_sigs
160 `thenTc` \ sig_stuff ->
162 -- MAKE THE CLASS OBJECT ITSELF
164 (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
165 rec_class_inst_env = rec_inst_mapper rec_class
166 clas = mkClass class_name tyvars
167 sc_theta sc_sel_ids op_sel_ids defm_ids
171 dict_component_tys = sc_tys ++ op_tys
172 new_or_data = case dict_component_tys of
176 dict_con = mkDataCon datacon_name
177 [NotMarkedStrict | _ <- dict_component_tys]
178 [{- No labelled fields -}]
181 [{-No existential tyvars-}] [{-Or context-}]
184 dict_con_id = mkDataConId dict_con
186 tycon = mkAlgTyCon tycon_name
190 [dict_con] -- Constructors
192 (Just clas) -- Yes! It's a dictionary
201 tcClassContext :: Name -> Class -> [TyVar]
202 -> RenamedContext -- class context
203 -> RenamedClassPragmas -- pragmas for superclasses
204 -> TcM s (ThetaType, -- the superclass context
205 [Type], -- types of the superclass dictionaries
206 [Id]) -- superclass selector Ids
208 tcClassContext class_name rec_class rec_tyvars context pragmas
209 = -- Check the context.
210 -- The renamer has already checked that the context mentions
211 -- only the type variable of the class decl.
213 -- For std Haskell check that the context constrains only tyvars
214 (if opt_GlasgowExts then
217 mapTc check_constraint context
220 tcContext context `thenTc` \ sc_theta ->
223 sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
226 -- Make super-class selector ids
227 -- We number them off, 1, 2, 3 etc so that we can construct
228 -- names for the selectors. Thus
229 -- class (C a, C b) => D a b where ...
230 -- gives superclass selectors
232 -- (We used to call them D_C, but now we can have two different
233 -- superclasses both called C!)
234 mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids ->
237 returnTc (sc_theta, sc_tys, sc_sel_ids)
240 rec_tyvar_tys = mkTyVarTys rec_tyvars
242 mk_super_id ((super_class, tys), index)
243 = tcGetUnique `thenNF_Tc` \ uniq ->
245 ty = mkForAllTys rec_tyvars $
246 mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
248 returnTc (mkSuperDictSelId uniq rec_class index ty)
250 check_constraint (c, tys) = checkTc (all is_tyvar tys)
251 (superClassErr class_name (c, tys))
253 is_tyvar (MonoTyVar _) = True
254 is_tyvar other = False
257 tcClassSig :: ValueEnv -- Knot tying only!
258 -> Class -- ...ditto...
259 -> [TyVar] -- The class type variable, used for error check only
261 -> TcM s (Type, -- Type of the method
263 Maybe Id) -- default-method ids
265 tcClassSig rec_env rec_clas rec_clas_tyvars
266 (ClassOpSig op_name maybe_dm_name
269 = tcAddSrcLoc src_loc $
271 -- Check the type signature. NB that the envt *already has*
272 -- bindings for the type variables; see comments in TcTyAndClassDcls.
274 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
275 -- and that it is not constrained by theta
276 -- traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
277 tcHsTopType op_ty `thenTc` \ local_ty ->
279 global_ty = mkSigmaTy rec_clas_tyvars
280 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
283 -- Build the selector id and default method id
284 sel_id = mkMethodSelId op_name rec_clas global_ty
285 maybe_dm_id = case maybe_dm_name of
288 dm_id = mkDefaultMethodId dm_name rec_clas global_ty
290 Just (tcAddImportedIdInfo rec_env dm_id)
292 -- traceTc (text "tcClassSig done" <+> ppr op_name) `thenTc_`
293 returnTc (local_ty, sel_id, maybe_dm_id)
297 %************************************************************************
299 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
301 %************************************************************************
303 The purpose of pass 2 is
306 to beat on the explicitly-provided default-method decls (if any),
307 using them to produce a complete set of default-method decls.
308 (Omitted ones elicit an error message.)
310 to produce a definition for the selector function for each method
311 and superclass dictionary.
314 Pass~2 only applies to locally-defined class declarations.
316 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
317 each local class decl.
320 tcClassDecls2 :: [RenamedHsDecl]
321 -> NF_TcM s (LIE, TcMonoBinds)
325 (returnNF_Tc (emptyLIE, EmptyMonoBinds))
326 [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
328 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
329 tc2 `thenNF_Tc` \ (lie2, binds2) ->
330 returnNF_Tc (lie1 `plusLIE` lie2,
331 binds1 `AndMonoBinds` binds2)
334 @tcClassDecl2@ is the business end of things.
337 tcClassDecl2 :: RenamedTyClDecl -- The class declaration
338 -> NF_TcM s (LIE, TcMonoBinds)
340 tcClassDecl2 (ClassDecl context class_name
341 tyvar_names class_sigs default_binds pragmas _ _ src_loc)
343 | not (isLocallyDefined class_name)
344 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
346 | otherwise -- It is locally defined
347 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
348 tcAddSrcLoc src_loc $
350 -- Get the relevant class
351 tcLookupClass class_name `thenNF_Tc` \ clas ->
353 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
355 -- The selector binds are already in the selector Id's unfoldings
356 -- sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
357 -- | sel_id <- sc_sel_ids ++ op_sel_ids,
358 -- isLocallyDefined sel_id
361 -- final_sel_binds = andMonoBindList sel_binds
363 -- Generate bindings for the default methods
364 tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
366 returnTc (const_insts, meth_binds)
367 -- final_sel_binds `AndMonoBinds` meth_binds)
368 -- Leave 'em out for now. They always get inlined anyway. SLPJ June '98
371 %************************************************************************
373 \subsection[Default methods]{Default methods}
375 %************************************************************************
377 The default methods for a class are each passed a dictionary for the
378 class, so that they get access to the other methods at the same type.
379 So, given the class decl
383 op2 :: Ord b => a -> b -> b -> b
386 op2 x y z = if (op1 x) && (y < z) then y else z
388 we get the default methods:
390 defm.Foo.op1 :: forall a. Foo a => a -> Bool
391 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
393 ====================== OLD ==================
395 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
396 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
397 if (op1 a dfoo x) && (< b dord y z) then y else z
399 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
400 ====================== END OF OLD ===================
404 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
405 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
406 if (op1 a dfoo x) && (< b dord y z) then y else z
410 When we come across an instance decl, we may need to use the default
413 instance Foo Int where {}
417 const.Foo.Int.op1 :: Int -> Bool
418 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
420 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
421 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
423 dfun.Foo.Int :: Foo Int
424 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
426 Notice that, as with method selectors above, we assume that dictionary
427 application is curried, so there's no need to mention the Ord dictionary
428 in const.Foo.Int.op2 (or the type variable).
431 instance Foo a => Foo [a] where {}
433 dfun.Foo.List :: forall a. Foo a -> Foo [a]
435 = /\ a -> \ dfoo_a ->
437 op1 = defm.Foo.op1 [a] dfoo_list
438 op2 = defm.Foo.op2 [a] dfoo_list
439 dfoo_list = (op1, op2)
448 -> TcM s (LIE, TcMonoBinds)
450 tcDefaultMethodBinds clas default_binds
451 = -- Construct suitable signatures
452 tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
454 -- Typecheck the default bindings
456 theta = [(clas,inst_tys)]
457 tc_dm sel_id_w_dm@(_, Just dm_id)
458 = tcMethodBind clas origin clas_tyvars inst_tys theta
459 default_binds [{-no prags-}] False
460 sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) ->
461 returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id))
463 tcExtendTyVarEnvForMeths tyvars clas_tyvars (
464 mapAndUnzip3Tc tc_dm sel_ids_w_dms
465 ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
469 newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
471 avail_insts = this_dict
473 tcAddErrCtxt (defltMethCtxt clas) $
475 -- tcMethodBind has checked that the class_tyvars havn't
476 -- been unified with each other or another type, but we must
477 -- still zonk them before passing them to tcSimplifyAndCheck
478 mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
481 (ptext SLIT("class") <+> ppr clas)
482 (mkVarSet clas_tyvars')
484 (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
487 full_binds = AbsBinds
491 (dict_binds `andMonoBinds` andMonoBindList defm_binds)
493 returnTc (const_lie, full_binds)
496 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
498 sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
499 -- Just the ones for which there is an explicit
500 -- user default declaration
502 origin = ClassDeclOrigin
505 @tcMethodBind@ is used to type-check both default-method and
506 instance-decl method declarations. We must type-check methods one at a
507 time, because their signatures may have different contexts and
514 -> [TcTyVar] -- Instantiated type variables for the
515 -- enclosing class/instance decl.
516 -- They'll be signature tyvars, and we
517 -- want to check that they don't get bound
518 -> [TcType] -- Instance types
519 -> TcThetaType -- Available theta; this could be used to check
520 -- the method signature, but actually that's done by
521 -- the caller; here, it's just used for the error message
522 -> RenamedMonoBinds -- Method binding (pick the right one from in here)
523 -> [RenamedSig] -- Pramgas (just for this one)
524 -> Bool -- True <=> supply default decl if no explicit decl
525 -- This is true for instance decls,
526 -- false for class decls
527 -> (Id, Maybe Id) -- The method selector and default-method Id
528 -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
530 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
531 meth_binds prags supply_default_bind
532 (sel_id, maybe_dm_id)
533 = tcGetSrcLoc `thenNF_Tc` \ loc ->
535 newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) ->
536 mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
539 meth_name = idName meth_id
540 maybe_user_bind = find_bind meth_name meth_binds
542 no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False}
543 no_user_default = case maybe_dm_id of {Nothing -> True; other -> False}
545 meth_bind = case maybe_user_bind of
547 Nothing -> mk_default_bind meth_name loc
549 meth_prags = find_prags meth_name prags
552 -- Warn if no method binding, only if -fwarn-missing-methods
553 if no_user_bind && not supply_default_bind then
554 pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
556 warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
557 (omittedMethodWarn sel_id clas) `thenNF_Tc_`
560 tcExtendLocalValEnv [(meth_name, meth_id)] (
561 tcPragmaSigs meth_prags
562 ) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
564 -- Check the bindings; first add inst_tyvars to the envt
565 -- so that we don't quantify over them in nested places
566 -- The *caller* put the class/inst decl tyvars into the envt
567 tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
568 tcAddErrCtxt (methodCtxt sel_id) $
569 tcBindWithSigs NotTopLevel meth_bind [sig_info]
570 NonRecursive prag_info_fn
571 ) `thenTc` \ (binds, insts, _) ->
574 -- The prag_lie for a SPECIALISE pragma will mention the function
575 -- itself, so we have to simplify them away right now lest they float
577 bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) ->
580 -- Now check that the instance type variables
581 -- (or, in the case of a class decl, the class tyvars)
582 -- have not been unified with anything in the environment
583 tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id))) $
584 checkSigTyVars inst_tyvars `thenTc_`
586 returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
587 insts `plusLIE` prag_lie',
590 sig_msg ty = sep [ptext SLIT("When checking the expected type for"),
591 nest 4 (ppr sel_name <+> dcolon <+> ppr ty)]
593 sel_name = idName sel_id
595 -- The renamer just puts the selector ID as the binder in the method binding
596 -- but we must use the method name; so we substitute it here. Crude but simple.
597 find_bind meth_name (FunMonoBind op_name fix matches loc)
598 | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
599 find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
600 | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
601 find_bind meth_name (AndMonoBinds b1 b2)
602 = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
603 find_bind meth_name other = Nothing -- Default case
606 -- Find the prags for this method, and replace the
607 -- selector name with the method name
608 find_prags meth_name [] = []
609 find_prags meth_name (SpecSig name ty spec loc : prags)
610 | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
611 find_prags meth_name (InlineSig name loc : prags)
612 | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
613 find_prags meth_name (NoInlineSig name loc : prags)
614 | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags
615 find_prags meth_name (prag:prags) = find_prags meth_name prags
617 mk_default_bind local_meth_name loc
618 = PatMonoBind (VarPatIn local_meth_name)
619 (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
623 = case maybe_dm_id of
624 Just dm_id -> HsVar (getName dm_id) -- There's a default method
625 Nothing -> error_expr loc -- No default method
627 error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
628 (HsLit (HsString (_PK_ (error_msg loc))))
630 error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
636 classArityErr class_name
637 = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
639 superClassErr class_name sc
640 = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
641 <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
643 defltMethCtxt class_name
644 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
647 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
649 badMethodErr bndr clas
650 = hsep [ptext SLIT("Class"), quotes (ppr clas),
651 ptext SLIT("does not have a method"), quotes (ppr bndr)]
653 omittedMethodWarn sel_id clas
654 = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
655 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]