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 ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
14 Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
15 DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
16 HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
17 SYN_IE(RecFlag), nonRecursive, andMonoBinds,
18 Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake )
19 import HsTypes ( getTyVarName )
20 import HsPragmas ( ClassPragmas(..) )
21 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
22 RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
23 RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
25 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
26 mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
28 import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
29 import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo,
30 tcExtendGlobalTyVars )
31 import TcInstDcls ( tcMethodBind )
32 import TcKind ( unifyKind, TcKind )
34 import TcMonoType ( tcHsType, tcContext )
35 import TcSimplify ( tcSimplifyAndCheck )
36 import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
37 import PragmaInfo ( PragmaInfo(..) )
39 import Bag ( foldBag, unionManyBags )
40 import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig,
41 classOps, classOpString, classOpLocalType, classDefaultMethodId,
42 classOpTagByOccName, SYN_IE(ClassOp), SYN_IE(Class)
44 import CmdLineOpts ( opt_PprUserLength )
45 import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
46 mkDefaultMethodId, getIdUnfolding,
49 import CoreUnfold ( getUnfoldingTemplate )
51 import Name ( Name, isLocallyDefined, moduleString,
52 nameString, NamedThing(..) )
54 import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
56 import PprType ( GenClass, GenType, GenTyVar, GenClassOp )
57 import SpecEnv ( SpecEnv )
58 import SrcLoc ( mkGeneratedSrcLoc )
59 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
60 mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type)
62 import TysWiredIn ( stringTy )
63 import TyVar ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
64 import Unique ( Unique, Uniquable(..) )
68 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
69 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
70 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
78 Every class implicitly declares a new data type, corresponding to dictionaries
79 of that class. So, for example:
81 class (D a) => C a where
83 op2 :: forall b. Ord b => a -> b -> b
85 would implicitly declare
87 data CDict a = CDict (D a)
89 (forall b. Ord b => a -> b -> b)
91 (We could use a record decl, but that means changing more of the existing apparatus.
94 For classes with just one superclass+method, we use a newtype decl instead:
97 op :: forallb. a -> b -> b
101 newtype CDict a = CDict (forall b. a -> b -> b)
103 Now DictTy in Type is just a form of type synomym:
104 DictTy c t = TyConTy CDict `AppTy` t
106 Death to "ExpandingDicts".
110 tcClassDecl1 rec_inst_mapper
111 (ClassDecl context class_name
112 tyvar_name class_sigs def_methods pragmas src_loc)
113 = tcAddSrcLoc src_loc $
114 tcAddErrCtxt (classDeclCtxt class_name) $
116 -- LOOK THINGS UP IN THE ENVIRONMENT
117 tcLookupClass class_name `thenTc` \ (class_kind, rec_class) ->
118 tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
120 (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
123 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
124 unifyKind class_kind tyvar_kind `thenTc_`
127 tcClassContext rec_class rec_tyvar context pragmas
128 `thenTc` \ (scs, sc_sel_ids) ->
130 -- CHECK THE CLASS SIGNATURES,
131 mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
132 `thenTc` \ sig_stuff ->
134 -- MAKE THE CLASS OBJECT ITSELF
136 (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
137 clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
138 scs sc_sel_ids ops op_sel_ids defm_ids
146 clas_ty = mkTyVarTy clas_tyvar
147 dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
148 [classOpLocalType op | op <- ops])
149 new_or_data = case dict_component_tys of
153 dict_con_id = mkDataCon class_name
155 [{- No labelled fields -}]
161 tycon = mkDataTyCon class_name
162 (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
164 [{- Empty context -}]
166 [{- No derived classes -}]
172 tcClassContext :: Class -> TyVar
173 -> RenamedContext -- class context
174 -> RenamedClassPragmas -- pragmas for superclasses
175 -> TcM s ([Class], -- the superclasses
176 [Id]) -- superclass selector Ids
178 tcClassContext rec_class rec_tyvar context pragmas
179 = -- Check the context.
180 -- The renamer has already checked that the context mentions
181 -- only the type variable of the class decl.
182 tcContext context `thenTc` \ theta ->
184 super_classes = [ supers | (supers, _) <- theta ]
187 -- Make super-class selector ids
188 mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
191 returnTc (super_classes, sc_sel_ids)
194 rec_tyvar_ty = mkTyVarTy rec_tyvar
196 mk_super_id rec_class super_class
197 = tcGetUnique `thenNF_Tc` \ uniq ->
199 ty = mkForAllTy rec_tyvar $
200 mkFunTy (mkDictTy rec_class rec_tyvar_ty)
201 (mkDictTy super_class rec_tyvar_ty)
203 returnTc (mkSuperDictSelId uniq rec_class super_class ty)
206 tcClassSig :: Class -- Knot tying only!
207 -> TyVar -- The class type variable, used for error check only
208 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
210 -> TcM s (ClassOp, -- class op
212 Id) -- default-method ids
214 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
215 (ClassOpSig op_name dm_name
218 = tcAddSrcLoc src_loc $
219 fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
221 -- Check the type signature. NB that the envt *already has*
222 -- bindings for the type variables; see comments in TcTyAndClassDcls.
224 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
225 -- and that it is not constrained by theta
226 tcHsType op_ty `thenTc` \ local_ty ->
228 global_ty = mkSigmaTy [rec_clas_tyvar]
229 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
231 class_op_nm = getOccName op_name
232 class_op = mkClassOp class_op_nm
233 (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm)
237 -- Build the selector id and default method id
239 sel_id = mkMethodSelId op_name rec_clas class_op global_ty
240 defm_id = mkDefaultMethodId dm_name rec_clas class_op False global_ty
241 -- ToDo: improve the "False"
243 tcAddImportedIdInfo defm_id `thenNF_Tc` \ final_defm_id ->
244 returnTc (class_op, sel_id, final_defm_id)
249 %************************************************************************
251 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
253 %************************************************************************
255 The purpose of pass 2 is
258 to beat on the explicitly-provided default-method decls (if any),
259 using them to produce a complete set of default-method decls.
260 (Omitted ones elicit an error message.)
262 to produce a definition for the selector function for each method
263 and superclass dictionary.
266 Pass~2 only applies to locally-defined class declarations.
268 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
269 each local class decl.
272 tcClassDecls2 :: [RenamedHsDecl]
273 -> NF_TcM s (LIE s, TcHsBinds s)
277 (returnNF_Tc (emptyLIE, EmptyBinds))
278 [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
280 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
281 tc2 `thenNF_Tc` \ (lie2, binds2) ->
282 returnNF_Tc (lie1 `plusLIE` lie2,
283 binds1 `ThenBinds` binds2)
286 @tcClassDecl2@ is the business end of things.
289 tcClassDecl2 :: RenamedClassDecl -- The class declaration
290 -> NF_TcM s (LIE s, TcHsBinds s)
292 tcClassDecl2 (ClassDecl context class_name
293 tyvar_name class_sigs default_binds pragmas src_loc)
295 | not (isLocallyDefined class_name)
296 = returnNF_Tc (emptyLIE, EmptyBinds)
298 | otherwise -- It is locally defined
299 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
300 tcAddSrcLoc src_loc $
302 -- Get the relevant class
303 tcLookupClass class_name `thenTc` \ (_, clas) ->
305 (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
308 -- The selector binds are already in the selector Id's unfoldings
309 sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
310 | sel_id <- sc_sel_ids ++ op_sel_ids,
311 isLocallyDefined sel_id
314 final_sel_binds = MonoBind (andMonoBinds sel_binds) [] nonRecursive
316 -- Generate bindings for the default methods
317 tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
318 mapAndUnzipTc (buildDefaultMethodBind clas clas_tyvar default_binds)
319 (op_sel_ids `zip` [0..])
320 `thenTc` \ (const_insts_s, meth_binds) ->
322 returnTc (unionManyBags const_insts_s,
323 final_sel_binds `ThenBinds`
324 MonoBind (andMonoBinds meth_binds) [] nonRecursive)
327 %************************************************************************
329 \subsection[Default methods]{Default methods}
331 %************************************************************************
333 The default methods for a class are each passed a dictionary for the
334 class, so that they get access to the other methods at the same type.
335 So, given the class decl
339 op2 :: Ord b => a -> b -> b -> b
342 op2 x y z = if (op1 x) && (y < z) then y else z
344 we get the default methods:
346 defm.Foo.op1 :: forall a. Foo a => a -> Bool
347 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
349 ====================== OLD ==================
351 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
352 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
353 if (op1 a dfoo x) && (< b dord y z) then y else z
355 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
356 ====================== END OF OLD ===================
360 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
361 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
362 if (op1 a dfoo x) && (< b dord y z) then y else z
366 When we come across an instance decl, we may need to use the default
369 instance Foo Int where {}
373 const.Foo.Int.op1 :: Int -> Bool
374 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
376 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
377 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
379 dfun.Foo.Int :: Foo Int
380 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
382 Notice that, as with method selectors above, we assume that dictionary
383 application is curried, so there's no need to mention the Ord dictionary
384 in const.Foo.Int.op2 (or the type variable).
387 instance Foo a => Foo [a] where {}
389 dfun.Foo.List :: forall a. Foo a -> Foo [a]
391 = /\ a -> \ dfoo_a ->
393 op1 = defm.Foo.op1 [a] dfoo_list
394 op2 = defm.Foo.op2 [a] dfoo_list
395 dfoo_list = (op1, op2)
401 buildDefaultMethodBind
406 -> TcM s (LIE s, TcMonoBinds s)
408 buildDefaultMethodBind clas clas_tyvar default_binds (sel_id, idx)
409 = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
411 avail_insts = this_dict
412 defm_id = classDefaultMethodId clas idx
413 no_prags name = NoPragmaInfo -- No pragmas yet for default methods
415 tcExtendGlobalTyVars clas_tyvar_set (
416 tcMethodBind noDefmExpr inst_ty no_prags default_binds (sel_id, idx)
417 ) `thenTc` \ (defm_bind, insts_needed, (_, local_defm_id)) ->
419 -- CHECK THE CONTEXT OF THE DEFAULT-METHOD BINDS
423 insts_needed `thenTc` \ (const_lie, dict_binds) ->
426 defm_binds = AbsBinds
429 [([clas_tyvar], RealId defm_id, local_defm_id)]
430 (dict_binds `AndMonoBinds` defm_bind)
432 returnTc (const_lie, defm_binds)
435 clas_tyvar_set = unitTyVarSet clas_tyvar
436 inst_ty = mkTyVarTy clas_tyvar
437 origin = ClassDeclOrigin
438 noDefmExpr _ = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
439 (HsLit (HsString (_PK_ error_msg)))
441 error_msg = show (sep [text "Class", ppr (PprForUser opt_PprUserLength) clas,
442 text "Method", ppr (PprForUser opt_PprUserLength) sel_id])
450 classDeclCtxt class_name sty
451 = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]