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 RnName{-instance Uniquable-}
25 import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
26 mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
29 import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
30 import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
31 import TcInstDcls ( processInstBinds )
32 import TcKind ( unifyKind )
33 import TcMonoType ( tcMonoType, tcContext )
34 import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars )
35 import TcKind ( TcKind )
37 import Bag ( foldBag )
38 import Class ( GenClass, mkClass, mkClassOp, getClassBigSig,
39 getClassOps, getClassOpString, getClassOpLocalType )
40 import CoreUtils ( escErrorMsg )
41 import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
43 import IdInfo ( noIdInfo )
44 import Name ( isLocallyDefined, moduleNamePair, getLocalName )
45 import PrelVals ( pAT_ERROR_ID )
48 import PprType ( GenType, GenTyVar, GenClassOp )
49 import SpecEnv ( SpecEnv(..) )
50 import SrcLoc ( mkGeneratedSrcLoc )
51 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
52 mkForAllTy, mkSigmaTy, splitSigmaTy)
53 import TysWiredIn ( stringTy )
54 import TyVar ( GenTyVar )
55 import Unique ( Unique )
58 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
59 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
60 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
65 tcClassDecl1 rec_inst_mapper
66 (ClassDecl context class_name
67 tyvar_name class_sigs def_methods pragmas src_loc)
68 = tcAddSrcLoc src_loc $
69 tcAddErrCtxt (classDeclCtxt class_name) $
71 -- LOOK THINGS UP IN THE ENVIRONMENT
72 tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) ->
73 tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
75 (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
78 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
79 unifyKind class_kind tyvar_kind `thenTc_`
82 tcClassContext rec_class rec_tyvar context pragmas
83 `thenTc` \ (scs, sc_sel_ids) ->
85 -- CHECK THE CLASS SIGNATURES,
86 mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
87 `thenTc` \ sig_stuff ->
89 -- MAKE THE CLASS OBJECT ITSELF
90 tcGetUnique `thenNF_Tc` \ uniq ->
92 (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
93 clas = mkClass uniq (getName class_name) rec_tyvar
94 scs sc_sel_ids ops op_sel_ids defm_ids
102 tcClassContext :: Class -> TyVar
103 -> RenamedContext -- class context
104 -> RenamedClassPragmas -- pragmas for superclasses
105 -> TcM s ([Class], -- the superclasses
106 [Id]) -- superclass selector Ids
108 tcClassContext rec_class rec_tyvar context pragmas
109 = -- Check the context.
110 -- The renamer has already checked that the context mentions
111 -- only the type variable of the class decl.
112 tcContext context `thenTc` \ theta ->
114 super_classes = [ supers | (supers, _) <- theta ]
117 -- Make super-class selector ids
118 mapTc (mk_super_id rec_class)
119 (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
122 returnTc (super_classes, sc_sel_ids)
125 mk_super_id rec_class (super_class, maybe_pragma)
126 = fixTc ( \ rec_super_id ->
127 tcGetUnique `thenNF_Tc` \ uniq ->
129 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
130 (case maybe_pragma of
131 Nothing -> returnNF_Tc noIdInfo
132 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
133 ) `thenNF_Tc` \ id_info ->
135 ty = mkForAllTy rec_tyvar (
136 mkFunTy (mkDictTy rec_class (mkTyVarTy rec_tyvar))
137 (mkDictTy super_class (mkTyVarTy rec_tyvar))
140 -- BUILD THE SUPERCLASS ID
141 returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
144 maybe_pragmas :: [Maybe RenamedGenPragmas]
145 maybe_pragmas = case pragmas of
146 NoClassPragmas -> repeat Nothing
147 SuperDictPragmas prags -> ASSERT(length prags == length context)
149 -- If there are any pragmas there should
150 -- be one for each superclass
154 tcClassSig :: Class -- Knot tying only!
155 -> TyVar -- The class type variable, used for error check only
156 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
158 -> TcM s (ClassOp, -- class op
160 Id) -- default-method ids
162 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
164 (HsForAllTy tyvar_names context monotype)
166 = tcAddSrcLoc src_loc $
167 fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
169 -- Check the type signature. NB that the envt *already has*
170 -- bindings for the type variables; see comments in TcTyAndClassDcls.
171 tcContext context `thenTc` \ theta ->
172 tcMonoType monotype `thenTc` \ tau ->
173 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (_,tyvars) ->
175 full_tyvars = rec_clas_tyvar : tyvars
176 full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
177 global_ty = mkSigmaTy full_tyvars full_theta tau
178 local_ty = mkSigmaTy tyvars theta tau
179 class_op = mkClassOp (getLocalName op_name)
180 (panic "(getTagFromClassOpName op_name)TcClassDecl"{-(getTagFromClassOpName op_name)-})
187 rec_sel_id rec_defm_id
188 (rec_classop_spec_fn class_op)
189 pragmas `thenNF_Tc` \ (op_info, defm_info) ->
191 -- Build the selector id and default method id
192 tcGetUnique `thenNF_Tc` \ d_uniq ->
194 op_uniq = uniqueOf op_name
195 sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
196 defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
197 -- ToDo: improve the "False"
199 returnTc (class_op, sel_id, defm_id)
204 %************************************************************************
206 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
208 %************************************************************************
210 The purpose of pass 2 is
213 to beat on the explicitly-provided default-method decls (if any),
214 using them to produce a complete set of default-method decls.
215 (Omitted ones elicit an error message.)
217 to produce a definition for the selector function for each method
218 and superclass dictionary.
221 Pass~2 only applies to locally-defined class declarations.
223 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
224 each local class decl.
227 tcClassDecls2 :: Bag RenamedClassDecl
228 -> NF_TcM s (LIE s, TcHsBinds s)
233 (returnNF_Tc (emptyLIE, EmptyBinds))
236 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
237 tc2 `thenNF_Tc` \ (lie2, binds2) ->
238 returnNF_Tc (lie1 `plusLIE` lie2,
239 binds1 `ThenBinds` binds2)
242 @tcClassDecl2@ is the business end of things.
245 tcClassDecl2 :: RenamedClassDecl -- The class declaration
246 -> NF_TcM s (LIE s, TcHsBinds s)
248 tcClassDecl2 (ClassDecl context class_name
249 tyvar_name class_sigs default_binds pragmas src_loc)
251 | not (isLocallyDefined class_name)
252 = returnNF_Tc (emptyLIE, EmptyBinds)
254 | otherwise -- It is locally defined
255 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
256 tcAddSrcLoc src_loc $
258 -- Get the relevant class
259 tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
261 (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
262 = getClassBigSig clas
264 tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
266 -- Generate bindings for the selector functions
267 buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
268 `thenNF_Tc` \ sel_binds ->
269 -- Ditto for the methods
270 buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
271 `thenTc` \ (const_insts, meth_binds) ->
273 returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
276 %************************************************************************
278 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
280 %************************************************************************
283 buildSelectors :: Class -- The class object
284 -> TyVar -- Class type variable
285 -> TcTyVar s -- Instantiated class type variable (TyVarTy)
286 -> [Class] -> [Id] -- Superclasses and selectors
287 -> [ClassOp] -> [Id] -- Class ops and selectors
288 -> NF_TcM s (TcHsBinds s)
290 buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
292 -- Make new Ids for the components of the dictionary
294 clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
295 mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType
297 mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
298 newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
300 newDicts ClassDeclOrigin
301 [ (super_clas, clas_tyvar_ty)
302 | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
304 newDicts ClassDeclOrigin
305 [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
307 -- Make suitable bindings for the selectors
309 mk_sel sel_id method_or_dict
310 = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
312 listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
313 listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
315 returnNF_Tc (SingleBind (
318 (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
323 %************************************************************************
325 \subsection[ClassDcl-misc]{Miscellaneous}
327 %************************************************************************
329 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
330 consisting of @dicts@ and @methods@.
332 We have to do a bit of jiggery pokery to get the type variables right.
333 Suppose we have the class decl:
336 op1 :: Ord b => a -> b -> a
339 Then the method selector for \tr{op1} is like this:
341 op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
342 (op1_method,op2_method) -> op1_method b dOrd
344 Note that the type variable for \tr{b} and the (Ord b) dictionary
345 are lifted to the top lambda, and
346 \tr{op1_method} is applied to them. This is preferable to the alternative:
348 op1_sel' = /\a -> \dFoo -> case dFoo of
349 (op1_method,op2_method) -> op1_method
351 because \tr{op1_sel'} then has the rather strange type
353 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
355 whereas \tr{op1_sel} (the one we use) has the decent type
357 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
360 NOTE that we return a TcMonoBinds (which is later zonked) even though
361 there's no real back-substitution to do. It's just simpler this way!
363 NOTE ALSO that the selector has no free type variables, so we
364 don't bother to instantiate the class-op's local type; instead
365 we just use the variables inside it.
368 mkSelBind :: Id -- the selector id
369 -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
370 -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
371 -> TcIdOcc s -- the superclass/method being slected
372 -> NF_TcM s (TcMonoBinds s)
374 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
376 (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
377 op_tys = mkTyVarTys op_tyvars
379 newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
381 -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
383 -- <dicts..methods> -> method_or_dict op_tyvars op_dicts
385 returnNF_Tc (VarMonoBind (RealId sel_id) (
386 TyLam (clas_tyvar:op_tyvars) (
387 DictLam (clas_dict:op_dicts) (
390 ([PatMatch (DictPat dicts methods) (
391 GRHSMatch (GRHSsAndBindsOut
393 (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
402 %************************************************************************
404 \subsection[Default methods]{Default methods}
406 %************************************************************************
408 The default methods for a class are each passed a dictionary for the
409 class, so that they get access to the other methods at the same type.
410 So, given the class decl
414 op2 :: Ord b => a -> b -> b -> b
417 op2 x y z = if (op1 x) && (y < z) then y else z
419 we get the default methods:
421 defm.Foo.op1 :: forall a. Foo a => a -> Bool
422 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
424 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
425 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
426 if (op1 a dfoo x) && (< b dord y z) then y else z
428 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
430 When we come across an instance decl, we may need to use the default
433 instance Foo Int where {}
437 const.Foo.Int.op1 :: Int -> Bool
438 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
440 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
441 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
443 dfun.Foo.Int :: Foo Int
444 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
446 Notice that, as with method selectors above, we assume that dictionary
447 application is curried, so there's no need to mention the Ord dictionary
450 instance Foo a => Foo [a] where {}
452 dfun.Foo.List :: forall a. Foo a -> Foo [a]
454 = /\ a -> \ dfoo_a ->
456 op1 = defm.Foo.op1 [a] dfoo_list
457 op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord
458 dfoo_list = (op1, op2)
464 buildDefaultMethodBinds
469 -> TcM s (LIE s, TcHsBinds s)
471 buildDefaultMethodBinds clas clas_tyvar
472 default_method_ids default_binds
473 = -- Deal with the method declarations themselves
474 mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids ->
476 (makeClassDeclDefaultMethodRhs clas default_method_ids)
477 [] -- No tyvars in scope for "this inst decl"
478 emptyLIE -- No insts available
479 (map TcId tc_defm_ids)
480 default_binds `thenTc` \ (dicts_needed, default_binds') ->
482 returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
485 @makeClassDeclDefaultMethodRhs@ builds the default method for a
486 class declaration when no explicit default method is given.
489 makeClassDeclDefaultMethodRhs
493 -> NF_TcM s (TcExpr s)
495 makeClassDeclDefaultMethodRhs clas method_ids tag
496 = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty ->
498 (tyvars, theta, tau) = splitSigmaTy method_ty
500 newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) ->
502 returnNF_Tc (mkHsTyLam tyvars (
503 mkHsDictLam dict_ids (
504 HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
505 (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
507 (clas_mod, clas_name) = moduleNamePair clas
509 method_id = method_ids !! (tag-1)
510 class_op = (getClassOps clas) !! (tag-1)
512 error_msg = "%D" -- => No default method for \"
513 ++ unencoded_part_of_msg
515 unencoded_part_of_msg = escErrorMsg (
516 _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
517 ++ (ppShow 80 (ppr PprForUser class_op))
525 classDeclCtxt class_name sty
526 = ppCat [ppStr "In the class declaration for", ppr sty class_name]