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                           tcExtendTyVarEnv, tcTyVarScope
  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 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 tys)
  82   = mapAndUnzipTc tcMonoTypeKind tys    `thenTc`    \ (arg_kinds, arg_tys) ->
  83
  84     tc_mono_name name                   `thenNF_Tc` \ (fun_kind, fun_ty) ->
  85
  86     newKindVar                          `thenNF_Tc` \ result_kind ->
  87     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
  88
  89         -- Check for saturated application in the special case of
  90         -- type synoyms.  Here the renamer has kindly attached the
  91         -- arity to the Name.
  92     synArityCheck name (length tys)     `thenTc_`
  93
  94     returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
  95
  96 -- for unfoldings only:
  97 tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
  98   = tcExtendTyVarEnv tyvar_names (tc_kinds `zip` tyvars) (
  99         tcMonoTypeKind ty               `thenTc` \ (kind, ty') ->
 100         unifyKind kind mkTcTypeKind     `thenTc_`
 101         returnTc (mkTcTypeKind, ty')
 102     )
 103   where
 104     (tyvar_names, kinds) = unzip tyvars_w_kinds
 105     tyvars   = zipWithEqual mk_tyvar tyvar_names kinds
 106     tc_kinds = map kindToTcKind kinds
 107     mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
 108
 109 -- for unfoldings only:
 110 tcMonoTypeKind (MonoDictTy class_name ty)
 111   = tcMonoTypeKind ty                   `thenTc` \ (arg_kind, arg_ty) ->
 112     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 113     unifyKind class_kind arg_kind       `thenTc_`
 114     returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
 115
 116
 117 tc_mono_name :: Name -> NF_TcM s (TcKind s, Type)
 118 tc_mono_name name@(Short _ _)           -- Must be a type variable
 119   = tcLookupTyVar name                  `thenNF_Tc` \ (kind,tyvar) ->
 120     returnNF_Tc (kind, mkTyVarTy tyvar)
 121
 122 tc_mono_name name | isTyConName name    -- Must be a type constructor
 123   = tcLookupTyCon name                  `thenNF_Tc` \ (kind,tycon) ->
 124     returnNF_Tc (kind, mkTyConTy tycon)
 125
 126 tc_mono_name name                       -- Renamer should have got it right
 127   = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
 128 \end{code}
 129
 130
 131 Contexts
 132 ~~~~~~~~
 133 \begin{code}
 134
 135 tcContext :: RenamedContext -> TcM s ThetaType
 136 tcContext context = mapTc tcClassAssertion context
 137
 138 tcClassAssertion (class_name, tyvar_name)
 139   = checkTc (canBeUsedInContext class_name)
 140             (naughtyCCallContextErr class_name) `thenTc_`
 141
 142     tcLookupClass class_name            `thenNF_Tc` \ (class_kind, clas) ->
 143     tcLookupTyVar tyvar_name            `thenNF_Tc` \ (tyvar_kind, tyvar) ->
 144
 145     unifyKind class_kind tyvar_kind     `thenTc_`
 146
 147     returnTc (clas, mkTyVarTy tyvar)
 148 \end{code}
 149
 150 HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@
 151 could be used in contexts such as:
 152 \begin{verbatim}
 153 foo :: _CCallable a => a -> PrimIO Int
 154 \end{verbatim}
 155
 156 Doing this utterly wrecks the whole point of introducing these
 157 classes so we specifically check that this isn't being done.
 158
 159 \begin{code}
 160 canBeUsedInContext :: Name -> Bool
 161 canBeUsedInContext (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys)
 162 canBeUsedInContext other                = True
 163 \end{code}
 164
 165
 166 Polytypes
 167 ~~~~~~~~~
 168 \begin{code}
 169 tcPolyType :: RenamedPolyType -> TcM s Type
 170 tcPolyType (HsForAllTy tyvar_names context ty)
 171   = tcTyVarScope tyvar_names (\ tyvars ->
 172         tcContext context       `thenTc` \ theta ->
 173         tcMonoType ty           `thenTc` \ tau ->
 174         returnTc (mkSigmaTy tyvars theta tau)
 175     )
 176 \end{code}
 177
 178 Auxilliary functions
 179 ~~~~~~~~~~~~~~~~~~~~
 180 \begin{code}
 181 synArityCheck :: Name -> Int -> TcM s ()
 182 synArityCheck name n_args
 183   = case getSynNameArity name of
 184         Just arity | arity /= n_args -> failTc (err arity)
 185         other                        -> returnTc ()
 186   where
 187     err arity = arityErr "Type synonym constructor" name arity n_args
 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}