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