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