[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)

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index c801a86..97be698 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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