\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType,
+module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
tcContext, tcHsTyVar, kcHsTyVar,
tcExtendTyVarScope, tcExtendTopTyVarScope,
- TcSigInfo(..), tcTySig, mkTcSig, noSigs, maybeSig,
+ TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
checkSigTyVars, sigCtxt, sigPatCtxt
) where
#include "HsVersions.h"
-import HsSyn ( HsType(..), HsTyVar(..), Sig(..), pprClassAssertion, pprParendHsType )
+import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..),
+ Sig(..), pprClassAssertion, pprParendHsType )
import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
import TcHsSyn ( TcId )
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
- tcGetGlobalTyVars, TcTyThing(..)
+ tcExtendUVarEnv, tcLookupUVar,
+ tcGetGlobalTyVars, valueEnvIds, TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
- typeToTcType, tcInstTcType, kindToTcKind,
- newKindVar,
+ typeToTcType, kindToTcKind,
+ newKindVar, tcInstSigVar,
zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
-import Type ( Type, ThetaType,
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys,
- mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitRhoTy,
+import Type ( Type, ThetaType, UsageAnn(..),
+ mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
+ mkUsForAllTy, zipFunTys,
+ mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
boxedTypeKind, unboxedTypeKind, tyVarsOfType,
mkArrowKinds, getTyVar_maybe, getTyVar,
tidyOpenType, tidyOpenTypes, tidyTyVar
)
-import Id ( mkUserId, idName, idType, idFreeTyVars )
-import Var ( TyVar, mkTyVar )
+import Subst ( mkTopTyVarSubst, substTy )
+import Id ( mkVanillaId, idName, idType, idFreeTyVars )
+import Var ( TyVar, mkTyVar, mkNamedUVar )
import VarEnv
import VarSet
import Bag ( bagToList )
import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
-import UniqFM ( eltsUFM )
import Util ( zipWithEqual, zipLazy, mapAccumL )
import Outputable
\end{code}
tc_type ty `thenTc` \ ty' ->
forkNF_Tc (zonkTcTypeToType ty')
+tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
+tcHsTopTypeKind ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_type_kind ty `thenTc` \ (kind, ty') ->
+ forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ zonked_ty ->
+ returnNF_Tc (kind, zonked_ty)
+
tcHsTopBoxedType :: RenamedHsType -> TcM s Type
tcHsTopBoxedType ty
= -- tcAddErrCtxt (typeCtxt ty) $
= tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
returnTc (boxedTypeKind, mkDictTy clas arg_tys)
-tc_type_kind (HsForAllTy tv_names context ty)
+tc_type_kind (MonoUsgTy usg ty)
+ = newUsg usg `thenTc` \ usg' ->
+ tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsgTy usg' tc_ty)
+ where
+ newUsg usg = case usg of
+ MonoUsOnce -> returnTc UsOnce
+ MonoUsMany -> returnTc UsMany
+ MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv ->
+ returnTc (UsVar uv)
+
+tc_type_kind (MonoUsgForAllTy uv_name ty)
+ = let
+ uv = mkNamedUVar uv_name
+ in
+ tcExtendUVarEnv uv_name uv $
+ tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsForAllTy uv tc_ty)
+
+tc_type_kind (HsForAllTy (Just tv_names) context ty)
= tcExtendTyVarScope tv_names $ \ tyvars ->
tcContext context `thenTc` \ theta ->
- tc_boxed_type ty `thenTc` \ tau ->
- -- Body of a for-all is a boxed type!
- returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau)
+ tc_type_kind ty `thenTc` \ (kind, tau) ->
+ let
+ body_kind | null theta = kind
+ | otherwise = boxedTypeKind
+ -- Context behaves like a function type
+ -- This matters. Return-unboxed-tuple analysis can
+ -- give overloaded functions like
+ -- f :: forall a. Num a => (# a->a, a->a #)
+ -- And we want these to get through the type checker
+ in
+ returnTc (body_kind, mkSigmaTy tyvars theta tau)
\end{code}
Help functions for type applications
maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
| name == sig_name = Just sig
| otherwise = maybeSig sigs name
-
--- This little helper is useful to pass to tcPat
-noSigs :: Name -> Maybe TcId
-noSigs name = Nothing
\end{code}
tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
tcHsType ty `thenTc` \ sigma_tc_ty ->
- mkTcSig (mkUserId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
+ mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
returnTc sig
mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo
-- the tyvars *do* get unified with something, we want to carry on
-- typechecking the rest of the program with the function bound
-- to a pristine type, namely sigma_tc_ty
- tcInstTcType (idType poly_id) `thenNF_Tc` \ (tyvars, rho) ->
let
- (theta, tau) = splitRhoTy rho
- -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
+ (tyvars, rho) = splitForAllTys (idType poly_id)
+ in
+ mapNF_Tc tcInstSigVar tyvars `thenNF_Tc` \ tyvars' ->
+ -- Make *signature* type variables
+
+ let
+ tyvar_tys' = mkTyVarTys tyvars'
+ rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho
+ -- mkTopTyVarSubst because the tyvars' are fresh
+ (theta', tau') = splitRhoTy rho'
+ -- This splitRhoTy tries hard to make sure that tau' is a type synonym
-- wherever possible, which can improve interface files.
in
newMethodWithGivenTy SignatureOrigin
poly_id
- (mkTyVarTys tyvars)
- theta tau `thenNF_Tc` \ inst ->
+ tyvar_tys'
+ theta' tau' `thenNF_Tc` \ inst ->
-- We make a Method even if it's not overloaded; no harm
- returnNF_Tc (TySigInfo name poly_id tyvars theta tau (instToIdBndr inst) inst src_loc)
+ returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToIdBndr inst) inst src_loc)
where
name = idName poly_id
\end{code}
if tv `elemVarSet` globals -- Error (c)! Type variable escapes
-- The least comprehensible, so put it last
then tcGetValueEnv `thenNF_Tc` \ ve ->
- find_globals tv env (eltsUFM ve) `thenNF_Tc` \ (env1, globs) ->
+ find_globals tv env (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) ->
returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
else -- All OK
projects / ghc-hetmet.git / blobdiff