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, tcMethodBind ) 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, InPat(..),
17 SYN_IE(RecFlag), nonRecursive, andMonoBinds, collectMonoBinders,
18 Stmt, DoOrListComp, ArithSeqInfo, 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 ( 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, newLocalIds, tcAddImportedIdInfo,
30 tcExtendGlobalTyVars )
31 import TcBinds ( tcBindWithSigs, TcSigInfo(..) )
32 import TcKind ( unifyKind, TcKind )
34 import TcMonoType ( tcHsType, tcContext )
35 import TcSimplify ( tcSimplifyAndCheck )
36 import TcType ( TcIdOcc(..), SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars,
37 tcInstSigType, tcInstSigTcType )
38 import PragmaInfo ( PragmaInfo(..) )
40 import Bag ( bagToList, unionManyBags )
41 import Class ( GenClass, mkClass, classBigSig,
43 classOpTagByOccName, SYN_IE(Class)
45 import CmdLineOpts ( opt_PprUserLength )
46 import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
47 mkDefaultMethodId, getIdUnfolding,
50 import CoreUnfold ( getUnfoldingTemplate )
52 import Name ( Name, isLocallyDefined, moduleString, getSrcLoc, nameOccName,
53 nameString, NamedThing(..) )
56 import PprType ( GenClass, GenType, GenTyVar )
57 import SpecEnv ( SpecEnv )
58 import SrcLoc ( mkGeneratedSrcLoc )
59 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
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_env 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_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_env rec_class rec_tyvar) class_sigs
132 `thenTc` \ sig_stuff ->
134 -- MAKE THE CLASS OBJECT ITSELF
136 (op_sel_ids, defm_ids) = unzip sig_stuff
137 clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
138 scs sc_sel_ids op_sel_ids defm_ids
146 clas_ty = mkTyVarTy clas_tyvar
147 dict_component_tys = classDictArgTys clas_ty
148 new_or_data = case dict_component_tys of
152 dict_con_id = mkDataCon class_name
154 [{- No labelled fields -}]
160 tycon = mkDataTyCon class_name
161 (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
163 [{- Empty context -}]
165 [{- No derived classes -}]
171 tcClassContext :: Class -> TyVar
172 -> RenamedContext -- class context
173 -> RenamedClassPragmas -- pragmas for superclasses
174 -> TcM s ([Class], -- the superclasses
175 [Id]) -- superclass selector Ids
177 tcClassContext rec_class rec_tyvar context pragmas
178 = -- Check the context.
179 -- The renamer has already checked that the context mentions
180 -- only the type variable of the class decl.
181 tcContext context `thenTc` \ theta ->
183 super_classes = [ supers | (supers, _) <- theta ]
186 -- Make super-class selector ids
187 mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
190 returnTc (super_classes, sc_sel_ids)
193 rec_tyvar_ty = mkTyVarTy rec_tyvar
195 mk_super_id rec_class super_class
196 = tcGetUnique `thenNF_Tc` \ uniq ->
198 ty = mkForAllTy rec_tyvar $
199 mkFunTy (mkDictTy rec_class rec_tyvar_ty)
200 (mkDictTy super_class rec_tyvar_ty)
202 returnTc (mkSuperDictSelId uniq rec_class super_class ty)
205 tcClassSig :: TcEnv s -- Knot tying only!
206 -> Class -- ...ditto...
207 -> TyVar -- The class type variable, used for error check only
209 -> TcM s (Id, -- selector id
210 Maybe Id) -- default-method ids
212 tcClassSig rec_env rec_clas rec_clas_tyvar
213 (ClassOpSig op_name maybe_dm_name
216 = tcAddSrcLoc src_loc $
218 -- Check the type signature. NB that the envt *already has*
219 -- bindings for the type variables; see comments in TcTyAndClassDcls.
221 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
222 -- and that it is not constrained by theta
223 tcHsType op_ty `thenTc` \ local_ty ->
225 global_ty = mkSigmaTy [rec_clas_tyvar]
226 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
230 -- Build the selector id and default method id
232 sel_id = mkMethodSelId op_name rec_clas global_ty
233 maybe_dm_id = case maybe_dm_name of
236 dm_id = mkDefaultMethodId dm_name rec_clas global_ty
238 Just (tcAddImportedIdInfo rec_env dm_id)
240 returnTc (sel_id, maybe_dm_id)
244 %************************************************************************
246 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
248 %************************************************************************
250 The purpose of pass 2 is
253 to beat on the explicitly-provided default-method decls (if any),
254 using them to produce a complete set of default-method decls.
255 (Omitted ones elicit an error message.)
257 to produce a definition for the selector function for each method
258 and superclass dictionary.
261 Pass~2 only applies to locally-defined class declarations.
263 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
264 each local class decl.
267 tcClassDecls2 :: [RenamedHsDecl]
268 -> NF_TcM s (LIE s, TcMonoBinds s)
272 (returnNF_Tc (emptyLIE, EmptyMonoBinds))
273 [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
275 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
276 tc2 `thenNF_Tc` \ (lie2, binds2) ->
277 returnNF_Tc (lie1 `plusLIE` lie2,
278 binds1 `AndMonoBinds` binds2)
281 @tcClassDecl2@ is the business end of things.
284 tcClassDecl2 :: RenamedClassDecl -- The class declaration
285 -> NF_TcM s (LIE s, TcMonoBinds s)
287 tcClassDecl2 (ClassDecl context class_name
288 tyvar_name class_sigs default_binds pragmas src_loc)
290 | not (isLocallyDefined class_name)
291 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
293 | otherwise -- It is locally defined
294 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
295 tcAddSrcLoc src_loc $
297 -- Get the relevant class
298 tcLookupClass class_name `thenTc` \ (_, clas) ->
300 (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
302 -- The selector binds are already in the selector Id's unfoldings
303 sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
304 | sel_id <- sc_sel_ids ++ op_sel_ids,
305 isLocallyDefined sel_id
308 final_sel_binds = andMonoBinds sel_binds
310 -- Generate bindings for the default methods
311 tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
313 returnTc (const_insts,
314 final_sel_binds `AndMonoBinds` meth_binds)
317 %************************************************************************
319 \subsection[Default methods]{Default methods}
321 %************************************************************************
323 The default methods for a class are each passed a dictionary for the
324 class, so that they get access to the other methods at the same type.
325 So, given the class decl
329 op2 :: Ord b => a -> b -> b -> b
332 op2 x y z = if (op1 x) && (y < z) then y else z
334 we get the default methods:
336 defm.Foo.op1 :: forall a. Foo a => a -> Bool
337 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
339 ====================== OLD ==================
341 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
342 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
343 if (op1 a dfoo x) && (< b dord y z) then y else z
345 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
346 ====================== END OF OLD ===================
350 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
351 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
352 if (op1 a dfoo x) && (< b dord y z) then y else z
356 When we come across an instance decl, we may need to use the default
359 instance Foo Int where {}
363 const.Foo.Int.op1 :: Int -> Bool
364 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
366 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
367 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
369 dfun.Foo.Int :: Foo Int
370 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
372 Notice that, as with method selectors above, we assume that dictionary
373 application is curried, so there's no need to mention the Ord dictionary
374 in const.Foo.Int.op2 (or the type variable).
377 instance Foo a => Foo [a] where {}
379 dfun.Foo.List :: forall a. Foo a -> Foo [a]
381 = /\ a -> \ dfoo_a ->
383 op1 = defm.Foo.op1 [a] dfoo_list
384 op2 = defm.Foo.op2 [a] dfoo_list
385 dfoo_list = (op1, op2)
394 -> TcM s (LIE s, TcMonoBinds s)
396 tcDefaultMethodBinds clas default_binds
397 = -- Construct suitable signatures
398 tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) ->
400 -- Typecheck the default bindings
402 clas_tyvar_set = unitTyVarSet clas_tyvar
406 bndr_name = case meth_bind of
407 FunMonoBind name _ _ _ -> name
408 PatMonoBind (VarPatIn name) _ _ -> name
410 idx = classOpTagByOccName clas (nameOccName bndr_name) - 1
411 sel_id = op_sel_ids !! idx
412 Just dm_id = defm_ids !! idx
414 tcMethodBind clas origin inst_ty sel_id meth_bind
415 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
416 returnTc (bind, insts, ([clas_tyvar], RealId dm_id, local_dm_id))
418 tcExtendGlobalTyVars clas_tyvar_set (
419 mapAndUnzip3Tc tc_dm (flatten default_binds [])
420 ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
423 newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
425 avail_insts = this_dict
430 (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
433 full_binds = AbsBinds
437 (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
439 returnTc (const_lie, full_binds)
442 (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
443 origin = ClassDeclOrigin
445 flatten EmptyMonoBinds rest = rest
446 flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
447 flatten a_bind rest = a_bind : rest
450 @tcMethodBind@ is used to type-check both default-method and
451 instance-decl method declarations. We must type-check methods one at a
452 time, because their signatures may have different contexts and
459 -> TcType s -- Instance type
460 -> Id -- The method selector
461 -> RenamedMonoBinds -- Method binding (just one)
462 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
464 tcMethodBind clas origin inst_ty sel_id meth_bind
465 = tcAddSrcLoc src_loc $
466 newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
467 tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
469 (theta', tau') = splitRhoTy rho_ty'
470 sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
472 tcBindWithSigs [bndr_name] meth_bind [sig_info]
473 nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
475 returnTc (binds, insts, meth)
477 (bndr_name, src_loc) = case meth_bind of
478 FunMonoBind name _ _ loc -> (name, loc)
479 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
485 classDeclCtxt class_name sty
486 = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]