ghc/compiler/typecheck/TcClassSig.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   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          -- typechecking monadic machinery
  12 import AbsSyn           -- the stuff being typechecked
  13
  14 import AbsUniType
  15 import CE               ( CE(..) )
  16 import E                ( mkE, getE_TCE, getE_CE, nullGVE, unitGVE, plusGVE, GVE(..), E )
  17 import Errors           ( methodTypeLacksTyVarErr, confusedNameErr )
  18 import Id               ( mkDefaultMethodId, mkClassOpId, IdInfo )
  19 import IdInfo
  20 import InstEnv          ( InstTemplate )
  21 import TCE              ( TCE(..), UniqFM )
  22 import TVE              ( TVE(..) )
  23 import TcPolyType       ( tcPolyType )
  24 import TcPragmas        ( tcClassOpPragmas )
  25 import Util
  26 \end{code}
  27
  28 \begin{code}
  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
  36                          [Id],          -- selector ids
  37                          [Id])          -- default-method ids
  38
  39 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
  40   = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
  41     let
  42         (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
  43     in
  44     returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
  45   where
  46     rec_ce  = getE_CE  e
  47     rec_tce = getE_TCE e
  48
  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 ->
  52         let
  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
  58
  59             not_elem = isn'tIn "tcClassSigs"
  60         in
  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_`
  64
  65             -- Munch the pragmas, building a suitable default-method
  66             -- Id from the details found there.
  67         getUniqueB_Tc                   `thenB_Tc` \ d_uniq ->
  68
  69         fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
  70             tcClassOpPragmas e{-fake_E-}
  71                 global_ty
  72                 rec_op_id rec_defm_id
  73                 (rec_classop_spec_fn class_op)
  74                 pragmas         `thenB_Tc` \ (op_info, defm_info) ->
  75             let
  76                 -- the default method is error "No default ..." if there is no
  77                 -- default method code or the imported default method is bottoming.
  78
  79                 error_defm = if isLocallyDefined clas_name then
  80                                  name `notElem` defm_names
  81                              else
  82                                  bottomIsGuaranteed (getInfo defm_info)
  83             in
  84             returnB_Tc (
  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
  87             )
  88
  89         ) `thenB_Tc` \ (selector_id, default_method_id) ->
  90
  91         returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
  92         )
  93
  94     tc_sig (ClassOpSig name _ _ src_loc)
  95       = failB_Tc (confusedNameErr
  96                     "Bad name on a class-method signature (a Prelude name?)"
  97                     name src_loc)
  98 \end{code}