2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcClassSig]{Typecheck a class signature}
7 #include "HsVersions.h"
9 module TcClassSig ( tcClassSigs ) where
11 import TcMonad hiding ( rnMtoTcM )
12 import HsSyn -- the stuff being typechecked
15 import Id ( mkDefaultMethodId, mkClassOpId, IdInfo )
17 import TcMonoType ( tcPolyType )
18 import TcPragmas ( tcClassOpPragmas )
23 tcClassSigs :: E -> TVE -> Class -- Knot tying only!
24 -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
25 -> TyVarTemplate -- The class type variable, used for error check only
26 -> [RnName] -- Names with default methods
27 -> [RenamedClassOpSig]
28 -> Baby_TcM ([ClassOp], -- class ops
29 GVE, -- env for looking up the class ops
31 [Id]) -- default-method ids
33 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
34 = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
36 (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
38 returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
42 --FAKE: fake_E = mkE rec_tce rec_ce
44 tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc)
45 = addSrcLocB_Tc src_loc (
46 tcPolyType rec_ce rec_tce tve poly_ty `thenB_Tc` \ local_ty ->
48 (local_tyvar_tmpls, theta, tau) = splitSigmaTy local_ty
49 full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
50 full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
51 global_ty = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
52 class_op = mkClassOp op_name tag local_ty
54 not_elem = isn'tIn "tcClassSigs"
56 -- Check that the class type variable is mentioned
57 checkB_Tc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
58 (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenB_Tc_`
60 -- Munch the pragmas, building a suitable default-method
61 -- Id from the details found there.
62 getUniqueB_Tc `thenB_Tc` \ d_uniq ->
64 fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
65 tcClassOpPragmas e{-fake_E-}
68 (rec_classop_spec_fn class_op)
69 pragmas `thenB_Tc` \ (op_info, defm_info) ->
71 -- the default method is error "No default ..." if there is no
72 -- default method code or the imported default method is bottoming.
74 error_defm = if isLocallyDefined clas_name then
75 name `notElem` defm_names
77 bottomIsGuaranteed (getInfo defm_info)
80 mkClassOpId op_uniq rec_clas class_op global_ty op_info,
81 mkDefaultMethodId d_uniq rec_clas class_op error_defm global_ty defm_info
84 ) `thenB_Tc` \ (selector_id, default_method_id) ->
86 returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
89 tc_sig (ClassOpSig name _ _ src_loc)
90 = failB_Tc (confusedNameErr
91 "Bad name on a class-method signature (a Prelude name?)"