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