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                         )
  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, Type(..), ThetaType(..),
  28                           mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
  29                           mkSigmaTy
  30                         )
  31 import TyVar            ( GenTyVar, TyVar(..), mkTyVar )
  32 import Type             ( mkDictTy )
  33 import Class            ( cCallishClassKeys )
  34 import TyCon            ( TyCon )
  35 import TysWiredIn       ( mkListTy, mkTupleTy )
  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, pprPanic{-ToDo:rm-} )
  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   | otherwise {-isRnTyCon name-}        -- Must be a type constructor
  89   = tcLookupTyCon name                  `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
  90     case maybe_arity of
  91         Just arity -> tcSynApp name kind arity tycon tys        -- synonum
  92         Nothing    -> tcMonoTyApp kind (mkTyConTy tycon) tys    -- newtype or data
  93
  94 --  | otherwise
  95 --  = pprPanic "tcMonoTypeKind:" (ppr PprDebug name)
  96
  97 -- for unfoldings only:
  98 tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
  99   = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
 100         tcMonoTypeKind ty               `thenTc` \ (kind, ty') ->
 101         unifyKind kind mkTcTypeKind     `thenTc_`
 102         returnTc (mkTcTypeKind, ty')
 103     )
 104   where
 105     (rn_names, kinds) = unzip tyvars_w_kinds
 106     names    = map de_rn rn_names
 107     tc_kinds = map kindToTcKind kinds
 108     de_rn (RnName n) = n
 109
 110 -- for unfoldings only:
 111 tcMonoTypeKind (MonoDictTy class_name ty)
 112   = tcMonoTypeKind ty                   `thenTc` \ (arg_kind, arg_ty) ->
 113     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 114     unifyKind class_kind arg_kind       `thenTc_`
 115     returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
 116 \end{code}
 117
 118 Help functions for type applications
 119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 120 \begin{code}
 121 tcMonoTyApp fun_kind fun_ty tys
 122   = mapAndUnzipTc tcMonoTypeKind tys    `thenTc`    \ (arg_kinds, arg_tys) ->
 123     newKindVar                          `thenNF_Tc` \ result_kind ->
 124     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
 125     returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
 126
 127 tcSynApp name syn_kind arity tycon tys
 128   = mapAndUnzipTc tcMonoTypeKind tys    `thenTc`    \ (arg_kinds, arg_tys) ->
 129     newKindVar                          `thenNF_Tc` \ result_kind ->
 130     unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
 131
 132         -- Check that it's applied to the right number of arguments
 133     checkTc (arity == n_args) (err arity)                               `thenTc_`
 134     returnTc (result_kind, mkSynTy tycon arg_tys)
 135   where
 136     err arity = arityErr "Type synonym constructor" name arity n_args
 137     n_args    = length tys
 138 \end{code}
 139
 140
 141 Contexts
 142 ~~~~~~~~
 143 \begin{code}
 144
 145 tcContext :: RenamedContext -> TcM s ThetaType
 146 tcContext context = mapTc tcClassAssertion context
 147
 148 tcClassAssertion (class_name, tyvar_name)
 149   = checkTc (canBeUsedInContext class_name)
 150             (naughtyCCallContextErr class_name) `thenTc_`
 151
 152     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 153     tcLookupTyVar tyvar_name            `thenNF_Tc` \ (tyvar_kind, tyvar) ->
 154
 155     unifyKind class_kind tyvar_kind     `thenTc_`
 156
 157     returnTc (clas, mkTyVarTy tyvar)
 158 \end{code}
 159
 160 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
 161 could be used in contexts such as:
 162 \begin{verbatim}
 163 foo :: CCallable a => a -> PrimIO Int
 164 \end{verbatim}
 165
 166 Doing this utterly wrecks the whole point of introducing these
 167 classes so we specifically check that this isn't being done.
 168
 169 \begin{code}
 170 canBeUsedInContext :: RnName -> Bool
 171 canBeUsedInContext n
 172   = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys)
 173 \end{code}
 174
 175 Polytypes
 176 ~~~~~~~~~
 177 \begin{code}
 178 tcPolyType :: RenamedPolyType -> TcM s Type
 179 tcPolyType (HsForAllTy tyvar_names context ty)
 180   = tcTyVarScope names (\ tyvars ->
 181         tcContext context       `thenTc` \ theta ->
 182         tcMonoType ty           `thenTc` \ tau ->
 183         returnTc (mkSigmaTy tyvars theta tau)
 184     )
 185   where
 186     names = map de_rn tyvar_names
 187     de_rn (RnName n) = n
 188 \end{code}
 189
 190 Errors and contexts
 191 ~~~~~~~~~~~~~~~~~~~
 192 \begin{code}
 193 naughtyCCallContextErr clas_name sty
 194   = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]
 195 \end{code}