-
- possibly_mangled_result
- | opt_IrrefutableTuples && isBoxed boxity = LazyPat 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}
-tcPat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty
- = addErrCtxt (patCtxt pat_in) $
-
- -- Check that it's a constructor, and instantiate it
- tcLookupDataCon con_name `thenM` \ data_con ->
- tcInstDataCon (PatOrigin pat_in) 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}
-tcPat tc_bndr (LitPat lit@(HsLitLit s _)) pat_ty
- -- cf tcExpr on LitLits
- = zapExpectedType pat_ty `thenM` \ pat_ty' ->
- tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
- newDicts (LitLitOrigin (unpackFS s))
- [mkClassPred cCallableClass [pat_ty']] `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
- returnM (LitPat (HsLitLit s pat_ty'), emptyBag, emptyBag, [])
-
-tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
- = zapExpectedType pat_ty `thenM` \ pat_ty' ->
- unifyTauTy pat_ty' stringTy `thenM_`
- tcLookupId eqStringName `thenM` \ eq_id ->
- returnM (NPatOut lit stringTy (HsVar eq_id `HsApp` HsLit lit),
- emptyBag, emptyBag, [])
-
-tcPat tc_bndr (LitPat simple_lit) pat_ty
- = zapExpectedType pat_ty `thenM` \ pat_ty' ->
- unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_`
- returnM (LitPat simple_lit, emptyBag, emptyBag, [])
-
-tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
- = zapExpectedType pat_ty `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, HsVar neg) `thenM` \ (_, neg_expr) ->
- returnM (HsApp 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
- (HsIntegral i _, Just _) -> HsInteger (-i)
- (HsFractional f _, Nothing) -> HsRat f pat_ty'
- (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
- in
- returnM (NPatOut lit' pat_ty' (HsApp (HsVar eq) lit_expr),
- emptyBag, emptyBag, [])
- where
- origin = PatOrigin pat
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{n+k patterns}
-%* *
-%************************************************************************
-
-\begin{code}
-tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
- = 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 ->
-
- -- The '-' part is re-mappable syntax
- tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) `thenM` \ (_, minus_expr) ->
+ ; 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 (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@(NPat over_lit mb_neg eq _) pat_ty thing_inside
+ = do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind
+ ; let orig = LiteralOrigin over_lit
+ ; lit' <- tcOverloadedLit orig over_lit pat_ty'
+ ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty', pat_ty'] boolTy)
+ ; mb_neg' <- case mb_neg of
+ Nothing -> return Nothing -- Positive literal
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty' pat_ty')
+ ; return (Just neg') }
+ ; res <- thing_inside
+ ; returnM (NPat lit' mb_neg' eq' pat_ty', [], res) }
+
+tc_pat ctxt pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
+ = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
+ ; let pat_ty' = idType bndr_id
+ orig = LiteralOrigin lit
+ ; lit' <- tcOverloadedLit orig lit pat_ty'
+
+ -- The '>=' and '-' parts are re-mappable syntax
+ ; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy)
+ ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty')