-
- possibly_mangled_result
- | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
- | otherwise = unmangled_result
- in
- returnM (possibly_mangled_result, tvs, ids, lie_avail)
- where
- arity = length pats
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Other constructors}
-%* *
-
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty
- = addErrCtxt (patCtxt pat_in) $
-
- -- Check that it's a constructor, and instantiate it
- tcLookupLocatedDataCon con_name `thenM` \ data_con ->
- tcInstDataCon (PatOrigin pat_in) ExistTv data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) ->
-
- -- Check overall type matches.
- -- The pat_ty might be a for-all type, in which
- -- case we must instantiate to match
- tcSubPat con_res_ty pat_ty `thenM` \ co_fn ->
-
- -- Check the argument patterns
- tcConStuff tc_bndr data_con arg_pats arg_tys `thenM` \ (arg_pats', arg_tvs, arg_ids, ex_dicts2) ->
-
- returnM (co_fn <$> ConPatOut data_con arg_pats' con_res_ty ex_tvs (map instToId ex_dicts1),
- listToBag ex_tvs `unionBags` arg_tvs,
- arg_ids,
- ex_dicts1 ++ ex_dicts2)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Literals}
-%* *
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
- = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' ->
- unifyTauTy pat_ty' stringTy `thenM_`
- tcLookupId eqStringName `thenM` \ eq_id ->
- returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit),
- emptyBag, emptyBag, [])
-
-tc_pat tc_bndr (LitPat simple_lit) pat_ty
- = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' ->
- unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_`
- returnM (LitPat simple_lit, emptyBag, emptyBag, [])
-
-tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
- = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' ->
- newOverloadedLit origin over_lit pat_ty' `thenM` \ pos_lit_expr ->
- newMethodFromName origin pat_ty' eqName `thenM` \ eq ->
- (case mb_neg of
- Nothing -> returnM pos_lit_expr -- Positive literal
- Just neg -> -- Negative literal
- -- The 'negate' is re-mappable syntax
- tcSyntaxName origin pat_ty' (negateName, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) ->
- returnM (mkHsApp neg_expr pos_lit_expr)
- ) `thenM` \ lit_expr ->
-
- let
- -- The literal in an NPatIn is always positive...
- -- But in NPat, the literal is used to find identical patterns
- -- so we must negate the literal when necessary!
- lit' = case (over_lit, mb_neg) of
- (HsIntegral i _, Nothing) -> HsInteger i pat_ty'
- (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty'
- (HsFractional f _, Nothing) -> HsRat f pat_ty'
- (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
- in
- returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr),
- emptyBag, emptyBag, [])
- where
- origin = PatOrigin pat
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{n+k patterns}
-%* *
-%************************************************************************
-
-\begin{code}
-tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty
- = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) ->
- let
- pat_ty' = idType bndr_id
- in
- newOverloadedLit origin lit pat_ty' `thenM` \ over_lit_expr ->
- newMethodFromName origin pat_ty' geName `thenM` \ ge ->
+ ; let unmangled_result = TuplePat pats' boxity
+ possibly_mangled_result
+ | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
+ | otherwise = unmangled_result
+
+ ; ASSERT( length arg_tys == arity ) -- Syntactically enforced
+ return (possibly_mangled_result, pats_tvs, res) }
+
+------------------------
+-- Data constructors
+tc_pat ctxt pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
+ = do { data_con <- tcLookupDataCon con_name
+ ; let tycon = dataConTyCon data_con
+ ; ty_args <- zapToTyConApp tycon pat_ty
+ ; (pat', tvs, res) <- tcConPat ctxt con_span data_con tycon ty_args arg_pats thing_inside
+ ; return (pat', tvs, res) }
+
+
+------------------------
+-- Literal patterns
+tc_pat ctxt pat@(LitPat lit@(HsString _)) pat_ty thing_inside
+ = do { -- Strings are mapped to NPatOuts, which have a guard expression
+ zapExpectedTo pat_ty stringTy
+ ; eq_id <- tcLookupId eqStringName
+ ; res <- thing_inside
+ ; returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), [], res) }
+
+tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside
+ = do { -- All other simple lits
+ zapExpectedTo pat_ty (hsLitType simple_lit)
+ ; res <- thing_inside
+ ; returnM (LitPat simple_lit, [], res) }
+
+------------------------
+-- Overloaded patterns: n, and n+k
+tc_pat ctxt pat@(NPatIn over_lit mb_neg) pat_ty thing_inside
+ = do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind
+ ; let origin = LiteralOrigin over_lit
+ ; pos_lit_expr <- newOverloadedLit origin over_lit pat_ty'
+ ; eq <- newMethodFromName origin pat_ty' eqName
+ ; lit_expr <- case mb_neg of
+ Nothing -> returnM pos_lit_expr -- Positive literal
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ do { (_, neg_expr) <- tcSyntaxName origin pat_ty'
+ (negateName, HsVar neg)
+ ; returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) }
+
+ ; let -- The literal in an NPatIn is always positive...
+ -- But in NPatOut, the literal is used to find identical patterns
+ -- so we must negate the literal when necessary!
+ lit' = case (over_lit, mb_neg) of
+ (HsIntegral i _, Nothing) -> HsInteger i pat_ty'
+ (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty'
+ (HsFractional f _, Nothing) -> HsRat f pat_ty'
+ (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
+
+ ; res <- thing_inside
+ ; returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), [], res) }
+
+tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty thing_inside
+ = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
+ ; let pat_ty' = idType bndr_id
+ origin = LiteralOrigin lit
+ ; over_lit_expr <- newOverloadedLit origin lit pat_ty'
+ ; ge <- newMethodFromName origin pat_ty' geName