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 ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
14 Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
15 HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
16 Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
17 import HsPragmas ( ClassPragmas(..) )
18 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
19 RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
20 RenamedGenPragmas(..), RenamedContext(..),
21 RnName{-instance Uniquable-}
23 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
24 mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
26 import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
27 import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
28 import TcInstDcls ( processInstBinds )
29 import TcKind ( unifyKind, TcKind )
30 import TcMonad hiding ( rnMtoTcM )
31 import TcMonoType ( tcPolyType, tcMonoType, tcContext )
32 import TcSimplify ( tcSimplifyAndCheck )
33 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
35 import Bag ( foldBag, unionManyBags )
36 import Class ( GenClass, mkClass, mkClassOp, classBigSig,
37 classOps, classOpString, classOpLocalType,
38 classOpTagByString, SYN_IE(ClassOp)
40 import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
43 import Name ( isLocallyDefined, origName, getLocalName )
44 import PrelVals ( nO_DEFAULT_METHOD_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 ( unitTyVarSet, GenTyVar )
54 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 `addInfo` spec,
68 Every class implicitly declares a new data type, corresponding to dictionaries
69 of that class. So, for example:
71 class (D a) => C a where
73 op2 :: forall b. Ord b => a -> b -> b
75 would implicitly declare
77 data CDict a = CDict (D a)
79 (forall b. Ord b => a -> b -> b)
81 (We could use a record decl, but that means changing more of the existing apparatus.
84 For classes with just one superclass+method, we use a newtype decl instead:
87 op :: forallb. a -> b -> b
91 newtype CDict a = CDict (forall b. a -> b -> b)
93 Now DictTy in Type is just a form of type synomym:
94 DictTy c t = TyConTy CDict `AppTy` t
96 Death to "ExpandingDicts".
100 tcClassDecl1 rec_inst_mapper
101 (ClassDecl context class_name
102 tyvar_name class_sigs def_methods pragmas src_loc)
103 = tcAddSrcLoc src_loc $
104 tcAddErrCtxt (classDeclCtxt class_name) $
106 -- LOOK THINGS UP IN THE ENVIRONMENT
107 tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) ->
108 tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
110 (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
113 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
114 unifyKind class_kind tyvar_kind `thenTc_`
117 tcClassContext rec_class rec_tyvar context pragmas
118 `thenTc` \ (scs, sc_sel_ids) ->
120 -- CHECK THE CLASS SIGNATURES,
121 mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
122 `thenTc` \ sig_stuff ->
124 -- MAKE THE CLASS OBJECT ITSELF
126 (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
127 clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
128 scs sc_sel_ids ops op_sel_ids defm_ids
136 clas_ty = mkTyVarTy clas_tyvar
137 dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
138 [classOpLocalType op | op <- ops])
139 new_or_data = case dict_component_tys of
143 dict_con_id = mkDataCon class_name
145 [{- No labelled fields -}]
151 tycon = mkDataTyCon class_name
152 (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
154 [{- Empty context -}]
156 [{- No derived classes -}]
162 tcClassContext :: Class -> TyVar
163 -> RenamedContext -- class context
164 -> RenamedClassPragmas -- pragmas for superclasses
165 -> TcM s ([Class], -- the superclasses
166 [Id]) -- superclass selector Ids
168 tcClassContext rec_class rec_tyvar context pragmas
169 = -- Check the context.
170 -- The renamer has already checked that the context mentions
171 -- only the type variable of the class decl.
172 tcContext context `thenTc` \ theta ->
174 super_classes = [ supers | (supers, _) <- theta ]
177 -- Make super-class selector ids
178 mapTc (mk_super_id rec_class)
179 (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
180 -- NB: we worry about matching list lengths below
183 returnTc (super_classes, sc_sel_ids)
186 mk_super_id rec_class (super_class, maybe_pragma)
187 = fixTc ( \ rec_super_id ->
188 tcGetUnique `thenNF_Tc` \ uniq ->
190 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
191 (case maybe_pragma of
192 Nothing -> returnNF_Tc noIdInfo
193 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
194 ) `thenNF_Tc` \ id_info ->
196 rec_tyvar_ty = mkTyVarTy rec_tyvar
197 ty = mkForAllTy rec_tyvar $
198 mkFunTy (mkDictTy rec_class rec_tyvar_ty)
199 (mkDictTy super_class rec_tyvar_ty)
201 -- BUILD THE SUPERCLASS ID
202 returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
205 maybe_pragmas :: [Maybe RenamedGenPragmas]
206 maybe_pragmas = case pragmas of
207 NoClassPragmas -> repeat Nothing
208 SuperDictPragmas prags -> ASSERT(length prags == length context)
210 -- If there are any pragmas there should
211 -- be one for each superclass
215 tcClassSig :: Class -- Knot tying only!
216 -> TyVar -- The class type variable, used for error check only
217 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
219 -> TcM s (ClassOp, -- class op
221 Id) -- default-method ids
223 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
227 = tcAddSrcLoc src_loc $
228 fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
230 -- Check the type signature. NB that the envt *already has*
231 -- bindings for the type variables; see comments in TcTyAndClassDcls.
233 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
234 -- and that it is not constrained by theta
235 tcPolyType op_ty `thenTc` \ local_ty ->
237 global_ty = mkSigmaTy [rec_clas_tyvar]
238 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
240 class_op_nm = getLocalName op_name
241 class_op = mkClassOp class_op_nm
242 (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
249 rec_sel_id rec_defm_id
250 (rec_classop_spec_fn class_op)
251 pragmas `thenNF_Tc` \ (op_info, defm_info) ->
253 -- Build the selector id and default method id
254 tcGetUnique `thenNF_Tc` \ d_uniq ->
256 op_uniq = uniqueOf op_name
257 sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
258 defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
259 -- ToDo: improve the "False"
261 returnTc (class_op, sel_id, defm_id)
266 %************************************************************************
268 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
270 %************************************************************************
272 The purpose of pass 2 is
275 to beat on the explicitly-provided default-method decls (if any),
276 using them to produce a complete set of default-method decls.
277 (Omitted ones elicit an error message.)
279 to produce a definition for the selector function for each method
280 and superclass dictionary.
283 Pass~2 only applies to locally-defined class declarations.
285 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
286 each local class decl.
289 tcClassDecls2 :: Bag RenamedClassDecl
290 -> NF_TcM s (LIE s, TcHsBinds s)
295 (returnNF_Tc (emptyLIE, EmptyBinds))
298 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
299 tc2 `thenNF_Tc` \ (lie2, binds2) ->
300 returnNF_Tc (lie1 `plusLIE` lie2,
301 binds1 `ThenBinds` binds2)
304 @tcClassDecl2@ is the business end of things.
307 tcClassDecl2 :: RenamedClassDecl -- The class declaration
308 -> NF_TcM s (LIE s, TcHsBinds s)
310 tcClassDecl2 (ClassDecl context class_name
311 tyvar_name class_sigs default_binds pragmas src_loc)
313 | not (isLocallyDefined class_name)
314 = returnNF_Tc (emptyLIE, EmptyBinds)
316 | otherwise -- It is locally defined
317 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
318 tcAddSrcLoc src_loc $
320 -- Get the relevant class
321 tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
323 (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
326 tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
328 -- Generate bindings for the selector functions
329 buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
330 `thenNF_Tc` \ sel_binds ->
331 -- Ditto for the methods
332 buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
333 `thenTc` \ (const_insts, meth_binds) ->
335 returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
338 %************************************************************************
340 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
342 %************************************************************************
345 buildSelectors :: Class -- The class object
346 -> TyVar -- Class type variable
347 -> TcTyVar s -- Instantiated class type variable (TyVarTy)
348 -> [Class] -> [Id] -- Superclasses and selectors
349 -> [ClassOp] -> [Id] -- Class ops and selectors
350 -> NF_TcM s (TcHsBinds s)
352 buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
354 -- Make new Ids for the components of the dictionary
356 clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
357 mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
359 mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
360 newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids ->
362 newDicts ClassDeclOrigin
363 [ (super_clas, clas_tyvar_ty)
364 | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
366 newDicts ClassDeclOrigin
367 [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
369 -- Make suitable bindings for the selectors
371 mk_sel sel_id method_or_dict
372 = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
374 listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
375 listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
377 returnNF_Tc (SingleBind (
380 (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
385 %************************************************************************
387 \subsection[ClassDcl-misc]{Miscellaneous}
389 %************************************************************************
391 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
392 consisting of @dicts@ and @methods@.
394 ====================== OLD ============================
395 We have to do a bit of jiggery pokery to get the type variables right.
396 Suppose we have the class decl:
399 op1 :: Ord b => a -> b -> a
402 Then the method selector for \tr{op1} is like this:
404 op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
405 (op1_method,op2_method) -> op1_method b dOrd
407 Note that the type variable for \tr{b} and the (Ord b) dictionary
408 are lifted to the top lambda, and
409 \tr{op1_method} is applied to them. This is preferable to the alternative:
411 op1_sel' = /\a -> \dFoo -> case dFoo of
412 (op1_method,op2_method) -> op1_method
414 because \tr{op1_sel'} then has the rather strange type
416 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
418 whereas \tr{op1_sel} (the one we use) has the decent type
420 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
422 ========================= END OF OLD ===========================
424 NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and
425 the rest of the compiler darn well ought to cope.
429 NOTE that we return a TcMonoBinds (which is later zonked) even though
430 there's no real back-substitution to do. It's just simpler this way!
432 NOTE ALSO that the selector has no free type variables, so we
433 don't bother to instantiate the class-op's local type; instead
434 we just use the variables inside it.
437 mkSelBind :: Id -- the selector id
438 -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
439 -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
440 -> TcIdOcc s -- the superclass/method being slected
441 -> NF_TcM s (TcMonoBinds s)
443 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
445 -- sel_id = /\ clas_tyvar -> \ clas_dict ->
447 -- <dicts..methods> -> method_or_dict
449 returnNF_Tc (VarMonoBind (RealId sel_id) (
451 DictLam [clas_dict] (
454 ([PatMatch (DictPat dicts methods) (
455 GRHSMatch (GRHSsAndBindsOut
457 (HsVar method_or_dict)
466 %************************************************************************
468 \subsection[Default methods]{Default methods}
470 %************************************************************************
472 The default methods for a class are each passed a dictionary for the
473 class, so that they get access to the other methods at the same type.
474 So, given the class decl
478 op2 :: Ord b => a -> b -> b -> b
481 op2 x y z = if (op1 x) && (y < z) then y else z
483 we get the default methods:
485 defm.Foo.op1 :: forall a. Foo a => a -> Bool
486 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
488 ====================== OLD ==================
490 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
491 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
492 if (op1 a dfoo x) && (< b dord y z) then y else z
494 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
495 ====================== END OF OLD ===================
499 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
500 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
501 if (op1 a dfoo x) && (< b dord y z) then y else z
505 When we come across an instance decl, we may need to use the default
508 instance Foo Int where {}
512 const.Foo.Int.op1 :: Int -> Bool
513 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
515 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
516 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
518 dfun.Foo.Int :: Foo Int
519 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
521 Notice that, as with method selectors above, we assume that dictionary
522 application is curried, so there's no need to mention the Ord dictionary
523 in const.Foo.Int.op2 (or the type variable).
526 instance Foo a => Foo [a] where {}
528 dfun.Foo.List :: forall a. Foo a -> Foo [a]
530 = /\ a -> \ dfoo_a ->
532 op1 = defm.Foo.op1 [a] dfoo_list
533 op2 = defm.Foo.op2 [a] dfoo_list
534 dfoo_list = (op1, op2)
540 buildDefaultMethodBinds
545 -> TcM s (LIE s, TcHsBinds s)
547 buildDefaultMethodBinds clas clas_tyvar
548 default_method_ids default_binds
549 = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
550 mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
552 avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available
553 clas_tyvar_set = unitTyVarSet clas_tyvar
555 tcExtendGlobalTyVars clas_tyvar_set (
558 (makeClassDeclDefaultMethodRhs clas local_defm_ids)
562 ) `thenTc` \ (insts_needed, default_binds') ->
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 = newMethod origin (RealId defm_id) [inst_ty]
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 (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" 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]