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 module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsType(..), HsTyVar(..), pprContext )
  12 import RnHsSyn          ( RenamedHsType(..), RenamedContext(..) )
  13
  14 import TcMonad
  15 import TcEnv            ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv )
  16 import TcKind           ( TcKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind,
  17                           unifyKind, unifyKinds, newKindVar,
  18                           kindToTcKind, tcDefaultKind
  19                         )
  20 import Type             ( Type, ThetaType,
  21                           mkTyVarTy, mkFunTy, mkSynTy,
  22                           mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys
  23                         )
  24 import TyVar            ( TyVar, mkTyVar )
  25 import PrelInfo         ( cCallishClassKeys )
  26 import TyCon            ( TyCon )
  27 import Name             ( Name, OccName, isTvOcc, getOccName )
  28 import TysWiredIn       ( mkListTy, mkTupleTy )
  29 import Unique           ( Unique, Uniquable(..) )
  30 import Util             ( zipWithEqual, zipLazy )
  31 import Outputable
  32 \end{code}
  33
  34
  35 tcHsType and tcHsTypeKind
  36 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  37
  38 tcHsType checks that the type really is of kind Type!
  39
  40 \begin{code}
  41 tcHsType :: RenamedHsType -> TcM s Type
  42
  43 tcHsType ty
  44   = tcAddErrCtxt (typeCtxt ty)          $
  45     tc_hs_type ty
  46
  47 tc_hs_type ty
  48   = tc_hs_type_kind ty                  `thenTc` \ (kind,ty) ->
  49         -- Check that it really is a type
  50     unifyKind mkTypeKind kind           `thenTc_`
  51     returnTc ty
  52 \end{code}
  53
  54 tcHsTypeKind does the real work.  It returns a kind and a type.
  55
  56 \begin{code}
  57 tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
  58
  59 tcHsTypeKind ty
  60   = tcAddErrCtxt (typeCtxt ty)          $
  61     tc_hs_type_kind ty
  62
  63
  64         -- This equation isn't needed (the next one would handle it fine)
  65         -- but it's rather a common case, so we handle it directly
  66 tc_hs_type_kind (MonoTyVar name)
  67   | isTvOcc (getOccName name)
  68   = tcLookupTyVar name                  `thenNF_Tc` \ (kind,tyvar) ->
  69     returnTc (kind, mkTyVarTy tyvar)
  70
  71 tc_hs_type_kind ty@(MonoTyVar name)
  72   = tcFunType ty []
  73
  74 tc_hs_type_kind (MonoListTy _ ty)
  75   = tc_hs_type ty       `thenTc` \ tau_ty ->
  76     returnTc (mkBoxedTypeKind, mkListTy tau_ty)
  77
  78 tc_hs_type_kind (MonoTupleTy _ tys)
  79   = mapTc tc_hs_type  tys       `thenTc` \ tau_tys ->
  80     returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys)
  81
  82 tc_hs_type_kind (MonoFunTy ty1 ty2)
  83   = tc_hs_type ty1      `thenTc` \ tau_ty1 ->
  84     tc_hs_type ty2      `thenTc` \ tau_ty2 ->
  85     returnTc (mkBoxedTypeKind, mkFunTy tau_ty1 tau_ty2)
  86
  87 tc_hs_type_kind (MonoTyApp ty1 ty2)
  88   = tcTyApp ty1 [ty2]
  89
  90 tc_hs_type_kind (HsForAllTy tv_names context ty)
  91   = tcTyVarScope tv_names                       $ \ tyvars ->
  92         tcContext context                       `thenTc` \ theta ->
  93         tc_hs_type ty                           `thenTc` \ tau ->
  94                 -- For-all's are of kind type!
  95         returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau)
  96
  97 -- for unfoldings, and instance decls, only:
  98 tc_hs_type_kind (MonoDictTy class_name tys)
  99   = mapAndUnzipTc tc_hs_type_kind tys   `thenTc` \ (arg_kinds, arg_tys) ->
 100     tcLookupClass class_name            `thenTc` \ (class_kinds, clas) ->
 101     let
 102         arity  = length class_kinds
 103         n_args = length arg_kinds
 104         err = arityErr "Class" class_name arity n_args
 105     in
 106     checkTc (arity == n_args) err       `thenTc_`
 107     unifyKinds class_kinds arg_kinds    `thenTc_`
 108     returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)
 109 \end{code}
 110
 111 Help functions for type applications
 112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 113 \begin{code}
 114 tcTyApp (MonoTyApp ty1 ty2) tys
 115   = tcTyApp ty1 (ty2:tys)
 116
 117 tcTyApp ty tys
 118   | null tys
 119   = tcFunType ty []
 120
 121   | otherwise
 122   = mapAndUnzipTc tc_hs_type_kind tys   `thenTc` \ (arg_kinds, arg_tys) ->
 123     tcFunType ty arg_tys                `thenTc` \ (fun_kind, result_ty) ->
 124
 125         -- Check argument compatibility
 126     newKindVar                          `thenNF_Tc` \ result_kind ->
 127     unifyKind fun_kind (foldr mkArrowKind result_kind arg_kinds)
 128                                         `thenTc_`
 129     returnTc (result_kind, result_ty)
 130
 131 -- (tcFunType ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
 132 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
 133 --      hence the rather strange functionality.
 134
 135 tcFunType (MonoTyVar name) arg_tys
 136   | isTvOcc (getOccName name)   -- Must be a type variable
 137   = tcLookupTyVar name                  `thenNF_Tc` \ (kind,tyvar) ->
 138     returnTc (kind, mkAppTys (mkTyVarTy tyvar) arg_tys)
 139
 140   | otherwise                   -- Must be a type constructor
 141   = tcLookupTyCon name                  `thenTc` \ (tycon_kind,maybe_arity, tycon) ->
 142     case maybe_arity of
 143         Nothing    ->   -- Data type or newtype
 144                       returnTc (tycon_kind, mkTyConApp tycon arg_tys)
 145
 146         Just arity ->   -- Type synonym
 147                       checkTc (arity <= n_args) err_msg `thenTc_`
 148                       returnTc (tycon_kind, result_ty)
 149                    where
 150                         -- It's OK to have an *over-applied* type synonym
 151                         --      data Tree a b = ...
 152                         --      type Foo a = Tree [a]
 153                         --      f :: Foo a b -> ...
 154                       result_ty = mkAppTys (mkSynTy tycon (take arity arg_tys))
 155                                            (drop arity arg_tys)
 156                       err_msg = arityErr "Type synonym constructor" name arity n_args
 157                       n_args  = length arg_tys
 158
 159 tcFunType ty arg_tys
 160   = tc_hs_type_kind ty          `thenTc` \ (fun_kind, fun_ty) ->
 161     returnTc (fun_kind, mkAppTys fun_ty arg_tys)
 162 \end{code}
 163
 164
 165 Contexts
 166 ~~~~~~~~
 167 \begin{code}
 168
 169 tcContext :: RenamedContext -> TcM s ThetaType
 170 tcContext context = tcAddErrCtxt (thetaCtxt context) $
 171                     mapTc tcClassAssertion context
 172
 173 tcClassAssertion (class_name, tys)
 174   = checkTc (canBeUsedInContext class_name)
 175             (naughtyCCallContextErr class_name) `thenTc_`
 176
 177     tcLookupClass class_name            `thenTc` \ (class_kinds, clas) ->
 178     mapAndUnzipTc tc_hs_type_kind tys   `thenTc` \ (ty_kinds, tc_tys) ->
 179
 180     unifyKinds class_kinds ty_kinds     `thenTc_`
 181
 182     returnTc (clas, tc_tys)
 183 \end{code}
 184
 185 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
 186 could be used in contexts such as:
 187 \begin{verbatim}
 188 foo :: CCallable a => a -> PrimIO Int
 189 \end{verbatim}
 190
 191 Doing this utterly wrecks the whole point of introducing these
 192 classes so we specifically check that this isn't being done.
 193
 194 \begin{code}
 195 canBeUsedInContext :: Name -> Bool
 196 canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
 197 \end{code}
 198
 199 Type variables, with knot tying!
 200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 201 \begin{code}
 202 tcTyVarScope
 203         :: [HsTyVar Name]               -- Names of some type variables
 204         -> ([TyVar] -> TcM s a)         -- Thing to type check in their scope
 205         -> TcM s a                      -- Result
 206
 207 tcTyVarScope tyvar_names thing_inside
 208   = mapAndUnzipNF_Tc tcHsTyVar tyvar_names      `thenNF_Tc` \ (names, kinds) ->
 209
 210     fixTc (\ ~(rec_tyvars, _) ->
 211                 -- Ok to look at names, kinds, but not tyvars!
 212
 213         tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
 214                          (thing_inside rec_tyvars)              `thenTc` \ result ->
 215
 216                 -- Get the tyvar's Kinds from their TcKinds
 217         mapNF_Tc tcDefaultKind kinds                            `thenNF_Tc` \ kinds' ->
 218
 219                 -- Construct the real TyVars
 220         let
 221           tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
 222         in
 223         returnTc (tyvars, result)
 224     )                                   `thenTc` \ (_,result) ->
 225     returnTc result
 226
 227 tcHsTyVar (UserTyVar name)
 228   = newKindVar          `thenNF_Tc` \ tc_kind ->
 229     returnNF_Tc (name, tc_kind)
 230 tcHsTyVar (IfaceTyVar name kind)
 231   = returnNF_Tc (name, kindToTcKind kind)
 232 \end{code}
 233
 234 Errors and contexts
 235 ~~~~~~~~~~~~~~~~~~~
 236 \begin{code}
 237 naughtyCCallContextErr clas_name
 238   = sep [ptext SLIT("Can't use class"), quotes (ppr clas_name), ptext SLIT("in a context")]
 239
 240 typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
 241
 242 thetaCtxt theta = ptext SLIT("In the context") <+> quotes (pprContext theta)
 243 \end{code}