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