#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcExpr )
+import {-# SOURCE #-} TcExpr( tcMonoExpr )
import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
import TcMonad
import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
-import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars )
-import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
-import TcMType ( newTyVarTy )
-import TcType ( TcType, TcTyVar, tyVarsOfType,
+import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
+import TcPat ( tcPat, tcMonoPatBndr )
+import TcMType ( newTyVarTy, zonkTcType )
+import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
import TcBinds ( tcBindsAndThen )
-import TcUnify ( subFunTy, checkSigTyVars, tcSub, isIdCoercion, (<$>), sigPatCtxt )
+import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSub, isIdCoercion, (<$>) )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
import TysWiredIn ( boolTy )
import Id ( idType )
+import CoreFVs ( idFreeTyVars )
import BasicTypes ( RecFlag(..) )
import VarSet
import Var ( Id )
-> TcType
-> TcM ([TcMatch], LIE)
-tcMatches xve fun_or_case matches expected_ty
+tcMatches xve ctxt matches expected_ty
= mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
returnTc (matches, plusLIEs lies)
where
- tc_match match = tcMatch xve fun_or_case match expected_ty
+ tc_match match = tcMatch xve ctxt match expected_ty
\end{code}
where
tc_grhss pats' rhs_ty
- = tcExtendLocalValEnv xve1 $
+ = tcExtendLocalValEnv2 xve1 $
-- Deal with the result signature
case maybe_rhs_sig of
xve = bagToList pat_bndrs
pat_ids = map snd xve
in
- tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
+ tcExtendLocalValEnv2 xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
- returnTc (rhs_ty, lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
- ) `thenTc` \ (rhs_ty, lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2) ->
+ returnTc (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
+ ) `thenTc` \ (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2) ->
-- STEP 4: Check for existentially bound type variables
-- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
returnTc (lie_req, EmptyMonoBinds)
| otherwise
- = tcExtendGlobalTyVars (tyVarsOfType match_ty) $
- tcAddErrCtxtM (sigPatCtxt tv_list ids) $
+ = tcAddErrCtxtM (sigPatCtxt tv_list ids match_ty) $
-- In case there are any polymorpic, overloaded binders in the pattern
-- (which can happen in the case of rank-2 type signatures, or data constructors
-- Deal with overloaded functions bound by the pattern
tcSimplifyCheck doc tv_list (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
- checkSigTyVars tv_list emptyVarSet `thenTc_`
+ checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
where
= tcAddSrcLoc src_loc $
tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
- tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+ tcMonoExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
tcPopErrCtxt $
thing_inside `thenTc` \ (thing, lie) ->
= tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
if isDoExpr do_or_lc then
newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
- tcExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
+ tcMonoExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
returnTc (ExprStmt exp' any_ty locn, lie)
else
- tcExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
+ tcMonoExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
returnTc (ExprStmt exp' boolTy locn, lie)
) `thenTc` \ (stmt', stmt_lie) ->
tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
= tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
if isDoExpr do_or_lc then
- tcExpr exp (m res_elt_ty)
+ tcMonoExpr exp (m res_elt_ty)
else
- tcExpr exp res_elt_ty
+ tcMonoExpr exp res_elt_ty
) `thenTc` \ (exp', stmt_lie) ->
thing_inside `thenTc` \ (thing, stmts_lie) ->
\end{code}
\begin{code}
+varyingArgsErr name matches
+ = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
+
matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
-varyingArgsErr name matches
- = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
+sigPatCtxt bound_tvs bound_ids match_ty tidy_env
+ = zonkTcType match_ty `thenNF_Tc` \ match_ty' ->
+ let
+ (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
+ (env2, tidy_mty) = tidyOpenType env1 match_ty'
+ in
+ returnNF_Tc (env1,
+ sep [ptext SLIT("When checking an existential match that binds"),
+ nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
+ ptext SLIT("and whose type is") <+> ppr tidy_mty])
+ where
+ show_ids = filter is_interesting bound_ids
+ is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
+
+ ppr_id id ty = ppr id <+> dcolon <+> ppr ty
+ -- Don't zonk the types so we get the separate, un-unified versions
\end{code}
projects / ghc-hetmet.git / blobdiff