Commit c362e216 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent 0c88fe00
......@@ -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'
......
......@@ -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
......
......@@ -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
......
......@@ -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")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment