ghc/compiler/typecheck/TcMonoType.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12
  13 import HsSyn            ( PolyType(..), MonoType(..), Fake )
  14 import RnHsSyn          ( RenamedPolyType(..), RenamedMonoType(..),
  15                           RenamedContext(..), RnName(..),
  16                           isRnLocal, isRnClass, isRnTyCon
  17                         )
  18
  19 import TcMonad          hiding ( rnMtoTcM )
  20 import TcEnv            ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
  21                           tcTyVarScope, tcTyVarScopeGivenKinds
  22                         )
  23 import TcKind           ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
  24                           mkTcArrowKind, unifyKind, newKindVar,
  25                           kindToTcKind
  26                         )
  27 import Type             ( GenType, SYN_IE(Type), SYN_IE(ThetaType),
  28                           mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
  29                           mkSigmaTy, mkDictTy
  30                         )
  31 import TyVar            ( GenTyVar, SYN_IE(TyVar) )
  32 import Class            ( cCallishClassKeys )
  33 import TyCon            ( TyCon )
  34 import TysWiredIn       ( mkListTy, mkTupleTy )
  35 import Unique           ( Unique )
  36 import PprStyle
  37 import Pretty
  38 import Util             ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
  39 \end{code}
  40
  41
  42 tcMonoType and tcMonoTypeKind
  43 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  44
  45 tcMonoType checks that the type really is of kind Type!
  46
  47 \begin{code}
  48 tcMonoType :: RenamedMonoType -> TcM s Type
  49
  50 tcMonoType ty
  51   = tcMonoTypeKind ty                   `thenTc` \ (kind,ty) ->
  52     unifyKind kind mkTcTypeKind         `thenTc_`
  53     returnTc ty
  54 \end{code}
  55
  56 tcMonoTypeKind does the real work.  It returns a kind and a type.
  57
  58 \begin{code}
  59 tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
  60
  61 tcMonoTypeKind (MonoTyVar name)
  62   = tcLookupTyVar name  `thenNF_Tc` \ (kind,tyvar) ->
  63     returnTc (kind, mkTyVarTy tyvar)
  64
  65
  66 tcMonoTypeKind (MonoListTy ty)
  67   = tcMonoType ty       `thenTc` \ tau_ty ->
  68     returnTc (mkTcTypeKind, mkListTy tau_ty)
  69
  70 tcMonoTypeKind (MonoTupleTy tys)
  71   = mapTc tcMonoType  tys       `thenTc` \ tau_tys ->
  72     returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
  73
  74 tcMonoTypeKind (MonoFunTy ty1 ty2)
  75   = tcMonoType ty1      `thenTc` \ tau_ty1 ->
  76     tcMonoType ty2      `thenTc` \ tau_ty2 ->
  77     returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
  78
  79 tcMonoTypeKind (MonoTyApp name tys)
  80   | isRnLocal name      -- Must be a type variable
  81   = tcLookupTyVar name                  `thenNF_Tc` \ (kind,tyvar) ->
  82     tcMonoTyApp kind (mkTyVarTy tyvar) tys
  83
  84   | otherwise {-isRnTyCon name-}        -- Must be a type constructor
  85   = tcLookupTyCon name                  `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
  86     case maybe_arity of
  87         Just arity -> tcSynApp name kind arity tycon tys        -- synonum
  88         Nothing    -> tcMonoTyApp kind (mkTyConTy tycon) tys    -- newtype or data
  89
  90 --  | otherwise
  91 --  = pprPanic "tcMonoTypeKind:" (ppr PprDebug name)
  92
  93 -- for unfoldings only:
  94 tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
  95   = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
  96         tcMonoTypeKind ty               `thenTc` \ (kind, ty') ->
  97         unifyKind kind mkTcTypeKind     `thenTc_`
  98         returnTc (mkTcTypeKind, ty')
  99     )
 100   where
 101     (rn_names, kinds) = unzip tyvars_w_kinds
 102     names    = map de_rn rn_names
 103     tc_kinds = map kindToTcKind kinds
 104     de_rn (RnName n) = n
 105
 106 -- for unfoldings only:
 107 tcMonoTypeKind (MonoDictTy class_name ty)
 108   = tcMonoTypeKind ty                   `thenTc` \ (arg_kind, arg_ty) ->
 109     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 110     unifyKind class_kind arg_kind       `thenTc_`
 111     returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
 112 \end{code}
 113
 114 Help functions for type applications
 115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 116 \begin{code}
 117 tcMonoTyApp fun_kind fun_ty tys
 118   = mapAndUnzipTc tcMonoTypeKind tys    `thenTc`    \ (arg_kinds, arg_tys) ->
 119     newKindVar                          `thenNF_Tc` \ result_kind ->
 120     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
 121     returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
 122
 123 tcSynApp name syn_kind arity tycon tys
 124   = mapAndUnzipTc tcMonoTypeKind tys    `thenTc`    \ (arg_kinds, arg_tys) ->
 125     newKindVar                          `thenNF_Tc` \ result_kind ->
 126     unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
 127
 128         -- Check that it's applied to the right number of arguments
 129     checkTc (arity == n_args) (err arity)                               `thenTc_`
 130     returnTc (result_kind, mkSynTy tycon arg_tys)
 131   where
 132     err arity = arityErr "Type synonym constructor" name arity n_args
 133     n_args    = length tys
 134 \end{code}
 135
 136
 137 Contexts
 138 ~~~~~~~~
 139 \begin{code}
 140
 141 tcContext :: RenamedContext -> TcM s ThetaType
 142 tcContext context = mapTc tcClassAssertion context
 143
 144 tcClassAssertion (class_name, tyvar_name)
 145   = checkTc (canBeUsedInContext class_name)
 146             (naughtyCCallContextErr class_name) `thenTc_`
 147
 148     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 149     tcLookupTyVar tyvar_name            `thenNF_Tc` \ (tyvar_kind, tyvar) ->
 150
 151     unifyKind class_kind tyvar_kind     `thenTc_`
 152
 153     returnTc (clas, mkTyVarTy tyvar)
 154 \end{code}
 155
 156 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
 157 could be used in contexts such as:
 158 \begin{verbatim}
 159 foo :: CCallable a => a -> PrimIO Int
 160 \end{verbatim}
 161
 162 Doing this utterly wrecks the whole point of introducing these
 163 classes so we specifically check that this isn't being done.
 164
 165 \begin{code}
 166 canBeUsedInContext :: RnName -> Bool
 167 canBeUsedInContext n
 168   = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys)
 169 \end{code}
 170
 171 Polytypes
 172 ~~~~~~~~~
 173 \begin{code}
 174 tcPolyType :: RenamedPolyType -> TcM s Type
 175 tcPolyType (HsForAllTy tyvar_names context ty)
 176   = tcTyVarScope names (\ tyvars ->
 177         tcContext context       `thenTc` \ theta ->
 178         tcMonoType ty           `thenTc` \ tau ->
 179         returnTc (mkSigmaTy tyvars theta tau)
 180     )
 181   where
 182     names = map de_rn tyvar_names
 183     de_rn (RnName n) = n
 184 \end{code}
 185
 186 Errors and contexts
 187 ~~~~~~~~~~~~~~~~~~~
 188 \begin{code}
 189 naughtyCCallContextErr clas_name sty
 190   = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]
 191 \end{code}