import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
import TcPat ( tcPat, tcMonoPatBndr )
-import TcMType ( newTyVarTy, zonkTcType )
+import TcMType ( newTyVarTy, zonkTcType, zapToType )
import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
import TcBinds ( tcBindsAndThen )
-import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSub, isIdCoercion, (<$>) )
+import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
import TysWiredIn ( boolTy )
import VarSet
import Var ( Id )
import Bag
-import Util ( isSingleton )
+import Util ( isSingleton, lengthExceeds )
import Outputable
import List ( nub )
-> TcM ([TcMatch], LIE)
tcMatches xve ctxt matches expected_ty
- = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
+ = -- If there is more than one branch, and expected_ty is a 'hole',
+ -- all branches must be types, not type schemes, otherwise the
+ -- in which we check them would affect the result.
+ (if lengthExceeds matches 1 then
+ zapToType expected_ty
+ else
+ returnNF_Tc expected_ty) `thenNF_Tc` \ expected_ty' ->
+
+ mapAndUnzipTc (tc_match expected_ty') matches `thenTc` \ (matches, lies) ->
returnTc (matches, plusLIEs lies)
where
- tc_match match = tcMatch xve ctxt match expected_ty
+ tc_match expected_ty match = tcMatch xve ctxt match expected_ty
\end{code}
tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
= tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
-
- tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
+ tcMatchPats pats expected_ty tc_grhss `thenTc` \ (pats', grhss', lie, ex_binds) ->
returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
where
- tc_grhss pats' rhs_ty
+ tc_grhss rhs_ty
= tcExtendLocalValEnv2 xve1 $
-- Deal with the result signature
case maybe_rhs_sig of
- Nothing -> tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) ->
- returnTc ((pats', grhss'), lie)
+ Nothing -> tcGRHSs ctxt grhss rhs_ty
Just sig -> tcAddScopedTyVars [sig] $
-- Bring into scope the type variables in the signature
tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
tcGRHSs ctxt grhss sig_ty `thenTc` \ (grhss', lie1) ->
- tcSub rhs_ty sig_ty `thenTc` \ (co_fn, lie2) ->
- returnTc ((pats', lift_grhss co_fn rhs_ty grhss'),
+ tcSubExp rhs_ty sig_ty `thenTc` \ (co_fn, lie2) ->
+ returnTc (lift_grhss co_fn rhs_ty grhss',
lie1 `plusLIE` lie2)
-- lift_grhss pushes the coercion down to the right hand sides,
\begin{code}
tcMatchPats
:: [RenamedPat] -> TcType
- -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
- -> TcM (a, LIE, TcDictBinds)
+ -> (TcType -> TcM (a, LIE))
+ -> TcM ([TypecheckedPat], a, LIE, TcDictBinds)
-- Typecheck the patterns, extend the environment to bind the variables,
-- do the thing inside, use any existentially-bound dictionaries to
-- discharge parts of the returning LIE, and deal with pattern type
tcAddScopedTyVars (collectSigTysFromPats pats) (
-- STEP 2: Typecheck the patterns themselves, gathering all the stuff
- tc_match_pats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
-
- -- STEP 3: Extend the environment, and do the thing inside
- let
- xve = bagToList pat_bndrs
- pat_ids = map snd xve
- in
- tcExtendLocalValEnv2 xve (thing_inside pats' rhs_ty) `thenTc` \ (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) ->
+ -- then do the thing inside
+ tc_match_pats pats expected_ty thing_inside
+
+ ) `thenTc` \ (pats', lie_req, ex_tvs, ex_ids, ex_lie, result) ->
-- STEP 4: Check for existentially bound type variables
-- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
-- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
-- might need (via lie_req2) something made available from an 'outer'
-- pattern. But it's inconvenient to deal with, and I can't find an example
- tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req2 expected_ty `thenTc` \ (lie_req2', ex_binds) ->
+ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenTc` \ (lie_req', ex_binds) ->
-- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
-- For example, we must reject this program:
-- data C = forall a. C (a -> Int)
-- f (C g) x = g x
-- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
- returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds)
+ returnTc (pats', result, lie_req', ex_binds)
+
+tc_match_pats [] expected_ty thing_inside
+ = thing_inside expected_ty `thenTc` \ (answer, lie) ->
+ returnTc ([], lie, emptyBag, [], emptyLIE, answer)
+
+tc_match_pats (pat:pats) expected_ty thing_inside
+ = subFunTy expected_ty $ \ arg_ty rest_ty ->
+ -- This is the unique place we call subFunTy
+ -- The point is that if expected_y is a "hole", we want
+ -- to make arg_ty and rest_ty as "holes" too.
+ tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, ex_tvs, pat_bndrs, ex_lie) ->
+ let
+ xve = bagToList pat_bndrs
+ ex_ids = [id | (_, id) <- xve]
+ -- ex_ids is all the pattern-bound Ids, a superset
+ -- of the existential Ids used in checkExistentialPat
+ in
+ tcExtendLocalValEnv2 xve $
+ tc_match_pats pats rest_ty thing_inside `thenTc` \ (pats', lie_reqs, exs_tvs, exs_ids, exs_lie, answer) ->
+ returnTc ( pat':pats',
+ lie_req `plusLIE` lie_reqs,
+ ex_tvs `unionBags` exs_tvs,
+ ex_ids ++ exs_ids,
+ ex_lie `plusLIE` exs_lie,
+ answer
+ )
+
-tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
- -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
+tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
+ -> [TcId] -- Ids bound by this pattern; used
+ -- (a) by bindsInstsOfLocalFuns
+ -- (b) to generate helpful error messages
-> LIE -- and context
-> LIE -- Required context
-> TcType -- and type of the Match; vars in here must not escape
-> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
-tcCheckExistentialPat ids ex_tvs lie_avail lie_req match_ty
- | isEmptyBag ex_tvs && all not_overloaded ids
+tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
+ | isEmptyBag ex_tvs && all not_overloaded ex_ids
-- Short cut for case when there are no existentials
-- and no polymorphic overloaded variables
-- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
-- f op x = ....
-- Here we must discharge op Methods
- = ASSERT( isEmptyLIE lie_avail )
+ = ASSERT( isEmptyLIE ex_lie )
returnTc (lie_req, EmptyMonoBinds)
| otherwise
- = tcAddErrCtxtM (sigPatCtxt tv_list ids match_ty) $
+ = tcAddErrCtxtM (sigPatCtxt tv_list ex_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
-- with polymorphic arguments), we must do a bindInstsOfLocalFns here
- bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
+ bindInstsOfLocalFuns lie_req ex_ids `thenTc` \ (lie1, inst_binds) ->
-- Deal with overloaded functions bound by the pattern
- tcSimplifyCheck doc tv_list (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
- checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
+ tcSimplifyCheck doc tv_list (lieToList ex_lie) lie1 `thenTc` \ (lie2, dict_binds) ->
+ checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
where
doc = text ("the existential context of a data constructor")
tv_list = bagToList ex_tvs
not_overloaded id = not (isOverloadedTy (idType id))
-
-tc_match_pats [] expected_ty
- = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
-
-tc_match_pats (pat:pats) expected_ty
- = subFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
- -- This is the unique place we call subFunTy
- -- The point is that if expected_y is a "hole", we want
- -- to make arg_ty and rest_ty as "holes" too.
- tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
- tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
- returnTc ( rhs_ty,
- pat':pats',
- lie_req `plusLIE` lie_reqs,
- pat_tvs `unionBags` pats_tvs,
- pat_ids `unionBags` pats_ids,
- lie_avail `plusLIE` lie_avails
- )
\end{code}
tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
tcMonoExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
- tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
- tcPopErrCtxt $
- thing_inside `thenTc` \ (thing, lie) ->
- returnTc ((BindStmt pat' exp' src_loc, thing), lie)
- ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
- returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
+ tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
+ tcPopErrCtxt thing_inside
+ ) `thenTc` \ ([pat'], thing, lie, dict_binds) ->
+ returnTc (combine (BindStmt pat' exp' src_loc)
+ (glue_binds combine Recursive dict_binds thing),
lie `plusLIE` exp_lie)
projects / ghc-hetmet.git / blobdiff