= tcIdApp fun_name n_args arg_checker res_ty
tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP)
- = do { arg_boxes <- newBoxyTyVars n_args
+ = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
; arg_tys' <- mapM readFilledBox arg_boxes
; args' <- arg_checker arg_tys'
-- Match the result type of the function with the
-- result type of the context, to get an inital substitution
- ; extra_arg_boxes <- newBoxyTyVars n_missing_args
+ ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
res_ty' = mkFunTys extra_arg_tys' res_ty
subst = boxySubMatchType arg_qtvs fun_res_ty res_ty'
--------------------------------
-- Boxy type variables
- newBoxyTyVar, newBoxyTyVars, readFilledBox,
+ newBoxyTyVar, newBoxyTyVars, newBoxyTyVarTys, readFilledBox,
--------------------------------
-- Instantiation
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
MetaDetails(..), SkolemInfo(..), BoxInfo(..),
- BoxyTyVar, BoxyThetaType, BoxySigmaType,
+ BoxyTyVar, BoxyType, BoxyThetaType, BoxySigmaType,
UserTypeCtxt(..),
isMetaTyVar, isSigTyVar, metaTvRef,
tcCmpPred, isClassPred, tcEqType, tcGetTyVar,
pprPred, pprTheta, pprClassPred )
import Kind ( Kind(..), KindVar, kindVarRef, mkKindVar,
isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
- liftedTypeKind, openTypeKind, defaultKind
+ liftedTypeKind, defaultKind
)
import Type ( TvSubst, zipTopTvSubst, substTy )
import Class ( Class, classArity, className )
%************************************************************************
\begin{code}
-newBoxyTyVar :: TcM BoxyTyVar -- Of openTypeKind
-newBoxyTyVar = newMetaTyVar BoxTv openTypeKind
+newBoxyTyVar :: Kind -> TcM BoxyTyVar
+newBoxyTyVar kind = newMetaTyVar BoxTv kind
-newBoxyTyVars :: Int -> TcM [BoxyTyVar] -- Of openTypeKind
-newBoxyTyVars n = sequenceM [newMetaTyVar BoxTv openTypeKind | i <- [1..n]]
+newBoxyTyVars :: [Kind] -> TcM [BoxyTyVar]
+newBoxyTyVars kinds = mapM newBoxyTyVar kinds
+
+newBoxyTyVarTys :: [Kind] -> TcM [BoxyType]
+newBoxyTyVarTys kinds = do { tvs <- mapM newBoxyTyVar kinds; return (mkTyVarTys tvs) }
readFilledBox :: BoxyTyVar -> TcM TcType
-- Read the contents of the box, which should be filled in by now
mkFunTy, mkFunTys, exactTyVarsOfTypes,
tidyOpenTypes )
import VarSet ( elemVarSet, mkVarSet )
-import Kind ( liftedTypeKind )
+import Kind ( liftedTypeKind, openTypeKind )
import TcUnify ( boxySplitTyConApp, boxySplitListTy,
unBox, stripBoxyType, zapToMonotype,
boxyMatchTypes, boxyUnify, boxyUnifyList, checkSigTyVarsWrt )
find_inst tv
| not (tv `elemVarSet` res_tvs) = return (mkTyVarTy tv)
| Just boxy_ty <- lookupTyVar subst tv = return boxy_ty
- | otherwise = do { tv <- newBoxyTyVar
+ | otherwise = do { tv <- newBoxyTyVar openTypeKind
; return (mkTyVarTy tv) }
; pat_tys' <- mapM find_inst pat_tvs
import TcMType ( lookupTcTyVar, LookupTyVarResult(..),
tcInstSkolType, newKindVar, newMetaTyVar,
- tcInstBoxy, newBoxyTyVar, readFilledBox,
+ tcInstBoxy, newBoxyTyVar, newBoxyTyVarTys, readFilledBox,
readMetaTyVar, writeMetaTyVar, newFlexiTyVarTy,
tcInstSkolTyVars,
zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV,
import VarEnv
import Name ( isSystemName )
import ErrUtils ( Message )
-import Maybes ( fromJust )
+import Maybes ( fromJust, isNothing )
import BasicTypes ( Arity )
import UniqSupply ( uniqsFromSupply )
import Util ( notNull, equalLength )
\begin{code}
tcInfer :: (BoxyType -> TcM a) -> TcM (a, TcType)
tcInfer tc_infer
- = do { box <- newBoxyTyVar
+ = do { box <- newBoxyTyVar openTypeKind
; res <- tc_infer (mkTyVarTy box)
; res_ty <- readFilledBox box -- Guaranteed filled-in by now
; return (res, res_ty) }
| Just res_ty' <- tcView res_ty = loop n args_so_far res_ty'
loop n args_so_far res_ty
- | isSigmaTy res_ty -- Do this first, because we guarantee to return
- -- a BoxyRhoType, not a BoxySigmaType
+ | isSigmaTy res_ty -- Do this before checking n==0, because we
+ -- guarantee to return a BoxyRhoType, not a BoxySigmaType
= do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ res_ty' ->
loop n args_so_far res_ty'
; return (gen_fn <.> co_fn, res) }
- loop 0 args_so_far res_ty = do { res <- thing_inside (reverse args_so_far) res_ty
- ; return (idCoercion, res) }
+ loop 0 args_so_far res_ty
+ = do { res <- thing_inside (reverse args_so_far) res_ty
+ ; return (idCoercion, res) }
+
loop n args_so_far (FunTy arg_ty res_ty)
= do { (co_fn, res) <- loop (n-1) (arg_ty:args_so_far) res_ty
; co_fn' <- wrapFunResCoercion [arg_ty] co_fn
; return (co_fn', res) }
+ -- res_ty might have a type variable at the head, such as (a b c),
+ -- in which case we must fill in with (->). Simplest thing to do
+ -- is to use boxyUnify, but we catch failure and generate our own
+ -- error message on failure
+ loop n args_so_far res_ty@(AppTy _ _)
+ = do { [arg_ty',res_ty'] <- newBoxyTyVarTys [argTypeKind, openTypeKind]
+ ; (_, mb_unit) <- tryTcErrs $ boxyUnify res_ty (FunTy arg_ty' res_ty')
+ ; if isNothing mb_unit then bale_out args_so_far res_ty
+ else loop n args_so_far (FunTy arg_ty' res_ty') }
+
loop n args_so_far (TyVarTy tv)
| not (isImmutableTyVar tv)
= do { cts <- readMetaTyVar tv
-- Note argTypeKind: the args can have an unboxed type,
-- but not an unboxed tuple.
- loop n args_so_far res_ty
- = failWithTc (mk_msg (length args_so_far))
+ loop n args_so_far res_ty = bale_out args_so_far res_ty
+
+ bale_out args_so_far res_ty
+ = do { env0 <- tcInitTidyEnv
+ ; res_ty' <- zonkTcType res_ty
+ ; let (env1, res_ty'') = tidyOpenType env0 res_ty'
+ ; failWithTcM (env1, mk_msg res_ty'' (length args_so_far)) }
- mk_msg n_actual
+ mk_msg res_ty n_actual
= error_herald <> comma $$
sep [ptext SLIT("but its type") <+> quotes (pprType res_ty),
if n_actual == 0 then ptext SLIT("has none")
projects / ghc-hetmet.git / commitdiff