+\begin{code}
+tcMatchPats
+ :: [RenamedPat] -> TcType
+ -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
+ -> TcM (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
+-- signatures
+
+tcMatchPats pats expected_ty thing_inside
+ = -- STEP 1: Bring pattern-signature type variables into scope
+ 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
+ tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
+
+ -- STEP 4: Check for existentially bound type variables
+ -- 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 rhs_ty `thenTc` \ (lie_req2', ex_binds) ->
+
+ returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds)
+
+tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
+-- Find the not-already-in-scope signature type variables,
+-- kind-check them, and bring them into scope
+--
+-- We no longer specify that these type variables must be univerally
+-- quantified (lots of email on the subject). If you want to put that
+-- back in, you need to
+-- a) Do a checkSigTyVars after thing_inside
+-- b) More insidiously, don't pass in expected_ty, else
+-- we unify with it too early and checkSigTyVars barfs
+-- Instead you have to pass in a fresh ty var, and unify
+-- it with expected_ty afterwards
+tcAddScopedTyVars sig_tys thing_inside
+ = tcGetEnv `thenNF_Tc` \ env ->
+ let
+ all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
+ sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
+ not_in_scope tv = not (tcInLocalScope env tv)
+ in
+ tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) thing_inside
+
+tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
+ -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
+ -> LIE -- and context
+ -> LIE -- Required context
+ -> TcType -- and result type; vars in here must not escape
+ -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
+tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
+ | isEmptyBag ex_tvs && all not_overloaded 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 )
+ returnTc (lie_req, EmptyMonoBinds)
+
+ | otherwise
+ = tcExtendGlobalTyVars (tyVarsOfType result_ty) $
+ tcAddErrCtxtM (sigPatCtxt tv_list ids) $
+
+ -- 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) ->
+
+ -- 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_`
+
+ 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