\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, kindToTcKind,
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
-import Type ( Type, ThetaType,
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys,
+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, fullSubstTy
+ 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 (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 ->
- case theta of
- [] -> -- No context, so propagate body type
- tc_type_kind ty `thenTc` \ (kind, tau) ->
- returnTc (kind, mkSigmaTy tyvars [] tau)
-
- other -> -- Context; behave 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
-
- tc_type ty `thenTc` \ tau ->
- 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
let
tyvar_tys' = mkTyVarTys tyvars'
- rho' = fullSubstTy (zipVarEnv tyvars tyvar_tys') emptyVarSet rho
+ 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.
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