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, 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 tc_method_ids = map TcId method_ids
301 mk_sel sel_id method_or_dict
302 = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids method_or_dict
304 listNF_Tc (zipWithEqual mk_sel op_sel_ids tc_method_ids) `thenNF_Tc` \ op_sel_binds ->
305 listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
307 returnNF_Tc (SingleBind (
310 (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
315 %************************************************************************
317 \subsection[ClassDcl-misc]{Miscellaneous}
319 %************************************************************************
321 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
322 consisting of @dicts@ and @methods@.
324 We have to do a bit of jiggery pokery to get the type variables right.
325 Suppose we have the class decl:
328 op1 :: Ord b => a -> b -> a
331 Then the method selector for \tr{op1} is like this:
333 op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
334 (op1_method,op2_method) -> op1_method b dOrd
336 Note that the type variable for \tr{b} and the (Ord b) dictionary
337 are lifted to the top lambda, and
338 \tr{op1_method} is applied to them. This is preferable to the alternative:
340 op1_sel' = /\a -> \dFoo -> case dFoo of
341 (op1_method,op2_method) -> op1_method
343 because \tr{op1_sel'} then has the rather strange type
345 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
347 whereas \tr{op1_sel} (the one we use) has the decent type
349 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
352 NOTE that we return a TcMonoBinds (which is later zonked) even though
353 there's no real back-substitution to do. It's just simpler this way!
355 NOTE ALSO that the selector has no free type variables, so we
356 don't bother to instantiate the class-op's local type; instead
357 we just use the variables inside it.
360 mkSelBind :: Id -- the selector id
361 -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
362 -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
363 -> TcIdOcc s -- the superclass/method being slected
364 -> NF_TcM s (TcMonoBinds s)
366 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
368 (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
369 op_tys = map mkTyVarTy op_tyvars
371 newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
373 -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
375 -- <dicts..methods> -> method_or_dict op_tyvars op_dicts
377 returnNF_Tc (VarMonoBind (RealId sel_id) (
378 TyLam (clas_tyvar:op_tyvars) (
379 DictLam (clas_dict:op_dicts) (
382 ([PatMatch (DictPat dicts methods) (
383 GRHSMatch (GRHSsAndBindsOut
385 (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
394 %************************************************************************
396 \subsection[Default methods]{Default methods}
398 %************************************************************************
400 The default methods for a class are each passed a dictionary for the
401 class, so that they get access to the other methods at the same type.
402 So, given the class decl
406 op2 :: Ord b => a -> b -> b -> b
409 op2 x y z = if (op1 x) && (y < z) then y else z
411 we get the default methods:
413 defm.Foo.op1 :: forall a. Foo a => a -> Bool
414 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
416 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
417 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
418 if (op1 a dfoo x) && (< b dord y z) then y else z
420 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
422 When we come across an instance decl, we may need to use the default
425 instance Foo Int where {}
429 const.Foo.Int.op1 :: Int -> Bool
430 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
432 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
433 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
435 dfun.Foo.Int :: Foo Int
436 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
438 Notice that, as with method selectors above, we assume that dictionary
439 application is curried, so there's no need to mention the Ord dictionary
442 instance Foo a => Foo [a] where {}
444 dfun.Foo.List :: forall a. Foo a -> Foo [a]
446 = /\ a -> \ dfoo_a ->
448 op1 = defm.Foo.op1 [a] dfoo_list
449 op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
450 dfoo_list = (op1, op2)
456 buildDefaultMethodBinds
461 -> TcM s (LIE s, TcHsBinds s)
463 buildDefaultMethodBinds clas clas_tyvar
464 default_method_ids default_binds
465 = -- Deal with the method declarations themselves
466 mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids ->
468 (makeClassDeclDefaultMethodRhs clas default_method_ids)
469 [] -- No tyvars in scope for "this inst decl"
470 emptyLIE -- No insts available
471 (map TcId tc_defm_ids)
472 default_binds `thenTc` \ (dicts_needed, default_binds') ->
474 returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
477 @makeClassDeclDefaultMethodRhs@ builds the default method for a
478 class declaration when no explicit default method is given.
481 makeClassDeclDefaultMethodRhs
485 -> NF_TcM s (TcExpr s)
487 makeClassDeclDefaultMethodRhs clas method_ids tag
488 = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
490 returnNF_Tc (mkHsTyLam tyvars (
491 mkHsDictLam dict_ids (
492 HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
493 (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
495 (clas_mod, clas_name) = getOrigName clas
497 method_id = method_ids !! (tag-1)
498 class_op = (getClassOps clas) !! (tag-1)
500 error_msg = "%D" -- => No default method for \"
501 ++ unencoded_part_of_msg
503 unencoded_part_of_msg = escErrorMsg (
504 _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
505 ++ (ppShow 80 (ppr PprForUser class_op))
513 classDeclCtxt class_name sty
514 = ppCat [ppStr "In the class declaration for", ppr sty class_name]