2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcClassDcl]{Typechecking class declarations}
7 module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
12 InPat(..), andMonoBinds, getTyVarName
14 import HsPragmas ( ClassPragmas(..) )
15 import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
16 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
17 RenamedClassOpSig(..), RenamedMonoBinds,
18 RenamedContext(..), RenamedHsDecl, RenamedSig
20 import TcHsSyn ( TcMonoBinds )
22 import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
23 import TcEnv ( TcIdOcc(..), tcAddImportedIdInfo,
24 tcLookupClass, tcLookupTyVar,
25 tcExtendGlobalTyVars, tcExtendLocalValEnv
27 import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..) )
28 import TcKind ( unifyKinds, TcKind )
30 import TcMonoType ( tcHsType, tcContext )
31 import TcSimplify ( tcSimplifyAndCheck )
32 import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
33 zonkSigTyVar, tcInstSigTcType
35 import FieldLabel ( firstFieldLabelTag )
36 import Bag ( unionManyBags )
37 import Class ( mkClass, classBigSig, Class )
38 import CmdLineOpts ( opt_GlasgowExts )
39 import MkId ( mkDataCon, mkSuperDictSelId,
40 mkMethodSelId, mkDefaultMethodId
42 import Id ( Id, StrictnessMark(..),
43 getIdUnfolding, idType
45 import CoreUnfold ( getUnfoldingTemplate )
47 import Name ( Name, isLocallyDefined, OccName, nameOccName,
50 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
51 mkSigmaTy, mkForAllTys, Type, ThetaType
53 import TyVar ( mkTyVarSet, tyVarKind, TyVar )
54 import TyCon ( mkDataTyCon )
55 import Kind ( mkBoxedTypeKind, mkArrowKind )
56 import Unique ( Unique, Uniquable(..) )
58 import Maybes ( assocMaybe, maybeToBool )
61 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
62 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
63 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
71 Every class implicitly declares a new data type, corresponding to dictionaries
72 of that class. So, for example:
74 class (D a) => C a where
76 op2 :: forall b. Ord b => a -> b -> b
78 would implicitly declare
80 data CDict a = CDict (D a)
82 (forall b. Ord b => a -> b -> b)
84 (We could use a record decl, but that means changing more of the existing apparatus.
87 For classes with just one superclass+method, we use a newtype decl instead:
90 op :: forallb. a -> b -> b
94 newtype CDict a = CDict (forall b. a -> b -> b)
96 Now DictTy in Type is just a form of type synomym:
97 DictTy c t = TyConTy CDict `AppTy` t
99 Death to "ExpandingDicts".
103 tcClassDecl1 rec_env rec_inst_mapper
104 (ClassDecl context class_name
105 tyvar_names class_sigs def_methods pragmas
106 tycon_name datacon_name src_loc)
107 = tcAddSrcLoc src_loc $
108 tcAddErrCtxt (classDeclCtxt class_name) $
110 -- CHECK ARITY 1 FOR HASKELL 1.4
111 checkTc (opt_GlasgowExts || length tyvar_names == 1)
112 (classArityErr class_name) `thenTc_`
114 -- LOOK THINGS UP IN THE ENVIRONMENT
115 tcLookupClass class_name `thenTc` \ (class_kinds, rec_class) ->
116 mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names
117 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
119 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
120 unifyKinds class_kinds tyvar_kinds `thenTc_`
123 tcClassContext rec_class rec_tyvars context pragmas
124 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
126 -- CHECK THE CLASS SIGNATURES,
127 mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs
128 `thenTc` \ sig_stuff ->
130 -- MAKE THE CLASS OBJECT ITSELF
132 (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
133 rec_class_inst_env = rec_inst_mapper rec_class
134 clas = mkClass (getName class_name) rec_tyvars
135 sc_theta sc_sel_ids op_sel_ids defm_ids
139 dict_component_tys = sc_tys ++ op_tys
140 new_or_data = case dict_component_tys of
144 dict_con_id = mkDataCon datacon_name
145 [NotMarkedStrict | _ <- dict_component_tys]
146 [{- No labelled fields -}]
149 [{-No existential tyvars-}] [{-Or context-}]
153 tycon = mkDataTyCon tycon_name
154 (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars)
157 [dict_con_id] -- Constructors
159 (Just clas) -- Yes! It's a dictionary
168 tcClassContext :: Class -> [TyVar]
169 -> RenamedContext -- class context
170 -> RenamedClassPragmas -- pragmas for superclasses
171 -> TcM s (ThetaType, -- the superclass context
172 [Type], -- types of the superclass dictionaries
173 [Id]) -- superclass selector Ids
175 tcClassContext rec_class rec_tyvars context pragmas
176 = -- Check the context.
177 -- The renamer has already checked that the context mentions
178 -- only the type variable of the class decl.
179 tcContext context `thenTc` \ sc_theta ->
181 sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
184 -- Make super-class selector ids
185 -- We number them off, 1, 2, 3 etc so that we can construct
186 -- names for the selectors. Thus
187 -- class (C a, C b) => D a b where ...
188 -- gives superclass selectors
190 -- (We used to call them D_C, but now we can have two different
191 -- superclasses both called C!)
192 mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids ->
195 returnTc (sc_theta, sc_tys, sc_sel_ids)
198 rec_tyvar_tys = mkTyVarTys rec_tyvars
200 mk_super_id ((super_class, tys), index)
201 = tcGetUnique `thenNF_Tc` \ uniq ->
203 ty = mkForAllTys rec_tyvars $
204 mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
206 returnTc (mkSuperDictSelId uniq rec_class index ty)
209 tcClassSig :: TcEnv s -- Knot tying only!
210 -> Class -- ...ditto...
211 -> [TyVar] -- The class type variable, used for error check only
213 -> TcM s (Type, -- Type of the method
215 Maybe Id) -- default-method ids
217 tcClassSig rec_env rec_clas rec_clas_tyvars
218 (ClassOpSig op_name maybe_dm_name
221 = tcAddSrcLoc src_loc $
223 -- Check the type signature. NB that the envt *already has*
224 -- bindings for the type variables; see comments in TcTyAndClassDcls.
226 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
227 -- and that it is not constrained by theta
228 tcHsType op_ty `thenTc` \ local_ty ->
230 global_ty = mkSigmaTy rec_clas_tyvars
231 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
235 -- Build the selector id and default method id
237 sel_id = mkMethodSelId op_name rec_clas global_ty
238 maybe_dm_id = case maybe_dm_name of
241 dm_id = mkDefaultMethodId dm_name rec_clas global_ty
243 Just (tcAddImportedIdInfo rec_env dm_id)
245 returnTc (local_ty, sel_id, maybe_dm_id)
249 %************************************************************************
251 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
253 %************************************************************************
255 The purpose of pass 2 is
258 to beat on the explicitly-provided default-method decls (if any),
259 using them to produce a complete set of default-method decls.
260 (Omitted ones elicit an error message.)
262 to produce a definition for the selector function for each method
263 and superclass dictionary.
266 Pass~2 only applies to locally-defined class declarations.
268 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
269 each local class decl.
272 tcClassDecls2 :: [RenamedHsDecl]
273 -> NF_TcM s (LIE s, TcMonoBinds s)
277 (returnNF_Tc (emptyLIE, EmptyMonoBinds))
278 [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
280 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
281 tc2 `thenNF_Tc` \ (lie2, binds2) ->
282 returnNF_Tc (lie1 `plusLIE` lie2,
283 binds1 `AndMonoBinds` binds2)
286 @tcClassDecl2@ is the business end of things.
289 tcClassDecl2 :: RenamedClassDecl -- The class declaration
290 -> NF_TcM s (LIE s, TcMonoBinds s)
292 tcClassDecl2 (ClassDecl context class_name
293 tyvar_names class_sigs default_binds pragmas _ _ src_loc)
295 | not (isLocallyDefined class_name)
296 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
298 | otherwise -- It is locally defined
299 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
300 tcAddSrcLoc src_loc $
302 -- Get the relevant class
303 tcLookupClass class_name `thenTc` \ (_, clas) ->
305 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
307 -- The selector binds are already in the selector Id's unfoldings
308 sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
309 | sel_id <- sc_sel_ids ++ op_sel_ids,
310 isLocallyDefined sel_id
313 final_sel_binds = andMonoBinds sel_binds
315 -- Generate bindings for the default methods
316 tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
318 returnTc (const_insts,
319 final_sel_binds `AndMonoBinds` meth_binds)
322 %************************************************************************
324 \subsection[Default methods]{Default methods}
326 %************************************************************************
328 The default methods for a class are each passed a dictionary for the
329 class, so that they get access to the other methods at the same type.
330 So, given the class decl
334 op2 :: Ord b => a -> b -> b -> b
337 op2 x y z = if (op1 x) && (y < z) then y else z
339 we get the default methods:
341 defm.Foo.op1 :: forall a. Foo a => a -> Bool
342 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
344 ====================== OLD ==================
346 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
347 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
348 if (op1 a dfoo x) && (< b dord y z) then y else z
350 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
351 ====================== END OF OLD ===================
355 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
356 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
357 if (op1 a dfoo x) && (< b dord y z) then y else z
361 When we come across an instance decl, we may need to use the default
364 instance Foo Int where {}
368 const.Foo.Int.op1 :: Int -> Bool
369 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
371 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
372 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
374 dfun.Foo.Int :: Foo Int
375 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
377 Notice that, as with method selectors above, we assume that dictionary
378 application is curried, so there's no need to mention the Ord dictionary
379 in const.Foo.Int.op2 (or the type variable).
382 instance Foo a => Foo [a] where {}
384 dfun.Foo.List :: forall a. Foo a -> Foo [a]
386 = /\ a -> \ dfoo_a ->
388 op1 = defm.Foo.op1 [a] dfoo_list
389 op2 = defm.Foo.op2 [a] dfoo_list
390 dfoo_list = (op1, op2)
399 -> TcM s (LIE s, TcMonoBinds s)
401 tcDefaultMethodBinds clas default_binds
402 = -- Construct suitable signatures
403 tcInstSigTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
405 -- Typecheck the default bindings
408 | not (maybeToBool maybe_stuff)
409 = -- Binding for something that isn't in the class signature
410 failWithTc (badMethodErr bndr_name clas)
414 tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind [{- No prags -}]
415 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
416 returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
418 bndr_name = case meth_bind of
419 FunMonoBind name _ _ _ -> name
420 PatMonoBind (VarPatIn name) _ _ -> name
422 maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
423 assoc_list = [ (getOccName sel_id, pair)
424 | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
426 Just (sel_id, Just dm_id) = maybe_stuff
427 -- We're looking at a default-method binding, so the dm_id
428 -- is sure to be there! Hence the inner "Just".
431 (flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
434 newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
436 avail_insts = this_dict
438 tcAddErrCtxt (classDeclCtxt clas) $
439 mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
441 (ptext SLIT("class") <+> ppr clas)
442 (mkTyVarSet clas_tyvars')
444 (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
447 full_binds = AbsBinds
451 (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
453 returnTc (const_lie, full_binds)
456 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
457 origin = ClassDeclOrigin
459 flatten EmptyMonoBinds rest = rest
460 flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
461 flatten a_bind rest = a_bind : rest
464 @tcMethodBind@ is used to type-check both default-method and
465 instance-decl method declarations. We must type-check methods one at a
466 time, because their signatures may have different contexts and
473 -> [TcType s] -- Instance types
474 -> [TcTyVar s] -- Free variables of those instance types
475 -- they'll be signature tyvars, and we
476 -- want to check that they don't bound
477 -> Id -- The method selector
478 -> RenamedMonoBinds -- Method binding (just one)
479 -> [RenamedSig] -- Pramgas (just for this one)
480 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
482 tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
483 = tcAddSrcLoc src_loc $
484 newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
485 tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
487 (theta', tau') = splitRhoTy rho_ty'
488 sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
490 tcExtendLocalValEnv [bndr_name] [local_meth_id] (
492 ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
494 tcExtendGlobalTyVars inst_tyvars (
495 tcAddErrCtxt (methodCtxt sel_id) $
496 tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
497 NonRecursive prag_info_fn
498 ) `thenTc` \ (binds, insts, _) ->
500 -- Now check that the instance type variables
501 -- (or, in the case of a class decl, the class tyvars)
502 -- have not been unified with anything in the environment
503 tcAddErrCtxt (monoCtxt sel_id) (
504 tcAddErrCtxt (sigCtxt sel_id) $
505 checkSigTyVars inst_tyvars (idType local_meth_id)
508 returnTc (binds `AndMonoBinds` prag_binds,
509 insts `plusLIE` prag_lie,
512 (bndr_name, src_loc) = case meth_bind of
513 FunMonoBind name _ _ loc -> (name, loc)
514 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
520 classArityErr class_name
521 = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
523 classDeclCtxt class_name
524 = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
527 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
530 = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
531 nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
534 badMethodErr bndr clas
535 = hsep [ptext SLIT("Class"), quotes (ppr clas),
536 ptext SLIT("does not have a method"), quotes (ppr bndr)]