+tc_lpat :: PatCtxt
+ -> LPat Name -> Expected TcSigmaType
+ -> TcM a -- Thing inside
+ -> TcM (LPat TcId, -- Translated pattern
+ [TcTyVar], -- Existential binders
+ a) -- Result of thing inside
+
+tc_lpat ctxt (L span pat) pat_ty thing_inside
+ = setSrcSpan span $
+ -- It's OK to keep setting the SrcSpan;
+ -- it just overwrites the previous value
+ do { (pat', tvs, res) <- tc_pat ctxt pat pat_ty thing_inside
+ ; return (L span pat', tvs, res) }
+
+---------------------
+tc_pat ctxt (VarPat name) pat_ty thing_inside
+ = do { id <- tcPatBndr ctxt name pat_ty
+ ; (res, binds) <- bindInstsOfPatId id $
+ tcExtendIdEnv1 name id $
+ (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
+ >> thing_inside)
+ ; let pat' | isEmptyLHsBinds binds = VarPat id
+ | otherwise = VarPatOut id binds
+ ; return (pat', [], res) }
+
+tc_pat ctxt (ParPat pat) pat_ty thing_inside
+ = do { (pat', tvs, res) <- tc_lpat ctxt pat pat_ty thing_inside
+ ; return (ParPat pat', tvs, res) }
+
+-- There's a wrinkle with irrefuatable patterns, namely that we
+-- must not propagate type refinement from them. For example
+-- data T a where { T1 :: Int -> T Int; ... }
+-- f :: T a -> Int -> a
+-- f ~(T1 i) y = y
+-- It's obviously not sound to refine a to Int in the right
+-- hand side, because the arugment might not match T1 at all!
+--
+-- Nor should a lazy pattern bind any existential type variables
+-- because they won't be in scope when we do the desugaring
+tc_pat ctxt lpat@(LazyPat pat) pat_ty thing_inside
+ = do { reft <- getTypeRefinement
+ ; (pat', pat_tvs, res) <- tc_lpat ctxt pat pat_ty $
+ setTypeRefinement reft thing_inside
+ ; if (null pat_tvs) then return ()
+ else lazyPatErr lpat pat_tvs
+ ; return (LazyPat pat', [], res) }
+
+tc_pat ctxt (WildPat _) pat_ty thing_inside
+ = do { pat_ty' <- zapExpectedType pat_ty argTypeKind
+ -- Note argTypeKind, so that
+ -- f _ = 3
+ -- is rejected when f applied to an unboxed tuple
+ -- However, this means that
+ -- (case g x of _ -> ...)
+ -- is rejected g returns an unboxed tuple, which is perhpas
+ -- annoying. I suppose we could pass the context into tc_pat...
+ ; res <- thing_inside
+ ; return (WildPat pat_ty', [], res) }
+
+tc_pat ctxt (AsPat (L nm_loc name) pat) pat_ty thing_inside
+ = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
+ ; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
+ tc_lpat ctxt pat (Check (idType bndr_id)) thing_inside
+ -- NB: if we do inference on:
+ -- \ (y@(x::forall a. a->a)) = e
+ -- we'll fail. The as-pattern infers a monotype for 'y', which then
+ -- fails to unify with the polymorphic type for 'x'. This could
+ -- perhaps be fixed, but only with a bit more work.
+ --
+ -- If you fix it, don't forget the bindInstsOfPatIds!
+ ; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }
+
+tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside
+ = do { -- See Note [Pattern coercions] below
+ (sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
+ ; tcSubPat sig_ty pat_ty
+ ; subst <- refineTyVars sig_tvs -- See note [Type matching]
+ ; let tv_binds = [(tv, substTyVar subst tv) | tv <- sig_tvs]
+ sig_ty' = substTy subst sig_ty
+ ; (pat', tvs, res)
+ <- tcExtendTyVarEnv2 tv_binds $
+ tc_lpat ctxt pat (Check sig_ty') thing_inside
+
+ ; return (SigPatOut pat' sig_ty, tvs, res) }
+
+tc_pat ctxt pat@(TypePat ty) pat_ty thing_inside
+ = failWithTc (badTypePat pat)