From fd7d044fe32e5685b35f16833b81794a61a98bc7 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 27 May 2002 16:13:43 +0000 Subject: [PATCH] [project @ 2002-05-27 16:13:42 by simonpj] Make negative literals work in patterns The issue here is that f (-1) = True f x = False should generate f x = x == negate (fromInteger 1) rather than f x = x == fromInteger (-1) --- ghc/compiler/hsSyn/HsPat.lhs | 11 +++++++---- ghc/compiler/parser/ParseUtil.lhs | 15 +++++++-------- ghc/compiler/rename/RnExpr.lhs | 14 +++++++++++--- ghc/compiler/typecheck/TcPat.lhs | 18 +++++++++++++----- 4 files changed, 38 insertions(+), 20 deletions(-) diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index c801a86..97be698 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -54,7 +54,10 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) - | NPatIn HsOverLit + | NPatIn HsOverLit -- Always positive + (Maybe Name) -- Just (Name of 'negate') for negative + -- patterns, Nothing otherwise + -- (see RnEnv.lookupSyntaxName) | NPlusKPatIn name -- n+k pattern HsOverLit -- It'll always be an HsIntegral @@ -166,7 +169,7 @@ pprInPat (ListPatIn pats) = brackets (interpp'SP pats) pprInPat (PArrPatIn pats) = pabrackets (interpp'SP pats) pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats) pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k]) -pprInPat (NPatIn l) = ppr l +pprInPat (NPatIn l _) = ppr l pprInPat (ConPatIn c pats) | null pats = ppr c @@ -345,7 +348,7 @@ collect (SigPatIn pat _) bndrs = collect pat bndrs collect (LazyPatIn pat) bndrs = collect pat bndrs collect (AsPatIn a pat) bndrs = a : collect pat bndrs collect (NPlusKPatIn n _ _) bndrs = n : bndrs -collect (NPatIn _) bndrs = bndrs +collect (NPatIn _ _) bndrs = bndrs collect (ConPatIn c pats) bndrs = foldr collect bndrs pats collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs) collect (ParPatIn pat) bndrs = collect pat bndrs @@ -390,7 +393,7 @@ collect_pat (VarPatIn var) acc = acc collect_pat (LitPatIn _) acc = acc collect_pat (LazyPatIn pat) acc = collect_pat pat acc collect_pat (AsPatIn a pat) acc = collect_pat pat acc -collect_pat (NPatIn _) acc = acc +collect_pat (NPatIn _ _) acc = acc collect_pat (NPlusKPatIn n _ _) acc = acc collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc) diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 2a9ae46..f882c89 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -200,7 +200,7 @@ checkPat e [] = case e of EWildPat -> returnP WildPatIn HsVar x -> returnP (VarPatIn x) HsLit l -> returnP (LitPatIn l) - HsOverLit l -> returnP (NPatIn l) + HsOverLit l -> returnP (NPatIn l Nothing) ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn) EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n) ExprWithTySig e t -> checkPat e [] `thenP` \e -> @@ -213,13 +213,12 @@ checkPat e [] = case e of in returnP (SigPatIn e t') - -- translate out NegApps of literals in patterns. - -- NB. negative primitive literals are already handled by - -- RdrHsSyn.mkHsNegApp - NegApp (HsOverLit (HsIntegral i n)) _ - -> returnP (NPatIn (HsIntegral (-i) n)) - NegApp (HsOverLit (HsFractional f n)) _ - -> returnP (NPatIn (HsFractional (-f) n)) + -- Translate out NegApps of literals in patterns. We negate + -- the Integer here, and add back the call to 'negate' when + -- we typecheck the pattern. + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg)) OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) | plus == plus_RDR diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 9760ae8..40ed626 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -90,15 +90,23 @@ rnPat (LitPatIn lit) = litFVs lit `thenRn` \ fvs -> returnRn (LitPatIn lit, fvs) -rnPat (NPatIn lit) +rnPat (NPatIn lit mb_neg) = rnOverLit lit `thenRn` \ (lit', fvs1) -> - returnRn (NPatIn lit', fvs1 `addOneFV` eqClassName) -- Needed to find equality on pattern + (case mb_neg of + Nothing -> returnRn (Nothing, emptyFVs) + Just neg -> lookupSyntaxName neg `thenRn` \ neg' -> + returnRn (Just neg', unitFV neg') + ) `thenRn` \ (mb_neg', fvs2) -> + returnRn (NPatIn lit' mb_neg', + fvs1 `plusFV` fvs2 `addOneFV` eqClassName) + -- Needed to find equality on pattern rnPat (NPlusKPatIn name lit minus) = rnOverLit lit `thenRn` \ (lit', fvs) -> lookupBndrRn name `thenRn` \ name' -> lookupSyntaxName minus `thenRn` \ minus' -> - returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ordClassName `addOneFV` minus') + returnRn (NPlusKPatIn name' lit' minus', + fvs `addOneFV` ordClassName `addOneFV` minus') rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index f816b7c..e4decd0 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -306,12 +306,20 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty = unifyTauTy pat_ty (simpleHsLitTy simple_lit) `thenTc_` returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE) -tcPat tc_bndr pat@(NPatIn over_lit) pat_ty - = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> +tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty + = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (pos_lit_expr, lie1) -> newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq -> - - returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr), - lie1 `plusLIE` unitLIE eq, + (case mb_neg of + Nothing -> returnNF_Tc (pos_lit_expr, emptyLIE) -- Positive literal + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + tcLookupId neg `thenNF_Tc` \ neg_sel_id -> + newMethod origin neg_sel_id [pat_ty] `thenNF_Tc` \ neg -> + returnNF_Tc (HsApp (HsVar (instToId neg)) pos_lit_expr, unitLIE neg) + ) `thenNF_Tc` \ (lit_expr, lie2) -> + + returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) lit_expr), + lie1 `plusLIE` lie2 `plusLIE` unitLIE eq, emptyBag, emptyBag, emptyLIE) where origin = PatOrigin pat -- 1.7.10.4