X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=ed35d0863400b51156f9eeae384d394707868a2c;hb=f93c225a0f8343dc17a5d569cfc0b4a35eba0b60;hp=f426434d28823b5cfd88b40b67d9d04e2e8c61d3;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index f426434..ed35d08 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,34 +4,31 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -#include "HsVersions.h" - module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( HsType(..), HsTyVar(..), Fake ) +import HsSyn ( HsType(..), HsTyVar(..), pprContext ) import RnHsSyn ( RenamedHsType(..), RenamedContext(..) ) import TcMonad import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv ) -import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind, - mkTcArrowKind, unifyKind, newKindVar, +import TcKind ( TcKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind, + unifyKind, unifyKinds, newKindVar, kindToTcKind, tcDefaultKind ) -import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType), - mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy, - mkSigmaTy, mkDictTy +import Type ( Type, ThetaType, + mkTyVarTy, mkFunTy, mkSynTy, + mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys ) -import TyVar ( GenTyVar, SYN_IE(TyVar), mkTyVar ) +import TyVar ( TyVar, mkTyVar ) import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) -import Name ( Name, OccName, isTvOcc ) +import Name ( Name, OccName, isTvOcc, getOccName ) import TysWiredIn ( mkListTy, mkTupleTy ) -import Unique ( Unique ) -import PprStyle -import Pretty -import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} ) +import Unique ( Unique, Uniquable(..) ) +import Util ( zipWithEqual, zipLazy ) +import Outputable \end{code} @@ -44,8 +41,13 @@ tcHsType checks that the type really is of kind Type! tcHsType :: RenamedHsType -> TcM s Type tcHsType ty - = tcHsTypeKind ty `thenTc` \ (kind,ty) -> - unifyKind kind mkTcTypeKind `thenTc_` + = 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} @@ -54,70 +56,101 @@ tcHsTypeKind does the real work. It returns a kind and a type. \begin{code} tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type) -tcHsTypeKind (MonoTyVar name) - = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> - returnTc (kind, mkTyVarTy tyvar) - +tcHsTypeKind ty + = tcAddErrCtxt (typeCtxt ty) $ + tc_hs_type_kind ty + -tcHsTypeKind (MonoListTy _ ty) - = tcHsType ty `thenTc` \ tau_ty -> - returnTc (mkTcTypeKind, mkListTy tau_ty) + -- 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) -tcHsTypeKind (MonoTupleTy _ tys) - = mapTc tcHsType tys `thenTc` \ tau_tys -> - returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys) +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) -tcHsTypeKind (MonoFunTy ty1 ty2) - = tcHsType ty1 `thenTc` \ tau_ty1 -> - tcHsType ty2 `thenTc` \ tau_ty2 -> - returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2) +tc_hs_type_kind (MonoTupleTy _ tys) + = mapTc tc_hs_type tys `thenTc` \ tau_tys -> + returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys) -tcHsTypeKind (MonoTyApp name tys) - | isTvOcc (getOccName name) -- Must be a type variable - = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> - tcMonoTyApp kind (mkTyVarTy tyvar) 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) - | otherwise -- Must be a type constructor - = tcLookupTyCon name `thenTc` \ (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 +tc_hs_type_kind (MonoTyApp ty1 ty2) + = tcTyApp ty1 [ty2] -tcHsTypeKind (HsForAllTy tv_names context ty) +tc_hs_type_kind (HsForAllTy tv_names context ty) = tcTyVarScope tv_names $ \ tyvars -> tcContext context `thenTc` \ theta -> - tcHsType ty `thenTc` \ tau -> + tc_hs_type ty `thenTc` \ tau -> -- For-all's are of kind type! - returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau) - --- for unfoldings only: -tcHsTypeKind (MonoDictTy class_name ty) - = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) -> - tcLookupClass class_name `thenTc` \ (class_kind, clas) -> - unifyKind class_kind arg_kind `thenTc_` - returnTc (mkTcTypeKind, mkDictTy clas arg_ty) + 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 tcHsTypeKind 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) +tcTyApp (MonoTyApp ty1 ty2) tys + = tcTyApp ty1 (ty2:tys) + +tcTyApp ty tys + | null tys + = tcFunType ty [] + + | otherwise + = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> + tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) -> -tcSynApp name syn_kind arity tycon tys - = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> + -- Check argument compatibility 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 + unifyKind fun_kind (foldr mkArrowKind result_kind arg_kinds) + `thenTc_` + returnTc (result_kind, result_ty) + +-- (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. + +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) + + | 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} @@ -126,33 +159,44 @@ Contexts \begin{code} tcContext :: RenamedContext -> TcM s ThetaType -tcContext context = mapTc tcClassAssertion context - -tcClassAssertion (class_name, ty) - = checkTc (canBeUsedInContext class_name) - (naughtyCCallContextErr class_name) `thenTc_` - - tcLookupClass class_name `thenTc` \ (class_kind, clas) -> - tcHsTypeKind ty `thenTc` \ (ty_kind, ty) -> - - unifyKind class_kind ty_kind `thenTc_` - - returnTc (clas, ty) +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} -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. - -\begin{code} -canBeUsedInContext :: Name -> Bool -canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys) -\end{code} Type variables, with knot tying! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -192,6 +236,10 @@ tcHsTyVar (IfaceTyVar name kind) 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}