2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcClassSig]{Typecheck a class signature}
7 #include "HsVersions.h"
9 module TcClassSig ( tcClassSigs ) where
11 import TcMonad -- typechecking monadic machinery
12 import AbsSyn -- the stuff being typechecked
16 import E ( mkE, getE_TCE, getE_CE, nullGVE, unitGVE, plusGVE, GVE(..), E )
17 import Errors ( methodTypeLacksTyVarErr, confusedNameErr )
18 import Id ( mkDefaultMethodId, mkClassOpId, IdInfo )
20 import InstEnv ( InstTemplate )
21 import TCE ( TCE(..), UniqFM )
22 import TVE ( TVE(..) )
23 import TcPolyType ( tcPolyType )
24 import TcPragmas ( tcClassOpPragmas )
29 tcClassSigs :: E -> TVE -> Class -- Knot tying only!
30 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
31 -> TyVarTemplate -- The class type variable, used for error check only
32 -> [RenamedClassOpSig]
33 -> Baby_TcM ([ClassOp], -- class ops
34 GVE, -- env for looking up the class ops
36 [Id]) -- default-method ids
38 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs
39 = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
41 (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
43 returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
47 --FAKE: fake_E = mkE rec_tce rec_ce
49 tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc)
50 = addSrcLocB_Tc src_loc (
51 tcPolyType rec_ce rec_tce tve poly_ty `thenB_Tc` \ local_ty ->
53 -- OLD: convoluted way to compute global_ty
55 -- (local_tyvar_tmpls, theta, tau) = splitType local_ty
57 -- -- Make new tyvars for each of the universally quantified type vars
58 -- copyTyVars (clas_tyvar:local_tyvar_tmpls)
59 -- `thenB_Tc` \ (inst_env, new_tyvars, _) ->
61 -- let -- Instantiate the tau type
62 -- full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
63 -- full_rho = mkRhoTy full_theta tau
64 -- inst_full_rho = instantiateTy inst_env full_rho
65 -- (_, global_ty) = quantifyTy new_tyvars inst_full_rho
68 (local_tyvar_tmpls, theta, tau) = splitType local_ty
69 full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
70 full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
71 global_ty = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
72 class_op = mkClassOp op_name tag local_ty
74 not_elem = isn'tIn "tcClassSigs"
76 -- Check that the class type variable is mentioned
77 checkB_Tc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
78 (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenB_Tc_`
80 -- Munch the pragmas, building a suitable default-method
81 -- Id from the details found there.
82 getUniqueB_Tc `thenB_Tc` \ d_uniq ->
84 fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
85 tcClassOpPragmas e{-fake_E-}
88 (rec_classop_spec_fn class_op)
89 pragmas `thenB_Tc` \ (op_info, defm_info) ->
92 mkClassOpId op_uniq rec_clas class_op global_ty op_info,
93 mkDefaultMethodId d_uniq rec_clas class_op False{-do better later-} global_ty defm_info
96 ) `thenB_Tc` \ (selector_id, default_method_id) ->
98 returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
101 tc_sig (ClassOpSig name _ _ src_loc)
102 = failB_Tc (confusedNameErr
103 "Bad name on a class-method signature (a Prelude name?)"