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 ErrUtils         ( arityErr )
  28 import Type             ( GenType, Type(..), ThetaType(..),
  29                           mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy,
  30                           mkSigmaTy
  31                         )
  32 import TyVar            ( GenTyVar, TyVar(..), mkTyVar )
  33 import PrelInfo         ( mkListTy, mkTupleTy )
  34 import Type             ( mkDictTy )
  35 import Class            ( cCallishClassKeys )
  36 import TyCon            ( TyCon, Arity(..) )
  37 import Unique           ( Unique )
  38 import Name             ( Name(..), getNameShortName, isTyConName, getSynNameArity )
  39 import PprStyle
  40 import Pretty
  41 import Util             ( zipWithEqual, panic )
  42 \end{code}
  43
  44
  45 tcMonoType and tcMonoTypeKind
  46 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  47
  48 tcMonoType checks that the type really is of kind Type!
  49
  50 \begin{code}
  51 tcMonoType :: RenamedMonoType -> TcM s Type
  52
  53 tcMonoType ty
  54   = tcMonoTypeKind ty                   `thenTc` \ (kind,ty) ->
  55     unifyKind kind mkTcTypeKind         `thenTc_`
  56     returnTc ty
  57 \end{code}
  58
  59 tcMonoTypeKind does the real work.  It returns a kind and a type.
  60
  61 \begin{code}
  62 tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
  63
  64 tcMonoTypeKind (MonoTyVar name)
  65   = tcLookupTyVar name  `thenNF_Tc` \ (kind,tyvar) ->
  66     returnTc (kind, mkTyVarTy tyvar)
  67
  68
  69 tcMonoTypeKind (MonoListTy ty)
  70   = tcMonoType ty       `thenTc` \ tau_ty ->
  71     returnTc (mkTcTypeKind, mkListTy tau_ty)
  72
  73 tcMonoTypeKind (MonoTupleTy tys)
  74   = mapTc tcMonoType  tys       `thenTc` \ tau_tys ->
  75     returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
  76
  77 tcMonoTypeKind (MonoFunTy ty1 ty2)
  78   = tcMonoType ty1      `thenTc` \ tau_ty1 ->
  79     tcMonoType ty2      `thenTc` \ tau_ty2 ->
  80     returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
  81
  82 tcMonoTypeKind (MonoTyApp name tys)
  83   = mapAndUnzipTc tcMonoTypeKind tys    `thenTc`    \ (arg_kinds, arg_tys) ->
  84
  85     tc_mono_name name                   `thenNF_Tc` \ (fun_kind, maybe_arity, fun_ty) ->
  86
  87     newKindVar                          `thenNF_Tc` \ result_kind ->
  88     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
  89
  90         -- Check for saturated application in the special case of
  91         -- type synoyms.
  92     (case maybe_arity of
  93         Just arity | arity /= n_args -> failTc (err arity)
  94         other                        -> returnTc ()
  95     )                                                                   `thenTc_`
  96
  97     returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
  98   where
  99     err arity = arityErr "Type synonym constructor" name arity n_args
 100     n_args    = length tys
 101
 102 -- for unfoldings only:
 103 tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
 104   = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
 105         tcMonoTypeKind ty               `thenTc` \ (kind, ty') ->
 106         unifyKind kind mkTcTypeKind     `thenTc_`
 107         returnTc (mkTcTypeKind, ty')
 108     )
 109   where
 110     (names, kinds) = unzip tyvars_w_kinds
 111     tc_kinds = map kindToTcKind kinds
 112
 113 -- for unfoldings only:
 114 tcMonoTypeKind (MonoDictTy class_name ty)
 115   = tcMonoTypeKind ty                   `thenTc` \ (arg_kind, arg_ty) ->
 116     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 117     unifyKind class_kind arg_kind       `thenTc_`
 118     returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
 119
 120
 121 tc_mono_name :: Name -> NF_TcM s (TcKind s, Maybe Arity, Type)
 122 tc_mono_name name@(Short _ _)           -- Must be a type variable
 123   = tcLookupTyVar name                  `thenNF_Tc` \ (kind,tyvar) ->
 124     returnNF_Tc (kind, Nothing, mkTyVarTy tyvar)
 125
 126 tc_mono_name name | isTyConName name    -- Must be a type constructor
 127   = tcLookupTyCon name                  `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
 128     returnNF_Tc (kind, maybe_arity, mkTyConTy tycon)
 129
 130 tc_mono_name name                       -- Renamer should have got it right
 131   = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
 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}