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