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)
95 --FAKE: fake_E = mkE rec_tce rec_ce
97 tc_clas1 (ClassDecl context class_name
98 tyvar_name class_sigs def_methods pragmas src_loc)
100 = addSrcLocTc src_loc (
102 -- The knot is needed so that the signatures etc can point
103 -- back to the class itself
104 fixTc (\ ~(rec_clas, _) ->
106 (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas
108 -- Get new (template) type variables for the class
109 let (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name] in
111 -- Typecheck the class context; since there is only one type
112 -- variable in scope, we are assured that the it will be of
113 -- the form (C1 a, C2 a...)
114 babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta ->
116 -- Make the superclass selector ids; the "class" pragmas
117 -- may have info about the superclass dict selectors;
118 -- so it is only tcClassPragmas that gives back the
120 getUniquesTc (length theta) `thenNF_Tc` \ uniqs ->
122 super_classes = [ supers | (supers, _) <- theta ]
124 = [ mkSuperDictSelType rec_clas super | super <- super_classes ]
125 super_info = zip3 super_classes uniqs super_tys
129 returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ]
131 SuperDictPragmas prags ->
132 -- pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) (
133 mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags)
136 -- pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty]
138 ) `thenNF_Tc` \ super_class_sel_ids ->
140 -- Typecheck the class signatures, checking that each mentions
141 -- the class type variable somewhere, and manufacturing
142 -- suitable Ids for selectors and default methods.
144 (tcClassSigs e tve rec_clas rec_class_op_inst_fn
145 clas_tyvar class_sigs)
146 `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) ->
148 -- Make the class object itself, producing clas::Class
151 = mkClass class_name clas_tyvar
152 super_classes super_class_sel_ids
153 ops op_sel_ids defm_ids
156 returnTc (clas, ops_gve)
157 ) `thenTc` \ (clas, ops_gve) ->
159 -- Return the class decl for further work if it is
160 -- local, otherwise just return the CE
161 returnTc (if (isLocallyDefined class_name) then
162 Just (ClassInfo clas def_methods)
165 unitCE (getClassKey clas) clas,
170 mk_super_id clas (super_clas, uniq, ty) id_info
171 = mkSuperDictSelId uniq clas super_clas ty id_info
174 mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags)
175 = fixNF_Tc ( \ rec_super_id ->
177 (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags)
178 `thenNF_Tc` \ id_info ->
180 returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info)
183 {- SOMETHING LIKE THIS NEEDED? ToDo [WDP]
184 tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc)
185 = failTc (confusedNameErr
186 "Bad name for a class (a type constructor, or Prelude name?)"
192 %************************************************************************
194 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
196 %************************************************************************
198 The purpose of pass 2 is
201 to beat on the explicitly-provided default-method decls (if any),
202 using them to produce a complete set of default-method decls.
203 (Omitted ones elicit an error message.)
205 to produce a definition for the selector function for each method
208 Pass~2 only applies to locally-defined class declarations.
210 The function @tcClassDecls2@ just arranges to apply
211 @tcClassDecls2_help@ to each local class decl.
214 tcClassDecls2 e class_info
216 -- Get type variables free in environment. Sadly, there may be
217 -- some, because of the dreaded monomorphism restriction
218 free_tyvars = tvOfE e
220 tcClassDecls2_help e free_tyvars class_info
226 -> NF_TcM (LIE, TypecheckedBinds)
228 tcClassDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
230 tcClassDecls2_help e free_tyvars ((ClassInfo clas default_binds) : rest)
231 = tcClassDecl2 e free_tyvars clas default_binds `thenNF_Tc` \ (lie1, binds1) ->
232 tcClassDecls2_help e free_tyvars rest `thenNF_Tc` \ (lie2, binds2) ->
233 returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
236 @tcClassDecl2@ is the business end of things.
240 -> [TyVar] -- Free in the envt
242 -> RenamedMonoBinds -- The default decls
243 -> NF_TcM (LIE, TypecheckedBinds)
245 tcClassDecl2 e free_tyvars clas default_binds
247 src_loc = getSrcLoc clas
248 origin = ClassDeclOrigin src_loc
249 (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
250 = getClassBigSig clas
252 -- Prune the substitution when we are finished, and arrange error recovery
253 recoverTc (nullLIE, EmptyBinds) (
254 addSrcLocTc src_loc (
255 pruneSubstTc free_tyvars (
257 -- Generate bindings for the selector functions
258 buildSelectors origin clas clas_tyvar_tmpl scs sc_sel_ids ops op_sel_ids
259 `thenNF_Tc` \ sel_binds ->
260 -- Ditto for the methods
261 buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
262 defm_ids default_binds `thenTc` \ (const_insts, meth_binds) ->
264 -- Back-substitute through the definitions
265 applyTcSubstToInsts const_insts `thenNF_Tc` \ final_const_insts ->
266 applyTcSubstToBinds (sel_binds `ThenBinds` meth_binds) `thenNF_Tc` \ final_binds ->
267 returnTc (mkLIE final_const_insts, final_binds)
271 %************************************************************************
273 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
275 %************************************************************************
278 buildSelectors :: InstOrigin
279 -> Class -- The class object
280 -> TyVarTemplate -- Class type variable
281 -> [Class] -> [Id] -- Superclasses and selectors
282 -> [ClassOp] -> [Id] -- Class ops and selectors
283 -> NF_TcM TypecheckedBinds
285 buildSelectors origin clas clas_tyvar_tmpl
289 -- Instantiate the class variable
290 copyTyVars [clas_tyvar_tmpl] `thenNF_Tc` \ (inst_env, [clas_tyvar], [clas_tyvar_ty]) ->
291 -- Make an Inst for each class op, and
292 -- dicts for the superclasses. These are used to
293 -- construct the selector functions
294 newClassOpLocals inst_env ops `thenNF_Tc` \ method_ids ->
295 newDicts origin [ (super_clas, clas_tyvar_ty)
297 ] `thenNF_Tc` \ dicts ->
298 let dict_ids = map mkInstId dicts in
300 -- Make suitable bindings for the selectors
301 let mk_op_sel op sel_id method_id
302 = mkSelExpr origin clas_tyvar dict_ids method_ids method_id `thenNF_Tc` \ rhs ->
303 returnNF_Tc (VarMonoBind sel_id rhs)
304 mk_sc_sel sc sel_id dict_id
305 = mkSelExpr origin clas_tyvar dict_ids method_ids dict_id `thenNF_Tc` \ rhs ->
306 returnNF_Tc (VarMonoBind sel_id rhs)
308 listNF_Tc (zipWith3 mk_op_sel ops op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
309 listNF_Tc (zipWith3 mk_sc_sel scs sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
311 returnNF_Tc (SingleBind (
313 foldr AndMonoBinds EmptyMonoBinds (
314 op_sel_binds ++ sc_sel_binds))))
317 %************************************************************************
319 \subsection[ClassDcl-misc]{Miscellaneous}
321 %************************************************************************
323 Make a selector expression for @local@ from a dictionary consisting of
324 @dicts@ and @op_locals@.
326 We have to do a bit of jiggery pokery to get the type variables right.
327 Suppose we have the class decl:
330 op1 :: Ord b => a -> b -> a
333 Then the method selector for \tr{op1} is like this:
335 op1_sel = /\ab -> \dFoo -> case dFoo of
336 (op1_method,op2_method) -> op1_method b
338 Note that the type variable for \tr{b} is lifted to the top big lambda, and
339 \tr{op1_method} is applied to it. This is preferable to the alternative:
341 op1_sel' = /\a -> \dFoo -> case dFoo of
342 (op1_method,op2_method) -> op1_method
344 because \tr{op1_sel'} then has the rather strange type
346 op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
348 whereas \tr{op1_sel} (the one we use) has the decent type
350 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
354 We could do the same thing for the dictionaries, giving
356 op1_sel = /\ab -> \dFoo -> \dOrd -> case dFoo of
359 but WE ASSUME THAT DICTIONARY APPLICATION IS CURRIED, so the two are
360 precisely equivalent, and have the same type, namely
362 op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
365 WDP 95/03: Quite false (``DICTIONARY APPLICATION IS CURRIED'').
366 Specialisation now wants to see all type- and dictionary-applications
367 absolutely explicitly.
370 mkSelExpr :: InstOrigin -> TyVar -> [Id] -> [Id] -> Id -> NF_TcM TypecheckedExpr
372 mkSelExpr origin clas_tyvar dicts op_locals local
374 (op_tyvar_tmpls,local_theta,_) = splitType (getIdUniType local)
376 copyTyVars op_tyvar_tmpls `thenNF_Tc` \ (inst_env, op_tyvars, tys) ->
378 inst_theta = instantiateThetaTy inst_env local_theta
380 newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts ->
382 local_dicts = map mkInstId local_dict_insts
384 returnNF_Tc (TyLam (clas_tyvar:op_tyvars)
388 (mkDictLam local_dicts
389 (mkDictApp (mkTyApp (Var local) tys) local_dicts))))
393 %************************************************************************
395 \subsection[Default methods]{Default methods}
397 %************************************************************************
399 The default methods for a class are each passed a dictionary for the
400 class, so that they get access to the other methods at the same type.
401 So, given the class decl
405 op2 :: Ord b => a -> b -> b -> b
408 op2 x y z = if (op1 x) && (y < z) then y else z
410 we get the default methods:
412 defm.Foo.op1 :: forall a. Foo a => a -> Bool
413 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
415 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
416 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
417 if (op1 a dfoo x) && (< b dord y z) then y else z
419 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
421 When we come across an instance decl, we may need to use the default
424 instance Foo Int where {}
428 const.Foo.Int.op1 :: Int -> Bool
429 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
431 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
432 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
434 dfun.Foo.Int :: Foo Int
435 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
437 Notice that, as with method selectors above, we assume that dictionary
438 application is curried, so there's no need to mention the Ord dictionary
441 instance Foo a => Foo [a] where {}
443 dfun.Foo.List :: forall a. Foo a -> Foo [a]
445 = /\ a -> \ dfoo_a ->
447 op1 = defm.Foo.op1 [a] dfoo_list
448 op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
449 dfoo_list = (op1, op2)
455 buildDefaultMethodBinds
463 -> TcM ([Inst], TypecheckedBinds)
465 buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
466 default_method_ids default_binds
467 = -- Deal with the method declarations themselves
470 (makeClassDeclDefaultMethodRhs clas origin default_method_ids)
471 [] -- No tyvars in scope for "this inst decl"
472 [] -- No insts available
474 default_binds `thenTc` \ (dicts_needed, default_binds') ->
476 returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
479 @makeClassDeclDefaultMethodRhs@ builds the default method for a
480 class declaration when no explicit default method is given.
483 makeClassDeclDefaultMethodRhs
488 -> NF_TcM TypecheckedExpr
490 makeClassDeclDefaultMethodRhs clas origin method_ids tag
491 = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
493 returnNF_Tc (mkTyLam tyvars (
494 mkDictLam (map mkInstId dicts) (
495 App (mkTyApp (Var pAT_ERROR_ID) [tau])
496 (Lit (StringLit (_PK_ error_msg))))))
498 method_id = method_ids !! (tag-1)
499 class_op = (getClassOps clas) !! (tag-1)
501 error_msg = "%D" -- => No default method for \"
502 ++ unencoded_part_of_msg
504 unencoded_part_of_msg = escErrorMsg (
505 _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
506 ++ (ppShow 80 (ppr PprForUser class_op))
509 (clas_mod, clas_name) = getOrigName clas