#include "HsVersions.h"
-import HsSyn ( ExprCoFn(..), idCoercion, isIdCoercion, (<.>),
- mkCoLams, mkCoTyLams, mkCoApps )
+import HsSyn ( HsWrapper(..), idHsWrapper, isIdHsWrapper, (<.>),
+ mkWpLams, mkWpTyLams, mkWpApps )
import TypeRep ( Type(..), PredType(..) )
import TcMType ( lookupTcTyVar, LookupTyVarResult(..),
- tcInstSkolType, tcInstBoxyTyVar, newKindVar, newMetaTyVar,
+ tcInstBoxyTyVar, newKindVar, newMetaTyVar,
newBoxyTyVar, newBoxyTyVarTys, readFilledBox,
readMetaTyVar, writeMetaTyVar, newFlexiTyVarTy,
- tcInstSkolTyVars, tcInstTyVar,
+ tcInstSkolTyVars, tcInstTyVar, tcInstSkolType,
zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV,
readKindVar, writeKindVar )
import TcSimplify ( tcSimplifyCheck )
tidyOpenType, tidyOpenTyVar, tidyOpenTyVars,
pprType, tidyKind, tidySkolemTyVar, isSkolemTyVar, isSigTyVar,
TvSubst, mkTvSubst, zipTyEnv, zipOpenTvSubst, emptyTvSubst,
- substTy, substTheta,
+ substTy, substTheta,
lookupTyVar, extendTvSubst )
import Type ( Kind, SimpleKind, KindVar,
openTypeKind, liftedTypeKind, unliftedTypeKind,
import Inst ( newDictBndrsO, instCall, instToId )
import TyCon ( TyCon, tyConArity, tyConTyVars, isSynTyCon )
import TysWiredIn ( listTyCon )
-import Id ( Id, mkSysLocal )
+import Id ( Id )
import Var ( Var, varName, tyVarKind, isTcTyVar, tcTyVarDetails )
import VarSet
import VarEnv
import ErrUtils ( Message )
import Maybes ( expectJust, isNothing )
import BasicTypes ( Arity )
-import UniqSupply ( uniqsFromSupply )
import Util ( notNull, equalLength )
import Outputable
-> Arity -- Expected # of args
-> BoxyRhoType -- res_ty
-> ([BoxySigmaType] -> BoxyRhoType -> TcM a)
- -> TcM (ExprCoFn, a)
+ -> TcM (HsWrapper, a)
-- Attempt to decompse res_ty to have enough top-level arrows to
-- match the number of patterns in the match group
--
loop n args_so_far res_ty
| 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' ->
+ = 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) }
+ ; return (idHsWrapper, 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
Indirect ty -> loop n args_so_far ty
Flexi -> do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty
; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty
- ; return (idCoercion, res) } }
+ ; return (idHsWrapper, res) } }
where
mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty'
mk_res_ty [] = panic "TcUnify.mk_res_ty1"
go (TyVarTy tv) b_ty
| tv `elemVarSet` tmpl_tvs -- Template type variable in the template
- , not (intersectsVarSet boxy_tvs (tyVarsOfType orig_boxy_ty))
+ , boxy_tvs `disjointVarSet` tyVarsOfType orig_boxy_ty
, typeKind b_ty `isSubKind` tyVarKind tv -- See Note [Matching kinds]
= extendTvSubst subst tv boxy_ty'
| otherwise
\begin{code}
-----------------
-tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only
+tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only
-- (tcSub act exp) checks that
-- act <= exp
tcSubExp actual_ty expected_ty
= -- addErrCtxtM (unifyCtxt actual_ty expected_ty) $
-- Adding the error context here leads to some very confusing error
- -- messages, such as "can't match foarall a. a->a with forall a. a->a"
- -- So instead I'm adding it when moving from tc_sub to u_tys
+ -- messages, such as "can't match forall a. a->a with forall a. a->a"
+ -- Example is tcfail165:
+ -- do var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String))
+ -- putMVar var (show :: forall a. Show a => a -> String)
+ -- Here the info does not flow from the 'var' arg of putMVar to its 'show' arg
+ -- but after zonking it looks as if it does!
+ --
+ -- So instead I'm adding the error context when moving from tc_sub to u_tys
+
traceTc (text "tcSubExp" <+> ppr actual_ty <+> ppr expected_ty) >>
- tc_sub Nothing actual_ty actual_ty False expected_ty expected_ty
+ tc_sub SubOther actual_ty actual_ty False expected_ty expected_ty
-tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only
+tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only
tcFunResTy fun actual_ty expected_ty
= traceTc (text "tcFunResTy" <+> ppr actual_ty <+> ppr expected_ty) >>
- tc_sub (Just fun) actual_ty actual_ty False expected_ty expected_ty
+ tc_sub (SubFun fun) actual_ty actual_ty False expected_ty expected_ty
-----------------
-tc_sub :: Maybe Name -- Just fun => we're looking at a function result type
+data SubCtxt = SubDone -- Error-context already pushed
+ | SubFun Name -- Context is tcFunResTy
+ | SubOther -- Context is something else
+
+tc_sub :: SubCtxt -- How to add an error-context
-> BoxySigmaType -- actual_ty, before expanding synonyms
-> BoxySigmaType -- ..and after
-> InBox -- True <=> expected_ty is inside a box
-> BoxySigmaType -- expected_ty, before
-> BoxySigmaType -- ..and after
- -> TcM ExprCoFn
+ -> TcM HsWrapper
-- The acual_ty is never inside a box
-- IMPORTANT pre-condition: if the args contain foralls, the bound type
-- variables are visible non-monadically
-- This invariant is needed so that we can "see" the foralls, ad
-- e.g. in the SPEC rule where we just use splitSigmaTy
-tc_sub mb_fun act_sty act_ty exp_ib exp_sty exp_ty
- = tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty
+tc_sub sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty
+ = tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty
-- This indirection is just here to make
-- it easy to insert a debug trace!
-tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty
- | Just exp_ty' <- tcView exp_ty = tc_sub mb_fun act_sty act_ty exp_ib exp_sty exp_ty'
-tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty
- | Just act_ty' <- tcView act_ty = tc_sub mb_fun act_sty act_ty' exp_ib exp_sty exp_ty
+tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty
+ | Just exp_ty' <- tcView exp_ty = tc_sub sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty'
+tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty
+ | Just act_ty' <- tcView act_ty = tc_sub sub_ctxt act_sty act_ty' exp_ib exp_sty exp_ty
-----------------------------------
-- Rule SBOXY, plus other cases when act_ty is a type variable
-- Just defer to boxy matching
-- This rule takes precedence over SKOL!
-tc_sub1 mb_fun act_sty (TyVarTy tv) exp_ib exp_sty exp_ty
- = do { addErrCtxtM (subCtxt mb_fun act_sty exp_sty) $
+tc_sub1 sub_ctxt act_sty (TyVarTy tv) exp_ib exp_sty exp_ty
+ = do { addSubCtxt sub_ctxt act_sty exp_sty $
uVar True False tv exp_ib exp_sty exp_ty
- ; return idCoercion }
+ ; return idHsWrapper }
-----------------------------------
-- Skolemisation case (rule SKOL)
-- g :: Ord b => b->b
-- Consider f g !
-tc_sub1 mb_fun act_sty act_ty exp_ib exp_sty exp_ty
+tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty
| not exp_ib, -- SKOL does not apply if exp_ty is inside a box
isSigmaTy exp_ty
- = do { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ body_exp_ty ->
- tc_sub mb_fun act_sty act_ty False body_exp_ty body_exp_ty
+ = do { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ _ body_exp_ty ->
+ tc_sub sub_ctxt act_sty act_ty False body_exp_ty body_exp_ty
; return (gen_fn <.> co_fn) }
where
act_tvs = tyVarsOfType act_ty
-- expected_ty: Int -> Int
-- co_fn e = e Int dOrdInt
-tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty
+tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty
-- Implements the new SPEC rule in the Appendix of the paper
-- "Boxy types: inference for higher rank types and impredicativity"
-- (This appendix isn't in the published version.)
; traceTc (text "tc_sub_spec" <+> vcat [ppr actual_ty,
ppr tyvars <+> ppr theta <+> ppr tau,
ppr tau'])
- ; co_fn2 <- tc_sub mb_fun tau tau exp_ib exp_sty expected_ty
+ ; co_fn2 <- tc_sub sub_ctxt tau' tau' exp_ib exp_sty expected_ty
-- Deal with the dictionaries
- ; co_fn1 <- instCall InstSigOrigin (mkTyVarTys tyvars) theta
- ; co_fn2 <- tc_sub False tau tau exp_sty expected_ty
+ ; co_fn1 <- instCall InstSigOrigin inst_tys (substTheta subst' theta)
; return (co_fn2 <.> co_fn1) }
-----------------------------------
-- Function case (rule F1)
-tc_sub1 mb_fun _ (FunTy act_arg act_res) exp_ib _ (FunTy exp_arg exp_res)
- = tc_sub_funs mb_fun act_arg act_res exp_ib exp_arg exp_res
+tc_sub1 sub_ctxt act_sty (FunTy act_arg act_res) exp_ib exp_sty (FunTy exp_arg exp_res)
+ = addSubCtxt sub_ctxt act_sty exp_sty $
+ tc_sub_funs act_arg act_res exp_ib exp_arg exp_res
-- Function case (rule F2)
-tc_sub1 mb_fun act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv)
+tc_sub1 sub_ctxt act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv)
| isBoxyTyVar exp_tv
- = do { cts <- readMetaTyVar exp_tv
+ = addSubCtxt sub_ctxt act_sty exp_sty $
+ do { cts <- readMetaTyVar exp_tv
; case cts of
- Indirect ty -> tc_sub mb_fun act_sty act_ty True exp_sty ty
+ Indirect ty -> tc_sub SubDone act_sty act_ty True exp_sty ty
Flexi -> do { [arg_ty,res_ty] <- withMetaTvs exp_tv fun_kinds mk_res_ty
- ; tc_sub_funs mb_fun act_arg act_res True arg_ty res_ty } }
+ ; tc_sub_funs act_arg act_res True arg_ty res_ty } }
where
mk_res_ty [arg_ty', res_ty'] = mkFunTy arg_ty' res_ty'
mk_res_ty other = panic "TcUnify.mk_res_ty3"
fun_kinds = [argTypeKind, openTypeKind]
-- Everything else: defer to boxy matching
-tc_sub1 mb_fun act_sty actual_ty exp_ib exp_sty expected_ty
- = do { addErrCtxtM (subCtxt mb_fun act_sty exp_sty) $
+tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty
+ = do { addSubCtxt sub_ctxt act_sty exp_sty $
u_tys True False act_sty actual_ty exp_ib exp_sty expected_ty
- ; return idCoercion }
+ ; return idHsWrapper }
-----------------------------------
-tc_sub_funs mb_fun act_arg act_res exp_ib exp_arg exp_res
+tc_sub_funs act_arg act_res exp_ib exp_arg exp_res
= do { uTys False act_arg exp_ib exp_arg
- ; co_fn_res <- tc_sub mb_fun act_res act_res exp_ib exp_res exp_res
+ ; co_fn_res <- tc_sub SubDone act_res act_res exp_ib exp_res exp_res
; wrapFunResCoercion [exp_arg] co_fn_res }
-----------------------------------
wrapFunResCoercion
:: [TcType] -- Type of args
- -> ExprCoFn -- HsExpr a -> HsExpr b
- -> TcM ExprCoFn -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b)
+ -> HsWrapper -- HsExpr a -> HsExpr b
+ -> TcM HsWrapper -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b)
wrapFunResCoercion arg_tys co_fn_res
- | isIdCoercion co_fn_res = return idCoercion
+ | isIdHsWrapper co_fn_res = return idHsWrapper
| null arg_tys = return co_fn_res
| otherwise
- = do { us <- newUniqueSupply
- ; let arg_ids = zipWith (mkSysLocal FSLIT("sub")) (uniqsFromSupply us) arg_tys
- ; return (mkCoLams arg_ids <.> co_fn_res <.> mkCoApps arg_ids) }
+ = do { arg_ids <- newSysLocalIds FSLIT("sub") arg_tys
+ ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpApps arg_ids) }
\end{code}
-> TcTyVarSet -- Extra tyvars that the universally
-- quantified tyvars of expected_ty
-- must not be unified
- -> (BoxyRhoType -> TcM result) -- spec_ty
- -> TcM (ExprCoFn, result)
+ -> ([TcTyVar] -> BoxyRhoType -> TcM result)
+ -> TcM (HsWrapper, result)
-- The expression has type: spec_ty -> expected_ty
tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type
-- mention the *instantiated* tyvar names, so that we get a
-- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-- Hence the tiresome but innocuous fixM
- ((forall_tvs, theta, rho_ty), skol_info) <- fixM (\ ~(_, skol_info) ->
+ ((tvs', theta', rho'), skol_info) <- fixM (\ ~(_, skol_info) ->
do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
; span <- getSrcSpanM
; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) span
#ifdef DEBUG
; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs,
text "expected_ty" <+> ppr expected_ty,
- text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr rho_ty,
- text "free_tvs" <+> ppr free_tvs,
- text "forall_tvs" <+> ppr forall_tvs])
+ text "inst ty" <+> ppr tvs' <+> ppr theta' <+> ppr rho',
+ text "free_tvs" <+> ppr free_tvs])
#endif
-- Type-check the arg and unify with poly type
- ; (result, lie) <- getLIE (thing_inside rho_ty)
+ ; (result, lie) <- getLIE (thing_inside tvs' rho')
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
-- Conclusion: include the free vars of the expected_ty in the
-- list of "free vars" for the signature check.
- ; dicts <- newDictBndrsO (SigOrigin skol_info) theta
- ; inst_binds <- tcSimplifyCheck sig_msg forall_tvs dicts lie
+ ; dicts <- newDictBndrsO (SigOrigin skol_info) theta'
+ ; inst_binds <- tcSimplifyCheck sig_msg tvs' dicts lie
- ; checkSigTyVarsWrt free_tvs forall_tvs
+ ; checkSigTyVarsWrt free_tvs tvs'
; traceTc (text "tcGen:done")
; let
- -- The CoLet binds any Insts which came out of the simplification.
+ -- The WpLet binds any Insts which came out of the simplification.
dict_ids = map instToId dicts
- co_fn = mkCoTyLams forall_tvs <.> mkCoLams dict_ids <.> CoLet inst_binds
+ co_fn = mkWpTyLams tvs' <.> mkWpLams dict_ids <.> WpLet inst_binds
; returnM (co_fn, result) }
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
unBoxPred (ClassP cls tys) = do { tys' <- mapM unBox tys; return (ClassP cls tys') }
unBoxPred (IParam ip ty) = do { ty' <- unBox ty; return (IParam ip ty') }
+unBoxPred (EqPred ty1 ty2) = do { ty1' <- unBox ty1; ty2' <- unBox ty2; return (EqPred ty1' ty2') }
\end{code}
----------------
-- If an error happens we try to figure out whether the function
-- function has been given too many or too few arguments, and say so.
-subCtxt mb_fun actual_res_ty expected_res_ty tidy_env
- = do { exp_ty' <- zonkTcType expected_res_ty
- ; act_ty' <- zonkTcType actual_res_ty
- ; let
- (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
- (env2, act_ty'') = tidyOpenType env1 act_ty'
- (exp_args, _) = tcSplitFunTys exp_ty''
- (act_args, _) = tcSplitFunTys act_ty''
+addSubCtxt SubDone actual_res_ty expected_res_ty thing_inside
+ = thing_inside
+addSubCtxt sub_ctxt actual_res_ty expected_res_ty thing_inside
+ = addErrCtxtM mk_err thing_inside
+ where
+ mk_err tidy_env
+ = do { exp_ty' <- zonkTcType expected_res_ty
+ ; act_ty' <- zonkTcType actual_res_ty
+ ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
+ (env2, act_ty'') = tidyOpenType env1 act_ty'
+ (exp_args, _) = tcSplitFunTys exp_ty''
+ (act_args, _) = tcSplitFunTys act_ty''
- len_act_args = length act_args
- len_exp_args = length exp_args
+ len_act_args = length act_args
+ len_exp_args = length exp_args
- message = case mb_fun of
- Just fun | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun
- | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun
- other -> mkExpectedActualMsg act_ty'' exp_ty''
- ; return (env2, message) }
+ message = case sub_ctxt of
+ SubFun fun | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun
+ | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun
+ other -> mkExpectedActualMsg act_ty'' exp_ty''
+ ; return (env2, message) }
- where
wrongArgsCtxt too_many_or_few fun
= ptext SLIT("Probable cause:") <+> quotes (ppr fun)
<+> ptext SLIT("is applied to") <+> text too_many_or_few
projects / ghc-hetmet.git / blobdiff