ghc/compiler/typecheck/TcClassSig.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcClassSig]{Typecheck a class signature}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcClassSig ( tcClassSigs ) where
  10
  11 import TcMonad          hiding ( rnMtoTcM )
  12 import HsSyn            -- the stuff being typechecked
  13
  14 import Type
  15 import Id               ( mkDefaultMethodId, mkClassOpId, IdInfo )
  16 import IdInfo
  17 import TcMonoType       ( tcPolyType )
  18 import TcPragmas        ( tcClassOpPragmas )
  19 import Util
  20 \end{code}
  21
  22 \begin{code}
  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
  30                          [Id],          -- selector ids
  31                          [Id])          -- default-method ids
  32
  33 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
  34   = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
  35     let
  36         (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
  37     in
  38     returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
  39   where
  40     rec_ce  = getE_CE  e
  41     rec_tce = getE_TCE e
  42 --FAKE:    fake_E  = mkE rec_tce rec_ce
  43
  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 ->
  47         let
  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
  53
  54             not_elem = isn'tIn "tcClassSigs"
  55         in
  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_`
  59
  60             -- Munch the pragmas, building a suitable default-method
  61             -- Id from the details found there.
  62         getUniqueB_Tc                   `thenB_Tc` \ d_uniq ->
  63
  64         fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
  65             tcClassOpPragmas e{-fake_E-}
  66                 global_ty
  67                 rec_op_id rec_defm_id
  68                 (rec_classop_spec_fn class_op)
  69                 pragmas         `thenB_Tc` \ (op_info, defm_info) ->
  70             let
  71                 -- the default method is error "No default ..." if there is no
  72                 -- default method code or the imported default method is bottoming.
  73
  74                 error_defm = if isLocallyDefined clas_name then
  75                                  name `notElem` defm_names
  76                              else
  77                                  bottomIsGuaranteed (getInfo defm_info)
  78             in
  79             returnB_Tc (
  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
  82             )
  83
  84         ) `thenB_Tc` \ (selector_id, default_method_id) ->
  85
  86         returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
  87         )
  88
  89     tc_sig (ClassOpSig name _ _ src_loc)
  90       = failB_Tc (confusedNameErr
  91                     "Bad name on a class-method signature (a Prelude name?)"
  92                     name src_loc)
  93 \end{code}