2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcClassDcl]{Typechecking class declarations}
7 #include "HsVersions.h"
10 tcClassDecl1, tcClassDecls2
15 import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
16 Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
17 HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
18 Stmt, Qual, ArithSeqInfo, InPat, Fake )
19 import HsPragmas ( ClassPragmas(..) )
20 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
21 RenamedClassOpSig(..), RenamedMonoBinds(..),
22 RenamedGenPragmas(..), RenamedContext(..) )
23 import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
24 mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
27 import GenSpecEtc ( specTy )
28 import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
29 import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
30 import TcInstDcls ( processInstBinds )
31 import TcKind ( unifyKind )
32 import TcMonoType ( tcMonoType, tcContext )
33 import TcType ( TcTyVar(..), tcInstType, tcInstTyVar )
34 import TcKind ( TcKind )
36 import Bag ( foldBag )
37 import Class ( GenClass, mkClass, mkClassOp, getClassBigSig,
38 getClassOps, getClassOpString, getClassOpLocalType )
39 import CoreUtils ( escErrorMsg )
40 import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
42 import IdInfo ( noIdInfo )
43 import Name ( Name, getNameFullName, getTagFromClassOpName )
44 import PrelVals ( pAT_ERROR_ID )
47 import PprType ( GenType, GenTyVar, GenClassOp )
48 import SpecEnv ( SpecEnv(..) )
49 import SrcLoc ( mkGeneratedSrcLoc )
50 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
51 mkForAllTy, mkSigmaTy, splitSigmaTy)
52 import TysWiredIn ( stringTy )
53 import TyVar ( GenTyVar )
54 import Unique ( Unique )
57 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
58 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
59 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
64 tcClassDecl1 rec_inst_mapper
65 (ClassDecl context class_name
66 tyvar_name class_sigs def_methods pragmas src_loc)
67 = tcAddSrcLoc src_loc $
68 tcAddErrCtxt (classDeclCtxt class_name) $
70 -- LOOK THINGS UP IN THE ENVIRONMENT
71 tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) ->
72 tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
74 (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
77 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
78 unifyKind class_kind tyvar_kind `thenTc_`
81 tcClassContext rec_class rec_tyvar context pragmas
82 `thenTc` \ (scs, sc_sel_ids) ->
84 -- CHECK THE CLASS SIGNATURES,
85 mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
86 `thenTc` \ sig_stuff ->
88 -- MAKE THE CLASS OBJECT ITSELF
89 tcGetUnique `thenNF_Tc` \ uniq ->
91 (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
92 clas = mkClass uniq (getNameFullName class_name) rec_tyvar
93 scs sc_sel_ids ops op_sel_ids defm_ids
101 tcClassContext :: Class -> TyVar
102 -> RenamedContext -- class context
103 -> RenamedClassPragmas -- pragmas for superclasses
104 -> TcM s ([Class], -- the superclasses
105 [Id]) -- superclass selector Ids
107 tcClassContext rec_class rec_tyvar context pragmas
108 = -- Check the context.
109 -- The renamer has already checked that the context mentions
110 -- only the type variable of the class decl.
111 tcContext context `thenTc` \ theta ->
113 super_classes = [ supers | (supers, _) <- theta ]
116 -- Make super-class selector ids
117 mapTc (mk_super_id rec_class)
118 (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
121 returnTc (super_classes, sc_sel_ids)
124 mk_super_id rec_class (super_class, maybe_pragma)
125 = fixTc ( \ rec_super_id ->
126 tcGetUnique `thenNF_Tc` \ uniq ->
128 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
129 (case maybe_pragma of
130 Nothing -> returnNF_Tc noIdInfo
131 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
132 ) `thenNF_Tc` \ id_info ->
134 ty = mkForAllTy rec_tyvar (
135 mkFunTy (mkDictTy rec_class (mkTyVarTy rec_tyvar))
136 (mkDictTy super_class (mkTyVarTy rec_tyvar))
139 -- BUILD THE SUPERCLASS ID
140 returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
143 maybe_pragmas :: [Maybe RenamedGenPragmas]
144 maybe_pragmas = case pragmas of
145 NoClassPragmas -> repeat Nothing
146 SuperDictPragmas prags -> ASSERT(length prags == length context)
148 -- If there are any pragmas there should
149 -- be one for each superclass
153 tcClassSig :: Class -- Knot tying only!
154 -> TyVar -- The class type variable, used for error check only
155 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
157 -> TcM s (ClassOp, -- class op
159 Id) -- default-method ids
161 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
163 (HsForAllTy tyvar_names context monotype)
165 = tcAddSrcLoc src_loc $
166 fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
168 -- Check the type signature. NB that the envt *already has*
169 -- bindings for the type variables; see comments in TcTyAndClassDcls.
170 tcContext context `thenTc` \ theta ->
171 tcMonoType monotype `thenTc` \ tau ->
172 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (_,tyvars) ->
174 full_tyvars = rec_clas_tyvar : tyvars
175 full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
176 global_ty = mkSigmaTy full_tyvars full_theta tau
177 local_ty = mkSigmaTy tyvars theta tau
178 class_op = mkClassOp (getOccurrenceName op_name)
179 (getTagFromClassOpName op_name)
186 rec_sel_id rec_defm_id
187 (rec_classop_spec_fn class_op)
188 pragmas `thenNF_Tc` \ (op_info, defm_info) ->
190 -- Build the selector id and default method id
191 tcGetUnique `thenNF_Tc` \ d_uniq ->
193 op_uniq = getItsUnique op_name
194 sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
195 defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
196 -- ToDo: improve the "False"
198 returnTc (class_op, sel_id, defm_id)
203 %************************************************************************
205 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
207 %************************************************************************
209 The purpose of pass 2 is
212 to beat on the explicitly-provided default-method decls (if any),
213 using them to produce a complete set of default-method decls.
214 (Omitted ones elicit an error message.)
216 to produce a definition for the selector function for each method
217 and superclass dictionary.
220 Pass~2 only applies to locally-defined class declarations.
222 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
223 each local class decl.
226 tcClassDecls2 :: Bag RenamedClassDecl
227 -> NF_TcM s (LIE s, TcHsBinds s)
232 (returnNF_Tc (emptyLIE, EmptyBinds))
235 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
236 tc2 `thenNF_Tc` \ (lie2, binds2) ->
237 returnNF_Tc (lie1 `plusLIE` lie2,
238 binds1 `ThenBinds` binds2)
241 @tcClassDecl2@ is the business end of things.
244 tcClassDecl2 :: RenamedClassDecl -- The class declaration
245 -> NF_TcM s (LIE s, TcHsBinds s)
247 tcClassDecl2 (ClassDecl context class_name
248 tyvar_name class_sigs default_binds pragmas src_loc)
249 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
250 tcAddSrcLoc src_loc $
252 -- Get the relevant class
253 tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
255 (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
256 = getClassBigSig clas
258 tcInstTyVar tyvar `thenNF_Tc` \ clas_tyvar ->
260 -- Generate bindings for the selector functions
261 buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
262 `thenNF_Tc` \ sel_binds ->
263 -- Ditto for the methods
264 buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
265 `thenTc` \ (const_insts, meth_binds) ->
267 returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
270 %************************************************************************
272 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
274 %************************************************************************
277 buildSelectors :: Class -- The class object
278 -> TcTyVar s -- Class type variable
279 -> [Class] -> [Id] -- Superclasses and selectors
280 -> [ClassOp] -> [Id] -- Class ops and selectors
281 -> NF_TcM s (TcHsBinds s)
283 buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
285 -- Make new Ids for the components of the dictionary
286 mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys ->
288 newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
290 newDicts ClassDeclOrigin
291 [ (super_clas, mkTyVarTy clas_tyvar)
292 | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
294 newDicts ClassDeclOrigin
295 [ (clas, mkTyVarTy clas_tyvar) ] `thenNF_Tc` \ (_,[clas_dict]) ->
297 -- Make suitable bindings for the selectors
299 mk_sel sel_id method_or_dict
300 = mkSelBind sel_id clas_tyvar clas_dict dict_ids method_ids method_or_dict
302 listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
303 listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
305 returnNF_Tc (SingleBind (
308 (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
313 %************************************************************************
315 \subsection[ClassDcl-misc]{Miscellaneous}
317 %************************************************************************
319 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
320 consisting of @dicts@ and @methods@.
322 We have to do a bit of jiggery pokery to get the type variables right.
323 Suppose we have the class decl:
326 op1 :: Ord b => a -> b -> a
329 Then the method selector for \tr{op1} is like this:
331 op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
332 (op1_method,op2_method) -> op1_method b dOrd
334 Note that the type variable for \tr{b} and the (Ord b) dictionary
335 are lifted to the top lambda, and
336 \tr{op1_method} is applied to them. This is preferable to the alternative:
338 op1_sel' = /\a -> \dFoo -> case dFoo of
339 (op1_method,op2_method) -> op1_method
341 because \tr{op1_sel'} then has the rather strange type
343 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
345 whereas \tr{op1_sel} (the one we use) has the decent type
347 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
350 NOTE that we return a TcMonoBinds (which is later zonked) even though
351 there's no real back-substitution to do. It's just simpler this way!
353 NOTE ALSO that the selector has no free type variables, so we
354 don't bother to instantiate the class-op's local type; instead
355 we just use the variables inside it.
358 mkSelBind :: Id -- the selector id
359 -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
360 -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
361 -> TcIdOcc s -- the superclass/method being slected
362 -> NF_TcM s (TcMonoBinds s)
364 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
366 (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
367 op_tys = mkTyVarTys op_tyvars
369 newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
371 -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
373 -- <dicts..methods> -> method_or_dict op_tyvars op_dicts
375 returnNF_Tc (VarMonoBind (RealId sel_id) (
376 TyLam (clas_tyvar:op_tyvars) (
377 DictLam (clas_dict:op_dicts) (
380 ([PatMatch (DictPat dicts methods) (
381 GRHSMatch (GRHSsAndBindsOut
383 (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
392 %************************************************************************
394 \subsection[Default methods]{Default methods}
396 %************************************************************************
398 The default methods for a class are each passed a dictionary for the
399 class, so that they get access to the other methods at the same type.
400 So, given the class decl
404 op2 :: Ord b => a -> b -> b -> b
407 op2 x y z = if (op1 x) && (y < z) then y else z
409 we get the default methods:
411 defm.Foo.op1 :: forall a. Foo a => a -> Bool
412 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
414 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
415 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
416 if (op1 a dfoo x) && (< b dord y z) then y else z
418 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
420 When we come across an instance decl, we may need to use the default
423 instance Foo Int where {}
427 const.Foo.Int.op1 :: Int -> Bool
428 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
430 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
431 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
433 dfun.Foo.Int :: Foo Int
434 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
436 Notice that, as with method selectors above, we assume that dictionary
437 application is curried, so there's no need to mention the Ord dictionary
440 instance Foo a => Foo [a] where {}
442 dfun.Foo.List :: forall a. Foo a -> Foo [a]
444 = /\ a -> \ dfoo_a ->
446 op1 = defm.Foo.op1 [a] dfoo_list
447 op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
448 dfoo_list = (op1, op2)
454 buildDefaultMethodBinds
459 -> TcM s (LIE s, TcHsBinds s)
461 buildDefaultMethodBinds clas clas_tyvar
462 default_method_ids default_binds
463 = -- Deal with the method declarations themselves
464 mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids ->
466 (makeClassDeclDefaultMethodRhs clas default_method_ids)
467 [] -- No tyvars in scope for "this inst decl"
468 emptyLIE -- No insts available
469 (map TcId tc_defm_ids)
470 default_binds `thenTc` \ (dicts_needed, default_binds') ->
472 returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
475 @makeClassDeclDefaultMethodRhs@ builds the default method for a
476 class declaration when no explicit default method is given.
479 makeClassDeclDefaultMethodRhs
483 -> NF_TcM s (TcExpr s)
485 makeClassDeclDefaultMethodRhs clas method_ids tag
486 = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
488 returnNF_Tc (mkHsTyLam tyvars (
489 mkHsDictLam dict_ids (
490 HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
491 (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
493 (clas_mod, clas_name) = getOrigName clas
495 method_id = method_ids !! (tag-1)
496 class_op = (getClassOps clas) !! (tag-1)
498 error_msg = "%D" -- => No default method for \"
499 ++ unencoded_part_of_msg
501 unencoded_part_of_msg = escErrorMsg (
502 _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
503 ++ (ppShow 80 (ppr PprForUser class_op))
511 classDeclCtxt class_name sty
512 = ppCat [ppStr "In the class declaration for", ppr sty class_name]