2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcClassDcl]{Typechecking class declarations}
7 #include "HsVersions.h"
9 module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
13 import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
14 Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
15 DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
16 HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
17 Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
18 import HsTypes ( getTyVarName )
19 import HsPragmas ( ClassPragmas(..) )
20 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
21 RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
22 RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
24 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
25 mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
27 import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
28 import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
29 import TcInstDcls ( processInstBinds )
30 import TcKind ( unifyKind, TcKind )
32 import TcMonoType ( tcHsType, tcContext )
33 import TcSimplify ( tcSimplifyAndCheck )
34 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
36 import Bag ( foldBag, unionManyBags )
37 import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig,
38 classOps, classOpString, classOpLocalType,
39 classOpTagByOccName, SYN_IE(ClassOp)
41 import Id ( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding,
43 import CoreUnfold ( getUnfoldingTemplate )
45 import Name ( Name, isLocallyDefined, moduleString, modAndOcc, nameString )
46 import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
49 import PprType ( GenType, GenTyVar, GenClassOp )
50 import SpecEnv ( SpecEnv )
51 import SrcLoc ( mkGeneratedSrcLoc )
52 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
53 mkForAllTy, mkSigmaTy, splitSigmaTy)
54 import TysWiredIn ( stringTy )
55 import TyVar ( unitTyVarSet, GenTyVar )
56 import Unique ( Unique )
60 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
61 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
62 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
70 Every class implicitly declares a new data type, corresponding to dictionaries
71 of that class. So, for example:
73 class (D a) => C a where
75 op2 :: forall b. Ord b => a -> b -> b
77 would implicitly declare
79 data CDict a = CDict (D a)
81 (forall b. Ord b => a -> b -> b)
83 (We could use a record decl, but that means changing more of the existing apparatus.
86 For classes with just one superclass+method, we use a newtype decl instead:
89 op :: forallb. a -> b -> b
93 newtype CDict a = CDict (forall b. a -> b -> b)
95 Now DictTy in Type is just a form of type synomym:
96 DictTy c t = TyConTy CDict `AppTy` t
98 Death to "ExpandingDicts".
102 tcClassDecl1 rec_inst_mapper
103 (ClassDecl context class_name
104 tyvar_name class_sigs def_methods pragmas src_loc)
105 = tcAddSrcLoc src_loc $
106 tcAddErrCtxt (classDeclCtxt class_name) $
108 -- LOOK THINGS UP IN THE ENVIRONMENT
109 tcLookupClass class_name `thenTc` \ (class_kind, rec_class) ->
110 tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
112 (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
115 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
116 unifyKind class_kind tyvar_kind `thenTc_`
119 tcClassContext rec_class rec_tyvar context pragmas
120 `thenTc` \ (scs, sc_sel_ids) ->
122 -- CHECK THE CLASS SIGNATURES,
123 mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
124 `thenTc` \ sig_stuff ->
126 -- MAKE THE CLASS OBJECT ITSELF
128 (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
129 clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
130 scs sc_sel_ids ops op_sel_ids defm_ids
138 clas_ty = mkTyVarTy clas_tyvar
139 dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
140 [classOpLocalType op | op <- ops])
141 new_or_data = case dict_component_tys of
145 dict_con_id = mkDataCon class_name
147 [{- No labelled fields -}]
153 tycon = mkDataTyCon class_name
154 (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
156 [{- Empty context -}]
158 [{- No derived classes -}]
164 tcClassContext :: Class -> TyVar
165 -> RenamedContext -- class context
166 -> RenamedClassPragmas -- pragmas for superclasses
167 -> TcM s ([Class], -- the superclasses
168 [Id]) -- superclass selector Ids
170 tcClassContext rec_class rec_tyvar context pragmas
171 = -- Check the context.
172 -- The renamer has already checked that the context mentions
173 -- only the type variable of the class decl.
174 tcContext context `thenTc` \ theta ->
176 super_classes = [ supers | (supers, _) <- theta ]
179 -- Make super-class selector ids
180 mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
183 returnTc (super_classes, sc_sel_ids)
186 rec_tyvar_ty = mkTyVarTy rec_tyvar
188 mk_super_id rec_class super_class
189 = tcGetUnique `thenNF_Tc` \ uniq ->
191 ty = mkForAllTy rec_tyvar $
192 mkFunTy (mkDictTy rec_class rec_tyvar_ty)
193 (mkDictTy super_class rec_tyvar_ty)
195 returnTc (mkSuperDictSelId uniq rec_class super_class ty)
198 tcClassSig :: Class -- Knot tying only!
199 -> TyVar -- The class type variable, used for error check only
200 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
202 -> TcM s (ClassOp, -- class op
204 Id) -- default-method ids
206 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
210 = tcAddSrcLoc src_loc $
211 fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
213 -- Check the type signature. NB that the envt *already has*
214 -- bindings for the type variables; see comments in TcTyAndClassDcls.
216 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
217 -- and that it is not constrained by theta
218 tcHsType op_ty `thenTc` \ local_ty ->
220 global_ty = mkSigmaTy [rec_clas_tyvar]
221 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
223 class_op_nm = getOccName op_name
224 class_op = mkClassOp class_op_nm
225 (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm)
229 -- Build the selector id and default method id
230 tcGetUnique `thenNF_Tc` \ d_uniq ->
232 sel_id = mkMethodSelId op_name rec_clas class_op global_ty
233 defm_id = mkDefaultMethodId op_name d_uniq rec_clas class_op False global_ty
234 -- ToDo: improve the "False"
236 returnTc (class_op, sel_id, defm_id)
241 %************************************************************************
243 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
245 %************************************************************************
247 The purpose of pass 2 is
250 to beat on the explicitly-provided default-method decls (if any),
251 using them to produce a complete set of default-method decls.
252 (Omitted ones elicit an error message.)
254 to produce a definition for the selector function for each method
255 and superclass dictionary.
258 Pass~2 only applies to locally-defined class declarations.
260 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
261 each local class decl.
264 tcClassDecls2 :: [RenamedHsDecl]
265 -> NF_TcM s (LIE s, TcHsBinds s)
269 (returnNF_Tc (emptyLIE, EmptyBinds))
270 [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
272 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
273 tc2 `thenNF_Tc` \ (lie2, binds2) ->
274 returnNF_Tc (lie1 `plusLIE` lie2,
275 binds1 `ThenBinds` binds2)
278 @tcClassDecl2@ is the business end of things.
281 tcClassDecl2 :: RenamedClassDecl -- The class declaration
282 -> NF_TcM s (LIE s, TcHsBinds s)
284 tcClassDecl2 (ClassDecl context class_name
285 tyvar_name class_sigs default_binds pragmas src_loc)
287 | not (isLocallyDefined class_name)
288 = returnNF_Tc (emptyLIE, EmptyBinds)
290 | otherwise -- It is locally defined
291 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
292 tcAddSrcLoc src_loc $
294 -- Get the relevant class
295 tcLookupClass class_name `thenTc` \ (_, clas) ->
297 (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
300 -- The selector binds are already in the selector Id's unfoldings
301 sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $
302 [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
303 | sel_id <- sc_sel_ids ++ op_sel_ids,
304 isLocallyDefined sel_id
307 -- Generate bindings for the default methods
308 tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
309 buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
310 `thenTc` \ (const_insts, meth_binds) ->
312 returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
315 %************************************************************************
317 \subsection[Default methods]{Default methods}
319 %************************************************************************
321 The default methods for a class are each passed a dictionary for the
322 class, so that they get access to the other methods at the same type.
323 So, given the class decl
327 op2 :: Ord b => a -> b -> b -> b
330 op2 x y z = if (op1 x) && (y < z) then y else z
332 we get the default methods:
334 defm.Foo.op1 :: forall a. Foo a => a -> Bool
335 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
337 ====================== OLD ==================
339 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
340 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
341 if (op1 a dfoo x) && (< b dord y z) then y else z
343 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
344 ====================== END OF OLD ===================
348 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
349 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
350 if (op1 a dfoo x) && (< b dord y z) then y else z
354 When we come across an instance decl, we may need to use the default
357 instance Foo Int where {}
361 const.Foo.Int.op1 :: Int -> Bool
362 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
364 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
365 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
367 dfun.Foo.Int :: Foo Int
368 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
370 Notice that, as with method selectors above, we assume that dictionary
371 application is curried, so there's no need to mention the Ord dictionary
372 in const.Foo.Int.op2 (or the type variable).
375 instance Foo a => Foo [a] where {}
377 dfun.Foo.List :: forall a. Foo a -> Foo [a]
379 = /\ a -> \ dfoo_a ->
381 op1 = defm.Foo.op1 [a] dfoo_list
382 op2 = defm.Foo.op2 [a] dfoo_list
383 dfoo_list = (op1, op2)
389 buildDefaultMethodBinds
394 -> TcM s (LIE s, TcHsBinds s)
396 buildDefaultMethodBinds clas clas_tyvar
397 default_method_ids default_binds
398 = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
399 mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
401 avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available
402 clas_tyvar_set = unitTyVarSet clas_tyvar
404 tcExtendGlobalTyVars clas_tyvar_set (
407 (makeClassDeclDefaultMethodRhs clas local_defm_ids)
411 ) `thenTc` \ (insts_needed, default_binds') ->
416 insts_needed `thenTc` \ (const_lie, dict_binds) ->
420 defm_binds = AbsBinds
423 (local_defm_ids `zip` map RealId default_method_ids)
425 (RecBind default_binds')
427 returnTc (const_lie, defm_binds)
429 inst_ty = mkTyVarTy clas_tyvar
430 mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty]
431 origin = ClassDeclOrigin
434 @makeClassDeclDefaultMethodRhs@ builds the default method for a
435 class declaration when no explicit default method is given.
438 makeClassDeclDefaultMethodRhs
442 -> NF_TcM s (TcExpr s)
444 makeClassDeclDefaultMethodRhs clas method_ids tag
445 = -- Return the expression
446 -- error ty "No default method for ..."
447 -- The interesting thing is that method_ty is a for-all type;
448 -- this is fun, although unusual in a type application!
450 returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
451 (HsLitOut (HsString (_PK_ error_msg)) stringTy))
454 (clas_mod, clas_name) = modAndOcc clas
456 method_id = method_ids !! (tag-1)
457 class_op = (classOps clas) !! (tag-1)
459 error_msg = _UNPK_ (nameString (getName clas))
460 ++ (ppShow 80 (ppr PprForUser class_op))
461 -- ++ "\"" Don't know what this trailing quote is for!
468 classDeclCtxt class_name sty
469 = ppCat [ppStr "In the class declaration for", ppr sty class_name]