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 -> [Name] -- Names with default methods
33 -> [RenamedClassOpSig]
34 -> Baby_TcM ([ClassOp], -- class ops
35 GVE, -- env for looking up the class ops
37 [Id]) -- default-method ids
39 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
40 = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
42 (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
44 returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
49 tc_sig (ClassOpSig name@(ClassOpName op_uniq clas_name 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 (local_tyvar_tmpls, theta, tau) = splitType local_ty
54 full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
55 full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
56 global_ty = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
57 class_op = mkClassOp op_name tag local_ty
59 not_elem = isn'tIn "tcClassSigs"
61 -- Check that the class type variable is mentioned
62 checkB_Tc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
63 (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenB_Tc_`
65 -- Munch the pragmas, building a suitable default-method
66 -- Id from the details found there.
67 getUniqueB_Tc `thenB_Tc` \ d_uniq ->
69 fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
70 tcClassOpPragmas e{-fake_E-}
73 (rec_classop_spec_fn class_op)
74 pragmas `thenB_Tc` \ (op_info, defm_info) ->
76 -- the default method is error "No default ..." if there is no
77 -- default method code or the imported default method is bottoming.
79 error_defm = if isLocallyDefined clas_name then
80 name `notElem` defm_names
82 bottomIsGuaranteed (getInfo defm_info)
85 mkClassOpId op_uniq rec_clas class_op global_ty op_info,
86 mkDefaultMethodId d_uniq rec_clas class_op error_defm global_ty defm_info
89 ) `thenB_Tc` \ (selector_id, default_method_id) ->
91 returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
94 tc_sig (ClassOpSig name _ _ src_loc)
95 = failB_Tc (confusedNameErr
96 "Bad name on a class-method signature (a Prelude name?)"