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, tcIdType )
28 import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
29 import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
30 import TcInstDcls ( processInstBinds, newMethodId )
31 import TcKind ( TcKind )
32 import TcKind ( unifyKind )
33 import TcMonad hiding ( rnMtoTcM )
34 import TcMonoType ( tcPolyType, tcMonoType, tcContext )
35 import TcSimplify ( tcSimplifyAndCheck )
36 import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType )
38 import Bag ( foldBag, unionManyBags )
39 import Class ( GenClass, mkClass, mkClassOp, classBigSig,
40 classOps, classOpString, classOpLocalType,
43 import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
45 import IdInfo ( noIdInfo )
46 import Name ( isLocallyDefined, moduleNamePair, getLocalName )
47 import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
50 import PprType ( GenType, GenTyVar, GenClassOp )
51 import SpecEnv ( SpecEnv(..) )
52 import SrcLoc ( mkGeneratedSrcLoc )
53 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
54 mkForAllTy, mkSigmaTy, splitSigmaTy)
55 import TysWiredIn ( stringTy )
56 import TyVar ( mkTyVarSet, GenTyVar )
57 import Unique ( Unique )
61 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
62 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
63 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
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 `thenNF_Tc` \ (class_kind, rec_class) ->
110 tcLookupTyVar 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)
181 (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
182 -- NB: we worry about matching list lengths below
185 returnTc (super_classes, sc_sel_ids)
188 mk_super_id rec_class (super_class, maybe_pragma)
189 = fixTc ( \ rec_super_id ->
190 tcGetUnique `thenNF_Tc` \ uniq ->
192 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
193 (case maybe_pragma of
194 Nothing -> returnNF_Tc noIdInfo
195 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
196 ) `thenNF_Tc` \ id_info ->
198 rec_tyvar_ty = mkTyVarTy rec_tyvar
199 ty = mkForAllTy rec_tyvar $
200 mkFunTy (mkDictTy rec_class rec_tyvar_ty)
201 (mkDictTy super_class rec_tyvar_ty)
203 -- BUILD THE SUPERCLASS ID
204 returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
207 maybe_pragmas :: [Maybe RenamedGenPragmas]
208 maybe_pragmas = case pragmas of
209 NoClassPragmas -> repeat Nothing
210 SuperDictPragmas prags -> ASSERT(length prags == length context)
212 -- If there are any pragmas there should
213 -- be one for each superclass
217 tcClassSig :: Class -- Knot tying only!
218 -> TyVar -- The class type variable, used for error check only
219 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
221 -> TcM s (ClassOp, -- class op
223 Id) -- default-method ids
225 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
229 = tcAddSrcLoc src_loc $
230 fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
232 -- Check the type signature. NB that the envt *already has*
233 -- bindings for the type variables; see comments in TcTyAndClassDcls.
235 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
236 -- and that it is not constrained by theta
237 tcPolyType op_ty `thenTc` \ local_ty ->
239 global_ty = mkSigmaTy [rec_clas_tyvar]
240 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
242 class_op_nm = getLocalName op_name
243 class_op = mkClassOp class_op_nm
244 (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
251 rec_sel_id rec_defm_id
252 (rec_classop_spec_fn class_op)
253 pragmas `thenNF_Tc` \ (op_info, defm_info) ->
255 -- Build the selector id and default method id
256 tcGetUnique `thenNF_Tc` \ d_uniq ->
258 op_uniq = uniqueOf op_name
259 sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
260 defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
261 -- ToDo: improve the "False"
263 returnTc (class_op, sel_id, defm_id)
268 %************************************************************************
270 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
272 %************************************************************************
274 The purpose of pass 2 is
277 to beat on the explicitly-provided default-method decls (if any),
278 using them to produce a complete set of default-method decls.
279 (Omitted ones elicit an error message.)
281 to produce a definition for the selector function for each method
282 and superclass dictionary.
285 Pass~2 only applies to locally-defined class declarations.
287 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
288 each local class decl.
291 tcClassDecls2 :: Bag RenamedClassDecl
292 -> NF_TcM s (LIE s, TcHsBinds s)
297 (returnNF_Tc (emptyLIE, EmptyBinds))
300 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
301 tc2 `thenNF_Tc` \ (lie2, binds2) ->
302 returnNF_Tc (lie1 `plusLIE` lie2,
303 binds1 `ThenBinds` binds2)
306 @tcClassDecl2@ is the business end of things.
309 tcClassDecl2 :: RenamedClassDecl -- The class declaration
310 -> NF_TcM s (LIE s, TcHsBinds s)
312 tcClassDecl2 (ClassDecl context class_name
313 tyvar_name class_sigs default_binds pragmas src_loc)
315 | not (isLocallyDefined class_name)
316 = returnNF_Tc (emptyLIE, EmptyBinds)
318 | otherwise -- It is locally defined
319 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
320 tcAddSrcLoc src_loc $
322 -- Get the relevant class
323 tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
325 (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
328 tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
330 -- Generate bindings for the selector functions
331 buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
332 `thenNF_Tc` \ sel_binds ->
333 -- Ditto for the methods
334 buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
335 `thenTc` \ (const_insts, meth_binds) ->
337 returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
340 %************************************************************************
342 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
344 %************************************************************************
347 buildSelectors :: Class -- The class object
348 -> TyVar -- Class type variable
349 -> TcTyVar s -- Instantiated class type variable (TyVarTy)
350 -> [Class] -> [Id] -- Superclasses and selectors
351 -> [ClassOp] -> [Id] -- Class ops and selectors
352 -> NF_TcM s (TcHsBinds s)
354 buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
356 -- Make new Ids for the components of the dictionary
358 clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
359 mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
361 mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
362 newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids ->
364 newDicts ClassDeclOrigin
365 [ (super_clas, clas_tyvar_ty)
366 | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
368 newDicts ClassDeclOrigin
369 [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
371 -- Make suitable bindings for the selectors
373 mk_sel sel_id method_or_dict
374 = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
376 listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
377 listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
379 returnNF_Tc (SingleBind (
382 (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
387 %************************************************************************
389 \subsection[ClassDcl-misc]{Miscellaneous}
391 %************************************************************************
393 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
394 consisting of @dicts@ and @methods@.
396 ====================== OLD ============================
397 We have to do a bit of jiggery pokery to get the type variables right.
398 Suppose we have the class decl:
401 op1 :: Ord b => a -> b -> a
404 Then the method selector for \tr{op1} is like this:
406 op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
407 (op1_method,op2_method) -> op1_method b dOrd
409 Note that the type variable for \tr{b} and the (Ord b) dictionary
410 are lifted to the top lambda, and
411 \tr{op1_method} is applied to them. This is preferable to the alternative:
413 op1_sel' = /\a -> \dFoo -> case dFoo of
414 (op1_method,op2_method) -> op1_method
416 because \tr{op1_sel'} then has the rather strange type
418 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
420 whereas \tr{op1_sel} (the one we use) has the decent type
422 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
424 ========================= END OF OLD ===========================
426 NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and
427 the rest of the compiler darn well ought to cope.
431 NOTE that we return a TcMonoBinds (which is later zonked) even though
432 there's no real back-substitution to do. It's just simpler this way!
434 NOTE ALSO that the selector has no free type variables, so we
435 don't bother to instantiate the class-op's local type; instead
436 we just use the variables inside it.
439 mkSelBind :: Id -- the selector id
440 -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
441 -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
442 -> TcIdOcc s -- the superclass/method being slected
443 -> NF_TcM s (TcMonoBinds s)
445 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
447 -- sel_id = /\ clas_tyvar -> \ clas_dict ->
449 -- <dicts..methods> -> method_or_dict
451 returnNF_Tc (VarMonoBind (RealId sel_id) (
453 DictLam [clas_dict] (
456 ([PatMatch (DictPat dicts methods) (
457 GRHSMatch (GRHSsAndBindsOut
459 (HsVar method_or_dict)
468 %************************************************************************
470 \subsection[Default methods]{Default methods}
472 %************************************************************************
474 The default methods for a class are each passed a dictionary for the
475 class, so that they get access to the other methods at the same type.
476 So, given the class decl
480 op2 :: Ord b => a -> b -> b -> b
483 op2 x y z = if (op1 x) && (y < z) then y else z
485 we get the default methods:
487 defm.Foo.op1 :: forall a. Foo a => a -> Bool
488 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
490 ====================== OLD ==================
492 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
493 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
494 if (op1 a dfoo x) && (< b dord y z) then y else z
496 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
497 ====================== END OF OLD ===================
501 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
502 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
503 if (op1 a dfoo x) && (< b dord y z) then y else z
507 When we come across an instance decl, we may need to use the default
510 instance Foo Int where {}
514 const.Foo.Int.op1 :: Int -> Bool
515 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
517 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
518 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
520 dfun.Foo.Int :: Foo Int
521 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
523 Notice that, as with method selectors above, we assume that dictionary
524 application is curried, so there's no need to mention the Ord dictionary
525 in const.Foo.Int.op2 (or the type variable).
528 instance Foo a => Foo [a] where {}
530 dfun.Foo.List :: forall a. Foo a -> Foo [a]
532 = /\ a -> \ dfoo_a ->
534 op1 = defm.Foo.op1 [a] dfoo_list
535 op2 = defm.Foo.op2 [a] dfoo_list
536 dfoo_list = (op1, op2)
542 buildDefaultMethodBinds
547 -> TcM s (LIE s, TcHsBinds s)
549 buildDefaultMethodBinds clas clas_tyvar
550 default_method_ids default_binds
551 = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
552 mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
554 avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available
558 (makeClassDeclDefaultMethodRhs clas local_defm_ids)
559 [clas_tyvar] -- Tyvars in scope
562 default_binds `thenTc` \ (insts_needed, default_binds') ->
565 (mkTyVarSet [clas_tyvar])
567 insts_needed `thenTc` \ (const_lie, dict_binds) ->
571 defm_binds = AbsBinds
574 (local_defm_ids `zip` map RealId default_method_ids)
576 (RecBind default_binds')
578 returnTc (const_lie, defm_binds)
580 inst_ty = mkTyVarTy clas_tyvar
581 mk_method defm_id = newMethodId defm_id inst_ty origin
582 origin = ClassDeclOrigin
585 @makeClassDeclDefaultMethodRhs@ builds the default method for a
586 class declaration when no explicit default method is given.
589 makeClassDeclDefaultMethodRhs
593 -> NF_TcM s (TcExpr s)
595 makeClassDeclDefaultMethodRhs clas method_ids tag
596 = -- Return the expression
597 -- error ty "No default method for ..."
598 -- The interesting thing is that method_ty is a for-all type;
599 -- this is fun, although unusual in a type application!
601 returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
602 (HsLitOut (HsString (_PK_ error_msg)) stringTy))
604 {- OLD AND COMPLICATED
605 tcInstSigType () `thenNF_Tc` \ method_ty ->
607 (tyvars, theta, tau) = splitSigmaTy method_ty
609 newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) ->
611 returnNF_Tc (mkHsTyLam tyvars (
612 mkHsDictLam dict_ids (
613 HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
614 (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
618 (clas_mod, clas_name) = moduleNamePair clas
620 method_id = method_ids !! (tag-1)
621 class_op = (classOps clas) !! (tag-1)
623 error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
624 ++ (ppShow 80 (ppr PprForUser class_op))
632 classDeclCtxt class_name sty
633 = ppCat [ppStr "In the class declaration for", ppr sty class_name]