\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-#include "HsVersions.h"
-
-module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
+module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
-import Ubiq{-uitous-}
-
-import HsSyn ( PolyType(..), MonoType(..), Fake )
-import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
- RenamedContext(..)
- )
+#include "HsVersions.h"
+import HsSyn ( HsType(..), HsTyVar(..), pprContext )
+import RnHsSyn ( RenamedHsType(..), RenamedContext(..) )
import TcMonad
-import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
- tcTyVarScope, tcTyVarScopeGivenKinds
- )
-import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
- mkTcArrowKind, unifyKind, newKindVar,
- kindToTcKind
+import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv )
+import TcKind ( TcKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind,
+ unifyKind, unifyKinds, newKindVar,
+ kindToTcKind, tcDefaultKind
)
-import Type ( GenType, Type(..), ThetaType(..),
- mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
- mkSigmaTy
+import Type ( Type, ThetaType,
+ mkTyVarTy, mkFunTy, mkSynTy,
+ mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys
)
-import TyVar ( GenTyVar, TyVar(..), mkTyVar )
-import PrelInfo ( mkListTy, mkTupleTy )
-import Type ( mkDictTy )
-import Class ( cCallishClassKeys )
-import TyCon ( TyCon, Arity(..) )
-import Unique ( Unique )
-import Name ( Name(..), getNameShortName, isTyConName, getSynNameArity )
-import PprStyle
-import Pretty
-import Util ( zipWithEqual, panic )
+import TyVar ( TyVar, mkTyVar )
+import PrelInfo ( cCallishClassKeys )
+import TyCon ( TyCon )
+import Name ( Name, OccName, isTvOcc, getOccName )
+import TysWiredIn ( mkListTy, mkTupleTy )
+import Unique ( Unique, Uniquable(..) )
+import Util ( zipWithEqual, zipLazy )
+import Outputable
\end{code}
-tcMonoType and tcMonoTypeKind
+tcHsType and tcHsTypeKind
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcMonoType checks that the type really is of kind Type!
+tcHsType checks that the type really is of kind Type!
\begin{code}
-tcMonoType :: RenamedMonoType -> TcM s Type
+tcHsType :: RenamedHsType -> TcM s Type
-tcMonoType ty
- = tcMonoTypeKind ty `thenTc` \ (kind,ty) ->
- unifyKind kind mkTcTypeKind `thenTc_`
+tcHsType ty
+ = tcAddErrCtxt (typeCtxt ty) $
+ tc_hs_type ty
+
+tc_hs_type ty
+ = tc_hs_type_kind ty `thenTc` \ (kind,ty) ->
+ -- Check that it really is a type
+ unifyKind mkTypeKind kind `thenTc_`
returnTc ty
\end{code}
-tcMonoTypeKind does the real work. It returns a kind and a type.
+tcHsTypeKind does the real work. It returns a kind and a type.
\begin{code}
-tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
-
-tcMonoTypeKind (MonoTyVar name)
- = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- returnTc (kind, mkTyVarTy tyvar)
-
+tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
-tcMonoTypeKind (MonoListTy ty)
- = tcMonoType ty `thenTc` \ tau_ty ->
- returnTc (mkTcTypeKind, mkListTy tau_ty)
+tcHsTypeKind ty
+ = tcAddErrCtxt (typeCtxt ty) $
+ tc_hs_type_kind ty
-tcMonoTypeKind (MonoTupleTy tys)
- = mapTc tcMonoType tys `thenTc` \ tau_tys ->
- returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
-tcMonoTypeKind (MonoFunTy ty1 ty2)
- = tcMonoType ty1 `thenTc` \ tau_ty1 ->
- tcMonoType ty2 `thenTc` \ tau_ty2 ->
- returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
-
-tcMonoTypeKind (MonoTyApp name@(Short _ _) tys)
- = -- Must be a type variable
- tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- tcMonoTyApp kind (mkTyVarTy tyvar) tys
+ -- This equation isn't needed (the next one would handle it fine)
+ -- but it's rather a common case, so we handle it directly
+tc_hs_type_kind (MonoTyVar name)
+ | isTvOcc (getOccName name)
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ returnTc (kind, mkTyVarTy tyvar)
-tcMonoTypeKind (MonoTyApp name tys)
- | isTyConName name -- Must be a type constructor
- = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
- case maybe_arity of
- Just arity -> tcSynApp name kind arity tycon tys -- synonum
- Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
-
--- for unfoldings only:
-tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
- = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
- tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
- unifyKind kind mkTcTypeKind `thenTc_`
- returnTc (mkTcTypeKind, ty')
- )
- where
- (names, kinds) = unzip tyvars_w_kinds
- tc_kinds = map kindToTcKind kinds
-
--- for unfoldings only:
-tcMonoTypeKind (MonoDictTy class_name ty)
- = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
- tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
- unifyKind class_kind arg_kind `thenTc_`
- returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
+tc_hs_type_kind ty@(MonoTyVar name)
+ = tcFunType ty []
+
+tc_hs_type_kind (MonoListTy _ ty)
+ = tc_hs_type ty `thenTc` \ tau_ty ->
+ returnTc (mkBoxedTypeKind, mkListTy tau_ty)
+
+tc_hs_type_kind (MonoTupleTy _ tys)
+ = mapTc tc_hs_type tys `thenTc` \ tau_tys ->
+ returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys)
+
+tc_hs_type_kind (MonoFunTy ty1 ty2)
+ = tc_hs_type ty1 `thenTc` \ tau_ty1 ->
+ tc_hs_type ty2 `thenTc` \ tau_ty2 ->
+ returnTc (mkBoxedTypeKind, mkFunTy tau_ty1 tau_ty2)
+
+tc_hs_type_kind (MonoTyApp ty1 ty2)
+ = tcTyApp ty1 [ty2]
+
+tc_hs_type_kind (HsForAllTy tv_names context ty)
+ = tcTyVarScope tv_names $ \ tyvars ->
+ tcContext context `thenTc` \ theta ->
+ tc_hs_type ty `thenTc` \ tau ->
+ -- For-all's are of kind type!
+ returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau)
+
+-- for unfoldings, and instance decls, only:
+tc_hs_type_kind (MonoDictTy class_name tys)
+ = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
+ returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)
\end{code}
Help functions for type applications
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcMonoTyApp fun_kind fun_ty tys
- = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
- newKindVar `thenNF_Tc` \ result_kind ->
- unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
- returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
-
-tcSynApp name syn_kind arity tycon tys
- = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
- newKindVar `thenNF_Tc` \ result_kind ->
- unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
-
- -- Check that it's applied to the right number of arguments
- checkTc (arity == n_args) (err arity) `thenTc_`
- returnTc (result_kind, mkSynTy tycon arg_tys)
- where
- err arity = arityErr "Type synonym constructor" name arity n_args
- n_args = length tys
-\end{code}
+tcTyApp (MonoTyApp ty1 ty2) tys
+ = tcTyApp ty1 (ty2:tys)
+tcTyApp ty tys
+ | null tys
+ = tcFunType ty []
-Contexts
-~~~~~~~~
-\begin{code}
-
-tcContext :: RenamedContext -> TcM s ThetaType
-tcContext context = mapTc tcClassAssertion context
+ | otherwise
+ = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
-tcClassAssertion (class_name, tyvar_name)
- = checkTc (canBeUsedInContext class_name)
- (naughtyCCallContextErr class_name) `thenTc_`
+ -- Check argument compatibility
+ newKindVar `thenNF_Tc` \ result_kind ->
+ unifyKind fun_kind (foldr mkArrowKind result_kind arg_kinds)
+ `thenTc_`
+ returnTc (result_kind, result_ty)
- tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
- tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, tyvar) ->
+-- (tcFunType ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
+-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
+-- hence the rather strange functionality.
- unifyKind class_kind tyvar_kind `thenTc_`
+tcFunType (MonoTyVar name) arg_tys
+ | isTvOcc (getOccName name) -- Must be a type variable
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ returnTc (kind, mkAppTys (mkTyVarTy tyvar) arg_tys)
- returnTc (clas, mkTyVarTy tyvar)
+ | otherwise -- Must be a type constructor
+ = tcLookupTyCon name `thenTc` \ (tycon_kind,maybe_arity, tycon) ->
+ case maybe_arity of
+ Nothing -> -- Data type or newtype
+ returnTc (tycon_kind, mkTyConApp tycon arg_tys)
+
+ Just arity -> -- Type synonym
+ checkTc (arity <= n_args) err_msg `thenTc_`
+ returnTc (tycon_kind, result_ty)
+ where
+ -- It's OK to have an *over-applied* type synonym
+ -- data Tree a b = ...
+ -- type Foo a = Tree [a]
+ -- f :: Foo a b -> ...
+ result_ty = mkAppTys (mkSynTy tycon (take arity arg_tys))
+ (drop arity arg_tys)
+ err_msg = arityErr "Type synonym constructor" name arity n_args
+ n_args = length arg_tys
+
+tcFunType ty arg_tys
+ = tc_hs_type_kind ty `thenTc` \ (fun_kind, fun_ty) ->
+ returnTc (fun_kind, mkAppTys fun_ty arg_tys)
\end{code}
-HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@
-could be used in contexts such as:
-\begin{verbatim}
-foo :: _CCallable a => a -> PrimIO Int
-\end{verbatim}
-
-Doing this utterly wrecks the whole point of introducing these
-classes so we specifically check that this isn't being done.
+Contexts
+~~~~~~~~
\begin{code}
-canBeUsedInContext :: Name -> Bool
-canBeUsedInContext (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys)
-canBeUsedInContext other = True
+
+tcContext :: RenamedContext -> TcM s ThetaType
+tcContext context
+ = tcAddErrCtxt (thetaCtxt context) $
+
+ --Someone discovered that @CCallable@ and @CReturnable@
+ -- could be used in contexts such as:
+ -- foo :: CCallable a => a -> PrimIO Int
+ -- Doing this utterly wrecks the whole point of introducing these
+ -- classes so we specifically check that this isn't being done.
+ --
+ -- We *don't* do this check in tcClassAssertion, because that's
+ -- called when checking a HsDictTy, and we don't want to reject
+ -- instance CCallable Int
+ -- etc. Ugh!
+ mapTc check_naughty context `thenTc_`
+
+ mapTc tcClassAssertion context
+
+ where
+ check_naughty (class_name, _)
+ = checkTc (not (uniqueOf class_name `elem` cCallishClassKeys))
+ (naughtyCCallContextErr class_name)
+
+tcClassAssertion (class_name, tys)
+ = tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
+ mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (ty_kinds, tc_tys) ->
+
+ -- Check with kind mis-match
+ let
+ arity = length class_kinds
+ n_tys = length ty_kinds
+ err = arityErr "Class" class_name arity n_tys
+ in
+ checkTc (arity == n_tys) err `thenTc_`
+ unifyKinds class_kinds ty_kinds `thenTc_`
+
+ returnTc (clas, tc_tys)
\end{code}
-Polytypes
-~~~~~~~~~
+Type variables, with knot tying!
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcPolyType :: RenamedPolyType -> TcM s Type
-tcPolyType (HsForAllTy tyvar_names context ty)
- = tcTyVarScope tyvar_names (\ tyvars ->
- tcContext context `thenTc` \ theta ->
- tcMonoType ty `thenTc` \ tau ->
- returnTc (mkSigmaTy tyvars theta tau)
- )
+tcTyVarScope
+ :: [HsTyVar Name] -- Names of some type variables
+ -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
+ -> TcM s a -- Result
+
+tcTyVarScope tyvar_names thing_inside
+ = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
+
+ fixTc (\ ~(rec_tyvars, _) ->
+ -- Ok to look at names, kinds, but not tyvars!
+
+ tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
+ (thing_inside rec_tyvars) `thenTc` \ result ->
+
+ -- Get the tyvar's Kinds from their TcKinds
+ mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
+
+ -- Construct the real TyVars
+ let
+ tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
+ in
+ returnTc (tyvars, result)
+ ) `thenTc` \ (_,result) ->
+ returnTc result
+
+tcHsTyVar (UserTyVar name)
+ = newKindVar `thenNF_Tc` \ tc_kind ->
+ returnNF_Tc (name, tc_kind)
+tcHsTyVar (IfaceTyVar name kind)
+ = returnNF_Tc (name, kindToTcKind kind)
\end{code}
Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
-naughtyCCallContextErr clas_name sty
- = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]
+naughtyCCallContextErr clas_name
+ = sep [ptext SLIT("Can't use class"), quotes (ppr clas_name), ptext SLIT("in a context")]
+
+typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
+
+thetaCtxt theta = ptext SLIT("In the context") <+> quotes (pprContext theta)
\end{code}
projects / ghc-hetmet.git / blobdiff