X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=d933c2f85bd33d5ec9da7379e062c34300978a95;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=4ed8e502c0365b09e52f173cd074061e044c2d68;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 4ed8e50..d933c2f 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -8,36 +8,34 @@ module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( PolyType(..), MonoType(..), Fake ) import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..), - RenamedContext(..) + RenamedContext(..), RnName(..), + isRnLocal, isRnClass, isRnTyCon ) - -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, - tcExtendTyVarEnv, tcTyVarScope + tcTyVarScope, tcTyVarScopeGivenKinds ) import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind, mkTcArrowKind, unifyKind, newKindVar, kindToTcKind ) -import ErrUtils ( arityErr ) -import Type ( GenType, Type(..), ThetaType(..), - mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, - mkSigmaTy +import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType), + mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy, + mkSigmaTy, mkDictTy ) -import TyVar ( GenTyVar, TyVar(..), mkTyVar ) -import PrelInfo ( mkListTy, mkTupleTy ) -import Type ( mkDictTy ) +import TyVar ( GenTyVar, SYN_IE(TyVar) ) import Class ( cCallishClassKeys ) +import TyCon ( TyCon ) +import TysWiredIn ( mkListTy, mkTupleTy ) import Unique ( Unique ) -import Name ( Name(..), getNameShortName, isTyConName, getSynNameArity ) import PprStyle import Pretty -import Util ( zipWithEqual, panic ) +import Util ( zipWithEqual, panic{-, pprPanic ToDo:rm-} ) \end{code} @@ -79,32 +77,31 @@ tcMonoTypeKind (MonoFunTy ty1 ty2) returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2) tcMonoTypeKind (MonoTyApp name tys) - = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> - - tc_mono_name name `thenNF_Tc` \ (fun_kind, fun_ty) -> - - newKindVar `thenNF_Tc` \ result_kind -> - unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_` - - -- Check for saturated application in the special case of - -- type synoyms. Here the renamer has kindly attached the - -- arity to the Name. - synArityCheck name (length tys) `thenTc_` + | isRnLocal name -- Must be a type variable + = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> + tcMonoTyApp kind (mkTyVarTy tyvar) tys - returnTc (result_kind, foldl mkAppTy fun_ty arg_tys) + | otherwise {-isRnTyCon 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 +-- | otherwise +-- = pprPanic "tcMonoTypeKind:" (ppr PprDebug name) + -- for unfoldings only: tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty) - = tcExtendTyVarEnv tyvar_names (tc_kinds `zip` tyvars) ( + = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars -> tcMonoTypeKind ty `thenTc` \ (kind, ty') -> unifyKind kind mkTcTypeKind `thenTc_` returnTc (mkTcTypeKind, ty') ) where - (tyvar_names, kinds) = unzip tyvars_w_kinds - tyvars = zipWithEqual mk_tyvar tyvar_names kinds + (rn_names, kinds) = unzip tyvars_w_kinds + names = map de_rn rn_names tc_kinds = map kindToTcKind kinds - mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind + de_rn (RnName n) = n -- for unfoldings only: tcMonoTypeKind (MonoDictTy class_name ty) @@ -112,19 +109,28 @@ tcMonoTypeKind (MonoDictTy class_name ty) tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) -> unifyKind class_kind arg_kind `thenTc_` returnTc (mkTcTypeKind, mkDictTy clas arg_ty) +\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) -tc_mono_name :: Name -> NF_TcM s (TcKind s, Type) -tc_mono_name name@(Short _ _) -- Must be a type variable - = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> - returnNF_Tc (kind, mkTyVarTy tyvar) +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_` -tc_mono_name name | isTyConName name -- Must be a type constructor - = tcLookupTyCon name `thenNF_Tc` \ (kind,tycon) -> - returnNF_Tc (kind, mkTyConTy tycon) - -tc_mono_name name -- Renamer should have got it right - = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name)) + -- 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} @@ -147,44 +153,34 @@ tcClassAssertion (class_name, tyvar_name) returnTc (clas, mkTyVarTy tyvar) \end{code} -HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@ +HACK warning: Someone discovered that @CCallable@ and @CReturnable@ could be used in contexts such as: \begin{verbatim} -foo :: _CCallable a => a -> PrimIO Int +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 (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys) -canBeUsedInContext other = True +canBeUsedInContext :: RnName -> Bool +canBeUsedInContext n + = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys) \end{code} - Polytypes ~~~~~~~~~ \begin{code} tcPolyType :: RenamedPolyType -> TcM s Type tcPolyType (HsForAllTy tyvar_names context ty) - = tcTyVarScope tyvar_names (\ tyvars -> + = tcTyVarScope names (\ tyvars -> tcContext context `thenTc` \ theta -> tcMonoType ty `thenTc` \ tau -> returnTc (mkSigmaTy tyvars theta tau) ) -\end{code} - -Auxilliary functions -~~~~~~~~~~~~~~~~~~~~ -\begin{code} -synArityCheck :: Name -> Int -> TcM s () -synArityCheck name n_args - = case getSynNameArity name of - Just arity | arity /= n_args -> failTc (err arity) - other -> returnTc () where - err arity = arityErr "Type synonym constructor" name arity n_args + names = map de_rn tyvar_names + de_rn (RnName n) = n \end{code} Errors and contexts