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             -> [RenamedClassOpSig]
  33             -> Baby_TcM ([ClassOp],     -- class ops
  34                          GVE,           -- env for looking up the class ops
  35                          [Id],          -- selector ids
  36                          [Id])          -- default-method ids
  37
  38 tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs
  39   = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
  40     let
  41         (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff
  42     in
  43     returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids)
  44   where
  45     rec_ce  = getE_CE  e
  46     rec_tce = getE_TCE e
  47 --FAKE:    fake_E  = mkE rec_tce rec_ce
  48
  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 ->
  52
  53 --              OLD: convoluted way to compute global_ty
  54 --      let
  55 --          (local_tyvar_tmpls, theta, tau) = splitType local_ty
  56 --      in
  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, _) ->
  60 --
  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
  66
  67         let
  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
  73
  74             not_elem = isn'tIn "tcClassSigs"
  75         in
  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_`
  79
  80             -- Munch the pragmas, building a suitable default-method
  81             -- Id from the details found there.
  82         getUniqueB_Tc                   `thenB_Tc` \ d_uniq ->
  83
  84         fixB_Tc ( \ ~(rec_op_id, rec_defm_id) ->
  85             tcClassOpPragmas e{-fake_E-}
  86                 global_ty
  87                 rec_op_id rec_defm_id
  88                 (rec_classop_spec_fn class_op)
  89                 pragmas         `thenB_Tc` \ (op_info, defm_info) ->
  90
  91             returnB_Tc (
  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
  94             )
  95
  96         ) `thenB_Tc` \ (selector_id, default_method_id) ->
  97
  98         returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id)
  99         )
 100
 101     tc_sig (ClassOpSig name _ _ src_loc)
 102       = failB_Tc (confusedNameErr
 103                     "Bad name on a class-method signature (a Prelude name?)"
 104                     name src_loc)
 105 \end{code}