From c362e21663e6222c01be3106c80ea9452c4ae222 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 31 Jan 2006 12:24:20 +0000 Subject: [PATCH] Fix TcUnify.subFunTys in AppTy case subFunTys wasn't dealing correctly with the case where the type to be split was of form (a ty1), where a is a type variable. This shows up when compiling Control.Arrow.Transformer.Stream in package arrows. This commit fixes it. --- ghc/compiler/typecheck/TcExpr.lhs | 4 ++-- ghc/compiler/typecheck/TcMType.lhs | 17 ++++++++++------- ghc/compiler/typecheck/TcPat.lhs | 4 ++-- ghc/compiler/typecheck/TcUnify.lhs | 37 ++++++++++++++++++++++++++---------- 4 files changed, 41 insertions(+), 21 deletions(-) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a572d36..0efcd03 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -608,7 +608,7 @@ tcApp (HsVar fun_name) n_args arg_checker res_ty = 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' @@ -648,7 +648,7 @@ tcIdApp fun_name n_args arg_checker res_ty -- 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' diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 88aa753..b8ea73a 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -20,7 +20,7 @@ module TcMType ( -------------------------------- -- Boxy type variables - newBoxyTyVar, newBoxyTyVars, readFilledBox, + newBoxyTyVar, newBoxyTyVars, newBoxyTyVarTys, readFilledBox, -------------------------------- -- Instantiation @@ -57,7 +57,7 @@ import TypeRep ( Type(..), PredType(..), -- Friend; can see representation 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, @@ -72,7 +72,7 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType, 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 ) @@ -303,11 +303,14 @@ zonkSigTyVar sig_tv %************************************************************************ \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 diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 4dc1327..4244763 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -35,7 +35,7 @@ import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, 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 ) @@ -580,7 +580,7 @@ refineAlt pstate con pat_tvs arg_flags pat_res_tys ctxt_res_tys thing_inside 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 diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 2c20d1f..470b532 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -30,7 +30,7 @@ import TypeRep ( Type(..), PredType(..) ) import TcMType ( lookupTcTyVar, LookupTyVarResult(..), tcInstSkolType, newKindVar, newMetaTyVar, - tcInstBoxy, newBoxyTyVar, readFilledBox, + tcInstBoxy, newBoxyTyVar, newBoxyTyVarTys, readFilledBox, readMetaTyVar, writeMetaTyVar, newFlexiTyVarTy, tcInstSkolTyVars, zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV, @@ -67,7 +67,7 @@ import VarSet ( emptyVarSet, mkVarSet, unitVarSet, unionVarSet, elemVarSet, var 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 ) @@ -88,7 +88,7 @@ import TcType ( isBoxyTy, isFlexi ) \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) } @@ -143,19 +143,31 @@ subFunTys error_herald n_pats res_ty thing_inside | 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 @@ -170,10 +182,15 @@ subFunTys error_herald n_pats res_ty thing_inside -- 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") -- 1.7.10.4