2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcClassDcl]{Typechecking class declarations}
7 #include "HsVersions.h"
10 tcClassDecls1, tcClassDecls2,
14 IMPORT_Trace -- ToDo: rm (debugging)
15 import Pretty -- add proper one below
17 import TcMonad -- typechecking monad machinery
18 import TcMonadFns ( newDicts, newClassOpLocals, copyTyVars )
19 import AbsSyn -- the stuff being typechecked
21 import AbsPrel ( pAT_ERROR_ID )
22 import AbsUniType ( mkClass, getClassKey, getClassBigSig,
23 getClassOpString, getClassOps, splitType,
24 mkSuperDictSelType, InstTyEnv(..),
25 instantiateTy, instantiateThetaTy, UniType
27 import BackSubst ( applyTcSubstToBinds )
28 import CE -- ( nullCE, unitCE, plusCE, CE(..), UniqFM )
29 import E ( mkE, getE_TCE, getE_CE, tvOfE, nullGVE, plusGVE, E, TCE(..), UniqFM, GVE(..) )
30 import Errors ( confusedNameErr, Error(..) )
31 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
32 import Id ( mkSuperDictSelId, mkInstId, getIdUniType,
36 import Inst ( InstOrigin(..), Inst )
38 import LIE ( nullLIE, mkLIE, plusLIE, LIE )
39 import Maybes ( Maybe(..) )
40 import Name ( Name(..) )
41 import PlainCore ( escErrorMsg )
42 import Spec ( specTy )
43 import TVE ( mkTVE, TVE(..)
44 IF_ATTACK_PRAGMAS(COMMA u2i)
46 import TcClassSig ( tcClassSigs )
47 import TcContext ( tcContext )
48 import TcInstDcls ( processInstBinds )
49 import TcPragmas ( tcGenPragmas )
53 @ClassInfo@ communicates the essential information about
54 locally-defined classes between passes 1 and 2.
63 %************************************************************************
65 \subsection[TcClassDcl]{Does the real work (apart from default methods)}
67 %************************************************************************
71 :: E -- Consult the CE/TCE args only to build knots
72 -> InstanceMapper -- Maps class name to its instances,
73 -- ...and its ops to their instances,
75 -> TcM ([ClassInfo], -- boiled-down info related to classes
76 CE, -- env so we can look up classes elsewhere
77 GVE) -- env so we can look up class ops elsewhere
79 tcClassDecls1 e rec_inst_mapper []
80 = returnTc ([], nullCE, nullGVE)
82 tcClassDecls1 e rec_inst_mapper (cd:cds)
83 = tc_clas1 cd `thenTc` \ (cinfo1_maybe, ce1, gve1) ->
84 tcClassDecls1 e rec_inst_mapper cds `thenTc` \ (cinfo2, ce2, gve2) ->
87 = case cinfo1_maybe of
89 Just xx -> xx : cinfo2
91 returnTc (glued_cinfos, ce1 `plusCE` ce2, gve1 `plusGVE` gve2)
96 tc_clas1 (ClassDecl context class_name
97 tyvar_name class_sigs def_methods pragmas src_loc)
99 = addSrcLocTc src_loc (
101 -- The knot is needed so that the signatures etc can point
102 -- back to the class itself
103 fixTc (\ ~(rec_clas, _) ->
105 (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas
107 -- Get new (template) type variables for the class
108 let (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name] in
110 -- Typecheck the class context; since there is only one type
111 -- variable in scope, we are assured that the it will be of
112 -- the form (C1 a, C2 a...)
113 babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta ->
115 -- Make the superclass selector ids; the "class" pragmas
116 -- may have info about the superclass dict selectors;
117 -- so it is only tcClassPragmas that gives back the
119 getUniquesTc (length theta) `thenNF_Tc` \ uniqs ->
121 super_classes = [ supers | (supers, _) <- theta ]
123 = [ mkSuperDictSelType rec_clas super | super <- super_classes ]
124 super_info = zip3 super_classes uniqs super_tys
128 returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ]
130 SuperDictPragmas prags ->
131 -- pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) (
132 mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags)
135 -- pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty]
137 ) `thenNF_Tc` \ super_class_sel_ids ->
139 -- Typecheck the class signatures, checking that each mentions
140 -- the class type variable somewhere, and manufacturing
141 -- suitable Ids for selectors and default methods.
143 (tcClassSigs e tve rec_clas rec_class_op_inst_fn
144 clas_tyvar defm_names class_sigs)
145 `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) ->
147 -- Make the class object itself, producing clas::Class
150 = mkClass class_name clas_tyvar
151 super_classes super_class_sel_ids
152 ops op_sel_ids defm_ids
155 returnTc (clas, ops_gve)
156 ) `thenTc` \ (clas, ops_gve) ->
158 -- Return the class decl for further work if it is
159 -- local, otherwise just return the CE
160 returnTc (if (isLocallyDefined class_name) then
161 Just (ClassInfo clas def_methods)
164 unitCE (getClassKey clas) clas,
168 defm_names = collectMonoBinders def_methods
171 mk_super_id clas (super_clas, uniq, ty) id_info
172 = mkSuperDictSelId uniq clas super_clas ty id_info
175 mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags)
176 = fixNF_Tc ( \ rec_super_id ->
178 (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags)
179 `thenNF_Tc` \ id_info ->
181 returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info)
184 {- SOMETHING LIKE THIS NEEDED? ToDo [WDP]
185 tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc)
186 = failTc (confusedNameErr
187 "Bad name for a class (a type constructor, or Prelude name?)"
193 %************************************************************************
195 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
197 %************************************************************************
199 The purpose of pass 2 is
202 to beat on the explicitly-provided default-method decls (if any),
203 using them to produce a complete set of default-method decls.
204 (Omitted ones elicit an error message.)
206 to produce a definition for the selector function for each method
209 Pass~2 only applies to locally-defined class declarations.
211 The function @tcClassDecls2@ just arranges to apply
212 @tcClassDecls2_help@ to each local class decl.
215 tcClassDecls2 e class_info
217 -- Get type variables free in environment. Sadly, there may be
218 -- some, because of the dreaded monomorphism restriction
219 free_tyvars = tvOfE e
221 tcClassDecls2_help e free_tyvars class_info
227 -> NF_TcM (LIE, TypecheckedBinds)
229 tcClassDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
231 tcClassDecls2_help e free_tyvars ((ClassInfo clas default_binds) : rest)
232 = tcClassDecl2 e free_tyvars clas default_binds `thenNF_Tc` \ (lie1, binds1) ->
233 tcClassDecls2_help e free_tyvars rest `thenNF_Tc` \ (lie2, binds2) ->
234 returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
237 @tcClassDecl2@ is the business end of things.
241 -> [TyVar] -- Free in the envt
243 -> RenamedMonoBinds -- The default decls
244 -> NF_TcM (LIE, TypecheckedBinds)
246 tcClassDecl2 e free_tyvars clas default_binds
248 src_loc = getSrcLoc clas
249 origin = ClassDeclOrigin src_loc
250 (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
251 = getClassBigSig clas
253 -- Prune the substitution when we are finished, and arrange error recovery
254 recoverTc (nullLIE, EmptyBinds) (
255 addSrcLocTc src_loc (
256 pruneSubstTc free_tyvars (
258 -- Generate bindings for the selector functions
259 buildSelectors origin clas clas_tyvar_tmpl scs sc_sel_ids ops op_sel_ids
260 `thenNF_Tc` \ sel_binds ->
261 -- Ditto for the methods
262 buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
263 defm_ids default_binds `thenTc` \ (const_insts, meth_binds) ->
265 -- Back-substitute through the definitions
266 applyTcSubstToInsts const_insts `thenNF_Tc` \ final_const_insts ->
267 applyTcSubstToBinds (sel_binds `ThenBinds` meth_binds) `thenNF_Tc` \ final_binds ->
268 returnTc (mkLIE final_const_insts, final_binds)
272 %************************************************************************
274 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
276 %************************************************************************
279 buildSelectors :: InstOrigin
280 -> Class -- The class object
281 -> TyVarTemplate -- Class type variable
282 -> [Class] -> [Id] -- Superclasses and selectors
283 -> [ClassOp] -> [Id] -- Class ops and selectors
284 -> NF_TcM TypecheckedBinds
286 buildSelectors origin clas clas_tyvar_tmpl
290 -- Instantiate the class variable
291 copyTyVars [clas_tyvar_tmpl] `thenNF_Tc` \ (inst_env, [clas_tyvar], [clas_tyvar_ty]) ->
292 -- Make an Inst for each class op, and
293 -- dicts for the superclasses. These are used to
294 -- construct the selector functions
295 newClassOpLocals inst_env ops `thenNF_Tc` \ method_ids ->
296 newDicts origin [ (super_clas, clas_tyvar_ty)
298 ] `thenNF_Tc` \ dicts ->
299 let dict_ids = map mkInstId dicts in
301 -- Make suitable bindings for the selectors
302 let mk_op_sel op sel_id method_id
303 = mkSelExpr origin clas_tyvar dict_ids method_ids method_id `thenNF_Tc` \ rhs ->
304 returnNF_Tc (VarMonoBind sel_id rhs)
305 mk_sc_sel sc sel_id dict_id
306 = mkSelExpr origin clas_tyvar dict_ids method_ids dict_id `thenNF_Tc` \ rhs ->
307 returnNF_Tc (VarMonoBind sel_id rhs)
309 listNF_Tc (zipWith3 mk_op_sel ops op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
310 listNF_Tc (zipWith3 mk_sc_sel scs sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
312 returnNF_Tc (SingleBind (
314 foldr AndMonoBinds EmptyMonoBinds (
315 op_sel_binds ++ sc_sel_binds))))
318 %************************************************************************
320 \subsection[ClassDcl-misc]{Miscellaneous}
322 %************************************************************************
324 Make a selector expression for @local@ from a dictionary consisting of
325 @dicts@ and @op_locals@.
327 We have to do a bit of jiggery pokery to get the type variables right.
328 Suppose we have the class decl:
331 op1 :: Ord b => a -> b -> a
334 Then the method selector for \tr{op1} is like this:
336 op1_sel = /\ab -> \dFoo -> case dFoo of
337 (op1_method,op2_method) -> op1_method b
339 Note that the type variable for \tr{b} is lifted to the top big lambda, and
340 \tr{op1_method} is applied to it. This is preferable to the alternative:
342 op1_sel' = /\a -> \dFoo -> case dFoo of
343 (op1_method,op2_method) -> op1_method
345 because \tr{op1_sel'} then has the rather strange type
347 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
349 whereas \tr{op1_sel} (the one we use) has the decent type
351 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
355 We could do the same thing for the dictionaries, giving
357 op1_sel = /\ab -> \dFoo -> \dOrd -> case dFoo of
360 but WE ASSUME THAT DICTIONARY APPLICATION IS CURRIED, so the two are
361 precisely equivalent, and have the same type, namely
363 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
366 WDP 95/03: Quite false (``DICTIONARY APPLICATION IS CURRIED'').
367 Specialisation now wants to see all type- and dictionary-applications
368 absolutely explicitly.
371 mkSelExpr :: InstOrigin -> TyVar -> [Id] -> [Id] -> Id -> NF_TcM TypecheckedExpr
373 mkSelExpr origin clas_tyvar dicts op_locals local
375 (op_tyvar_tmpls,local_theta,_) = splitType (getIdUniType local)
377 copyTyVars op_tyvar_tmpls `thenNF_Tc` \ (inst_env, op_tyvars, tys) ->
379 inst_theta = instantiateThetaTy inst_env local_theta
381 newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts ->
383 local_dicts = map mkInstId local_dict_insts
385 returnNF_Tc (TyLam (clas_tyvar:op_tyvars)
389 (mkDictLam local_dicts
390 (mkDictApp (mkTyApp (Var local) tys) local_dicts))))
394 %************************************************************************
396 \subsection[Default methods]{Default methods}
398 %************************************************************************
400 The default methods for a class are each passed a dictionary for the
401 class, so that they get access to the other methods at the same type.
402 So, given the class decl
406 op2 :: Ord b => a -> b -> b -> b
409 op2 x y z = if (op1 x) && (y < z) then y else z
411 we get the default methods:
413 defm.Foo.op1 :: forall a. Foo a => a -> Bool
414 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
416 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
417 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
418 if (op1 a dfoo x) && (< b dord y z) then y else z
420 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
422 When we come across an instance decl, we may need to use the default
425 instance Foo Int where {}
429 const.Foo.Int.op1 :: Int -> Bool
430 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
432 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
433 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
435 dfun.Foo.Int :: Foo Int
436 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
438 Notice that, as with method selectors above, we assume that dictionary
439 application is curried, so there's no need to mention the Ord dictionary
442 instance Foo a => Foo [a] where {}
444 dfun.Foo.List :: forall a. Foo a -> Foo [a]
446 = /\ a -> \ dfoo_a ->
448 op1 = defm.Foo.op1 [a] dfoo_list
449 op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
450 dfoo_list = (op1, op2)
456 buildDefaultMethodBinds
464 -> TcM ([Inst], TypecheckedBinds)
466 buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
467 default_method_ids default_binds
468 = -- Deal with the method declarations themselves
471 (makeClassDeclDefaultMethodRhs clas origin default_method_ids)
472 [] -- No tyvars in scope for "this inst decl"
473 [] -- No insts available
475 default_binds `thenTc` \ (dicts_needed, default_binds') ->
477 returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
480 @makeClassDeclDefaultMethodRhs@ builds the default method for a
481 class declaration when no explicit default method is given.
484 makeClassDeclDefaultMethodRhs
489 -> NF_TcM TypecheckedExpr
491 makeClassDeclDefaultMethodRhs clas origin method_ids tag
492 = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
494 returnNF_Tc (mkTyLam tyvars (
495 mkDictLam (map mkInstId dicts) (
496 App (mkTyApp (Var pAT_ERROR_ID) [tau])
497 (Lit (StringLit (_PK_ error_msg))))))
499 method_id = method_ids !! (tag-1)
500 class_op = (getClassOps clas) !! (tag-1)
502 error_msg = "%D" -- => No default method for \"
503 ++ unencoded_part_of_msg
505 unencoded_part_of_msg = escErrorMsg (
506 _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
507 ++ (ppShow 80 (ppr PprForUser class_op))
510 (clas_mod, clas_name) = getOrigName clas