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 PrelInfo         ( cCallishClassKeys )
  28 import TyCon            ( TyCon )
  29 import Name             ( Name, OccName, isTvOcc )
  30 import TysWiredIn       ( mkListTy, mkTupleTy )
  31 import Unique           ( Unique )
  32 import PprStyle
  33 import Pretty
  34 import Util             ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} )
  35 \end{code}
  36
  37
  38 tcHsType and tcHsTypeKind
  39 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  40
  41 tcHsType checks that the type really is of kind Type!
  42
  43 \begin{code}
  44 tcHsType :: RenamedHsType -> TcM s Type
  45
  46 tcHsType ty
  47   = tcHsTypeKind ty                     `thenTc` \ (kind,ty) ->
  48     unifyKind kind mkTcTypeKind         `thenTc_`
  49     returnTc ty
  50 \end{code}
  51
  52 tcHsTypeKind does the real work.  It returns a kind and a type.
  53
  54 \begin{code}
  55 tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
  56
  57 tcHsTypeKind (MonoTyVar name)
  58   = tcLookupTyVar name  `thenNF_Tc` \ (kind,tyvar) ->
  59     returnTc (kind, mkTyVarTy tyvar)
  60
  61
  62 tcHsTypeKind (MonoListTy _ ty)
  63   = tcHsType ty `thenTc` \ tau_ty ->
  64     returnTc (mkTcTypeKind, mkListTy tau_ty)
  65
  66 tcHsTypeKind (MonoTupleTy _ tys)
  67   = mapTc tcHsType  tys `thenTc` \ tau_tys ->
  68     returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
  69
  70 tcHsTypeKind (MonoFunTy ty1 ty2)
  71   = tcHsType ty1        `thenTc` \ tau_ty1 ->
  72     tcHsType ty2        `thenTc` \ tau_ty2 ->
  73     returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
  74
  75 tcHsTypeKind (MonoTyApp name tys)
  76   | isTvOcc (getOccName name)   -- Must be a type variable
  77   = tcLookupTyVar name                  `thenNF_Tc` \ (kind,tyvar) ->
  78     tcMonoTyApp kind (mkTyVarTy tyvar) tys
  79
  80   | otherwise                   -- Must be a type constructor
  81   = tcLookupTyCon name                  `thenTc` \ (kind,maybe_arity,tycon) ->
  82     case maybe_arity of
  83         Just arity -> tcSynApp name kind arity tycon tys        -- synonum
  84         Nothing    -> tcMonoTyApp kind (mkTyConTy tycon) tys    -- newtype or data
  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 tcMonoTyApp fun_kind fun_ty tys
 105   = mapAndUnzipTc tcHsTypeKind tys      `thenTc`    \ (arg_kinds, arg_tys) ->
 106     newKindVar                          `thenNF_Tc` \ result_kind ->
 107     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
 108     returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
 109
 110 tcSynApp name syn_kind arity tycon tys
 111   = mapAndUnzipTc tcHsTypeKind tys      `thenTc`    \ (arg_kinds, arg_tys) ->
 112     newKindVar                          `thenNF_Tc` \ result_kind ->
 113     unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds)      `thenTc_`
 114
 115         -- Check that it's applied to the right number of arguments
 116     checkTc (arity == n_args) (err arity)                               `thenTc_`
 117     returnTc (result_kind, mkSynTy tycon arg_tys)
 118   where
 119     err arity = arityErr "Type synonym constructor" name arity n_args
 120     n_args    = length tys
 121 \end{code}
 122
 123
 124 Contexts
 125 ~~~~~~~~
 126 \begin{code}
 127
 128 tcContext :: RenamedContext -> TcM s ThetaType
 129 tcContext context = mapTc tcClassAssertion context
 130
 131 tcClassAssertion (class_name, ty)
 132   = checkTc (canBeUsedInContext class_name)
 133             (naughtyCCallContextErr class_name) `thenTc_`
 134
 135     tcLookupClass class_name            `thenTc` \ (class_kind, clas) ->
 136     tcHsTypeKind ty                     `thenTc` \ (ty_kind, ty) ->
 137
 138     unifyKind class_kind ty_kind        `thenTc_`
 139
 140     returnTc (clas, ty)
 141 \end{code}
 142
 143 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
 144 could be used in contexts such as:
 145 \begin{verbatim}
 146 foo :: CCallable a => a -> PrimIO Int
 147 \end{verbatim}
 148
 149 Doing this utterly wrecks the whole point of introducing these
 150 classes so we specifically check that this isn't being done.
 151
 152 \begin{code}
 153 canBeUsedInContext :: Name -> Bool
 154 canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
 155 \end{code}
 156
 157 Type variables, with knot tying!
 158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 159 \begin{code}
 160 tcTyVarScope
 161         :: [HsTyVar Name]               -- Names of some type variables
 162         -> ([TyVar] -> TcM s a)         -- Thing to type check in their scope
 163         -> TcM s a                      -- Result
 164
 165 tcTyVarScope tyvar_names thing_inside
 166   = mapAndUnzipNF_Tc tcHsTyVar tyvar_names      `thenNF_Tc` \ (names, kinds) ->
 167
 168     fixTc (\ ~(rec_tyvars, _) ->
 169                 -- Ok to look at names, kinds, but not tyvars!
 170
 171         tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
 172                          (thing_inside rec_tyvars)              `thenTc` \ result ->
 173
 174                 -- Get the tyvar's Kinds from their TcKinds
 175         mapNF_Tc tcDefaultKind kinds                            `thenNF_Tc` \ kinds' ->
 176
 177                 -- Construct the real TyVars
 178         let
 179           tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
 180         in
 181         returnTc (tyvars, result)
 182     )                                   `thenTc` \ (_,result) ->
 183     returnTc result
 184
 185 tcHsTyVar (UserTyVar name)
 186   = newKindVar          `thenNF_Tc` \ tc_kind ->
 187     returnNF_Tc (name, tc_kind)
 188 tcHsTyVar (IfaceTyVar name kind)
 189   = returnNF_Tc (name, kindToTcKind kind)
 190 \end{code}
 191
 192 Errors and contexts
 193 ~~~~~~~~~~~~~~~~~~~
 194 \begin{code}
 195 naughtyCCallContextErr clas_name sty
 196   = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]
 197 \end{code}