-tcPat (VarPatIn name)
- = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id ->
- returnTc (VarPat (TcId id), emptyLIE, idType id)
-
-tcPat (LazyPatIn pat)
- = tcPat pat `thenTc` \ (pat', lie, ty) ->
- returnTc (LazyPat pat', lie, ty)
-
-tcPat pat_in@(AsPatIn name pat)
- = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
- tcPat pat `thenTc` \ (pat', lie, ty) ->
- tcAddErrCtxt (patCtxt pat_in) $
- unifyTauTy (idType id) ty `thenTc_`
- returnTc (AsPat (TcId id) pat', lie, ty)
-
-tcPat WildPatIn
- = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
- returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
-
-tcPat (NegPatIn pat)
- = tcPat (negate_lit pat)
- where
- negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
- negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
- negate_lit _ = panic "TcPat:negate_pat"
-
-tcPat (ParPatIn parend_pat)
- = tcPat parend_pat
+tc_pat tc_bndr pat@(TypePat ty) pat_ty
+ = failWithTc (badTypePat pat)
+
+tc_pat tc_bndr (VarPat name) pat_ty
+ = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) ->
+ returnM (co_fn <$> VarPat bndr_id,
+ emptyBag, unitBag (name, bndr_id), [])
+
+tc_pat tc_bndr (LazyPat pat) pat_ty
+ = tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (LazyPat pat', tvs, ids, lie_avail)
+
+tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty
+ = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) ->
+ tcPat tc_bndr pat (Check (idType bndr_id)) `thenM` \ (pat', tvs, ids, lie_avail) ->
+ -- NB: if we have:
+ -- \ (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 be
+ -- fixed, but only with a bit more work.
+ returnM (co_fn <$> (AsPat (L nm_loc bndr_id) pat'),
+ tvs, (name, bndr_id) `consBag` ids, lie_avail)
+
+tc_pat tc_bndr (WildPat _) pat_ty
+ = zapExpectedType pat_ty `thenM` \ pat_ty' ->
+ -- We might have an incoming 'hole' type variable; no annotation
+ -- so zap it to a type. Rather like tcMonoPatBndr.
+ returnM (WildPat pat_ty', emptyBag, emptyBag, [])
+
+tc_pat tc_bndr (ParPat parend_pat) pat_ty
+-- Leave the parens in, so that warnings from the
+-- desugarer have parens in them
+ = tcPat tc_bndr parend_pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (ParPat pat', tvs, ids, lie_avail)
+
+tc_pat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
+ = addErrCtxt (patCtxt pat_in) $
+ tcHsSigType PatSigCtxt sig `thenM` \ sig_ty ->
+ tcSubPat sig_ty pat_ty `thenM` \ co_fn ->
+ tcPat tc_bndr pat (Check sig_ty) `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (co_fn <$> unLoc pat', tvs, ids, lie_avail)