\begin{code}
module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType,
- tcContext, tcClassContext,
+ tcContext, tcClassContext, checkAmbiguity,
-- Kind checking
kcHsTyVar, kcHsTyVars, mkTyClTyVars,
#include "HsVersions.h"
-import HsSyn ( HsType(..), HsTyVarBndr(..), HsUsageAnn(..),
+import HsSyn ( HsType(..), HsTyVarBndr(..),
Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig )
import TcHsSyn ( TcId )
import TcMonad
-import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookupTy,
- tcGetEnv, tcEnvTyVars, tcEnvTcIds,
+import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
+ tcLookupGlobal, tcLookup,
+ tcEnvTcIds, tcEnvTyVars,
tcGetGlobalTyVars,
- TyThing(..)
+ TyThing(..), TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
newKindVar, tcInstSigVar,
instFunDeps, instFunDepsOfTheta )
import FunDeps ( tyVarFunDep, oclose )
import TcUnify ( unifyKind, unifyOpenTypeKind )
-import Type ( Type, Kind, PredType(..), ThetaType, UsageAnn(..),
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
- mkUsForAllTy, zipFunTys, hoistForAllTys,
+import Type ( Type, Kind, PredType(..), ThetaType,
+ mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+ zipFunTys, hoistForAllTys,
mkSigmaTy, mkPredTy, mkTyConApp,
mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy,
boxedTypeKind, unboxedTypeKind, mkArrowKind,
mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
tyVarsOfType, tyVarsOfPred, mkForAllTys,
- classesOfPreds, isUnboxedTupleType
+ classesOfPreds,
)
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
-import Id ( mkVanillaId, idName, idType, idFreeTyVars )
-import Var ( TyVar, mkTyVar, tyVarKind )
+import Id ( Id, mkVanillaId, idName, idType, idFreeTyVars )
+import Var ( Var, TyVar, mkTyVar, tyVarKind )
import VarEnv
import VarSet
import ErrUtils ( Message )
-import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind, tyConName )
+import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind )
import Class ( ClassContext, classArity, classTyCon )
-import Name ( Name, isLocallyDefined )
+import Name ( Name )
import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
import UniqFM ( elemUFM )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
import Util ( mapAccumL, isSingleton )
import Outputable
-
+import HscTypes ( TyThing(..) )
\end{code}
returnTc boxedTypeKind
---------------------------
-kcTyVar name -- Could be a tyvar or a tycon
- = tcLookup name `thenTc` \ thing ->
- case thing of {
- ATyVar tv -> returnTc (tyVarKind tv) ;
- AThing k -> returnTc k ;
- AGlobal (ATyCon tc) -> returnTc (tyConKind tc) ;
- other ->
-
- failWithTc (wrongThingErr "type" thing name)
- }}
-
----------------------------
kcFunResType :: RenamedHsType -> TcM TcKind
-- The only place an unboxed tuple type is allowed
-- is at the right hand end of an arrow
kcHsPred pred@(HsPClass cls tys)
= tcAddErrCtxt (appKindCtxt (ppr pred)) $
- tcLookupTy cls `thenNF_Tc` \ thing ->
- (case thing of
- AClass cls -> returnTc (tyConKind (classTyCon cls))
- AThing kind -> returnTc kind
- other -> failWithTc (wrongThingErr "class" (pp_thing thing) cls)) `thenTc` \ kind ->
- mapTc kcHsType tys `thenTc` \ arg_kinds ->
+ kcClass cls `thenTc` \ kind ->
+ mapTc kcHsType tys `thenTc` \ arg_kinds ->
unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind)
+
+---------------------------
+kcTyVar name -- Could be a tyvar or a tycon
+ = tcLookup name `thenTc` \ thing ->
+ case thing of
+ AThing kind -> returnTc kind
+ ATyVar tv -> returnTc (tyVarKind tv)
+ AGlobal (ATyCon tc) -> returnTc (tyConKind tc)
+ other -> failWithTc (wrongThingErr "type" thing name)
+
+kcClass cls -- Must be a class
+ = tcLookup cls `thenNF_Tc` \ thing ->
+ case thing of
+ AThing kind -> returnTc kind
+ AGlobal (AClass cls) -> returnTc (tyConKind (classTyCon cls))
+ other -> failWithTc (wrongThingErr "class" thing cls)
\end{code}
%************************************************************************
tcHsTyVars tv_names kind_check $ \ tyvars ->
tcContext ctxt `thenTc` \ theta ->
tcHsType ty `thenTc` \ tau ->
- checkAmbiguity full_ty tyvars theta tau `thenTc_`
- returnTc (mkSigmaTy tyvars theta tau)
+ checkAmbiguity is_source tyvars theta tau
+ where
+ is_source = case tv_names of
+ (UserTyVar _ : _) -> True
+ other -> False
+checkAmbiguity :: Bool -> [TyVar] -> ThetaType -> Type -> TcM Type
-- Check for ambiguity
-- forall V. P => tau
-- is ambiguous if P contains generic variables
-- even in a scope where b is in scope.
-- This is the is_free test below.
-checkAmbiguity full_ty forall_tyvars theta tau
- = mapTc check_pred theta
- where
- tau_vars = tyVarsOfType tau
- fds = instFunDepsOfTheta theta
- tvFundep = tyVarFunDep fds
- extended_tau_vars = oclose tvFundep tau_vars
-
- is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
- not (ct_var `elemUFM` extended_tau_vars)
- is_free ct_var = not (ct_var `elem` forall_tyvars)
-
- check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_`
- checkTc (not all_free) (freeErr pred full_ty)
- where
- ct_vars = varSetElems (tyVarsOfPred pred)
- all_free = all is_free ct_vars
- any_ambig = is_source_polytype && any is_ambig ct_vars
-
-- Notes on the 'is_source_polytype' test above
-- Check ambiguity only for source-program types, not
-- for types coming from inteface files. The latter can
-- If the list of tv_names is empty, we have a monotype,
-- and then we don't need to check for ambiguity either,
-- because the test can't fail (see is_ambig).
- is_source_polytype
- = case full_ty of
- HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True
- other -> False
+
+checkAmbiguity is_source_polytype forall_tyvars theta tau
+ = mapTc_ check_pred theta `thenTc_`
+ returnTc sigma_ty
+ where
+ sigma_ty = mkSigmaTy forall_tyvars theta tau
+ tau_vars = tyVarsOfType tau
+ fds = instFunDepsOfTheta theta
+ tvFundep = tyVarFunDep fds
+ extended_tau_vars = oclose tvFundep tau_vars
+
+ is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemUFM` extended_tau_vars)
+ is_free ct_var = not (ct_var `elem` forall_tyvars)
+
+ check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_`
+ checkTc (not all_free) (freeErr pred sigma_ty)
+ where
+ ct_vars = varSetElems (tyVarsOfPred pred)
+ all_free = all is_free ct_vars
+ any_ambig = is_source_polytype && any is_ambig ct_vars
\end{code}
Help functions for type applications
-- hence the rather strange functionality.
tc_fun_type name arg_tys
- = tcLookupGlobal name `thenTc` \ thing ->
+ = tcLookup name `thenTc` \ thing ->
case thing of
ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
- ATyCon tc | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_`
- returnTc (mkAppTys (mkSynTy tc (take arity arg_tys))
+ AGlobal (ATyCon tc)
+ | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_`
+ returnTc (mkAppTys (mkSynTy tc (take arity arg_tys))
(drop arity arg_tys))
- | otherwise -> returnTc (mkTyConApp tc arg_tys)
- where
+ | otherwise -> returnTc (mkTyConApp tc arg_tys)
+ where
arity_ok = arity <= n_args
arity = tyConArity tc
err_msg = arityErr "Type synonym" name arity n_args
n_args = length arg_tys
- other -> failWithTc (wrongThingErr "type constructor" (pp_thing thing) name)
+ other -> failWithTc (wrongThingErr "type constructor" thing name)
\end{code}
tcClassAssertion ccall_ok assn@(HsPClass class_name tys)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
mapTc tcHsType tys `thenTc` \ arg_tys ->
- tcLookupTy class_name `thenTc` \ thing ->
+ tcLookupGlobal class_name `thenTc` \ thing ->
case thing of
AClass clas -> checkTc (arity == n_tys) err `thenTc_`
returnTc (Class clas arg_tys)
n_tys = length tys
err = arityErr "Class" class_name arity n_tys
- other -> failWithTc (wrongThingErr "class" (ppr_thing thing) class_name)
+ other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
tcClassAssertion ccall_ok assn@(HsPIParam name ty)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
- check (env, acc, msgs) (sig_tyvar,ty)
+ check (tidy_env, acc, msgs) (sig_tyvar,ty)
-- sig_tyvar is from the signature;
-- ty is what you get if you zonk sig_tyvar and then tidy it
--
-- acc maps a zonked type variable back to a signature type variable
= case getTyVar_maybe ty of {
Nothing -> -- Error (a)!
- returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
+ returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
Just tv ->
case lookupVarEnv acc tv of {
Just sig_tyvar' -> -- Error (b) or (d)!
- returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
+ returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
Nothing ->
if tv `elemVarSet` globals -- Error (c)! Type variable escapes
-- The least comprehensible, so put it last
- then tcGetEnv `thenNF_Tc` \ env ->
- find_globals tv env [] (tcEnvTcIds) `thenNF_Tc` \ (env1, globs) ->
- find_frees tv env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (env2, frees) ->
- returnNF_Tc (env2, acc, escape_msg sig_tyvar tv globs frees : msgs)
+ -- Game plan:
+ -- a) get the local TcIds from the environment,
+ -- and pass them to find_globals (they might have tv free)
+ -- b) similarly, find any free_tyvars that mention tv
+ then tcGetEnv `thenNF_Tc` \ tc_env ->
+ find_globals tv tidy_env [] (tcEnvTcIds tc_env) `thenNF_Tc` \ (tidy_env1, globs) ->
+ find_frees tv tidy_env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (tidy_env2, frees) ->
+ returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs)
else -- All OK
- returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs)
+ returnNF_Tc (tidy_env, extendVarEnv acc tv sig_tyvar, msgs)
}}
-- find_globals looks at the value environment and finds values
-- whose types mention the offending type variable. It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.
+
+find_globals :: Var
+ -> TidyEnv
+ -> [(Name,Type)]
+ -> [Id]
+ -> NF_TcM (TidyEnv,[(Name,Type)])
+
find_globals tv tidy_env acc []
= returnNF_Tc (tidy_env, acc)
find_globals tv tidy_env acc (id:ids)
- | not (isLocallyDefined id) ||
- isEmptyVarSet (idFreeTyVars id)
+ | isEmptyVarSet (idFreeTyVars id)
= find_globals tv tidy_env acc ids
| otherwise
appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp
wrongThingErr expected thing name
- = thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected
-
-pp_ty_thing (ATyCon _) = ptext SLIT("Type constructor")
-pp_ty_thing (AClass _) = ptext SLIT("Class")
-pp_ty_thing (AnId _) = ptext SLIT("Identifier")
-
-pp_tc_ty_thing (ATyVar _) = ptext SLIT("Type variable")
-pp_tc_ty_thing (ATcId _) = ptext SLIT("Local identifier")
-pp_tc_ty_thing (AThing _) = ptext SLIT("Utterly bogus")
+ = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected
+ where
+ pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
+ pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
+ pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
+ pp_thing (ATyVar _) = ptext SLIT("Type variable")
+ pp_thing (ATcId _) = ptext SLIT("Local identifier")
+ pp_thing (AThing _) = ptext SLIT("Utterly bogus")
ambigErr pred ty
= sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
projects / ghc-hetmet.git / blobdiff