Make XNegativeLiterals treat -0.0 as negative 0
authorNolan <nolane16@gmail.com>
Mon, 8 May 2017 21:46:22 +0000 (17:46 -0400)
committerBen Gamari <ben@smart-cactus.org>
Mon, 8 May 2017 21:46:24 +0000 (17:46 -0400)
Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, mpickering

GHC Trac Issues: #13211

Differential Revision: https://phabricator.haskell.org/D3543

22 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/deSugar/Check.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchLit.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsLit.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
testsuite/tests/ghc-api/annotations-literals/literals.stdout
testsuite/tests/ghc-api/annotations-literals/parsed.hs
testsuite/tests/parser/should_run/NegativeZero.hs [new file with mode: 0644]
testsuite/tests/parser/should_run/NegativeZero.stdout [new file with mode: 0644]
testsuite/tests/parser/should_run/all.T
testsuite/tests/perf/compiler/all.T

index 03e588c..b67e662 100644 (file)
@@ -97,7 +97,10 @@ module BasicTypes(
 
         SuccessFlag(..), succeeded, failed, successIf,
 
-        FractionalLit(..), negateFractionalLit, integralFractionalLit,
+        IntegralLit(..), FractionalLit(..),
+        negateIntegralLit, negateFractionalLit,
+        mkIntegralLit, mkFractionalLit,
+        integralFractionalLit,
 
         SourceText(..), pprWithSourceText,
 
@@ -1404,6 +1407,30 @@ isEarlyActive AlwaysActive      = True
 isEarlyActive (ActiveBefore {}) = True
 isEarlyActive _                 = False
 
+-- | Integral Literal
+--
+-- Used (instead of Integer) to represent negative zegative zero which is
+-- required for NegativeLiterals extension to correctly parse `-0::Double`
+-- as negative zero. See also #13211.
+data IntegralLit
+  = IL { il_text :: SourceText
+       , il_neg :: Bool -- See Note [Negative zero]
+       , il_value :: Integer
+       }
+  deriving (Data, Show)
+
+mkIntegralLit :: Integral a => a -> IntegralLit
+mkIntegralLit i = IL { il_text = SourceText (show (fromIntegral i :: Int))
+                     , il_neg = i < 0
+                     , il_value = toInteger i }
+
+negateIntegralLit :: IntegralLit -> IntegralLit
+negateIntegralLit (IL text neg value)
+  = case text of
+      SourceText ('-':src) -> IL (SourceText src)       False    (negate value)
+      SourceText      src  -> IL (SourceText ('-':src)) True     (negate value)
+      NoSourceText         -> IL NoSourceText          (not neg) (negate value)
+
 -- | Fractional Literal
 --
 -- Used (instead of Rational) to represent exactly the floating point literal that we
@@ -1411,22 +1438,43 @@ isEarlyActive _                 = False
 -- the user wrote, which is important e.g. for floating point numbers that can't represented
 -- as Doubles (we used to via Double for pretty-printing). See also #2245.
 data FractionalLit
-  = FL { fl_text :: String         -- How the value was written in the source
+  = FL { fl_text :: SourceText     -- How the value was written in the source
+       , fl_neg :: Bool            -- See Note [Negative zero]
        , fl_value :: Rational      -- Numeric value of the literal
        }
   deriving (Data, Show)
   -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
 
+mkFractionalLit :: Real a => a -> FractionalLit
+mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
+                       , fl_neg = r < 0
+                       , fl_value = toRational r }
+
 negateFractionalLit :: FractionalLit -> FractionalLit
-negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
-negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
+negateFractionalLit (FL text neg value)
+  = case text of
+      SourceText ('-':src) -> FL (SourceText src)     False value
+      SourceText      src  -> FL (SourceText ('-':src)) True  value
+      NoSourceText         -> FL NoSourceText (not neg) (negate value)
 
-integralFractionalLit :: Integer -> FractionalLit
-integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
+integralFractionalLit :: Bool -> Integer -> FractionalLit
+integralFractionalLit neg i = FL { fl_text = SourceText (show i),
+                                   fl_neg = neg,
+                                   fl_value = fromInteger i }
 
 -- Comparison operations are needed when grouping literals
 -- for compiling pattern-matching (module MatchLit)
 
+instance Eq IntegralLit where
+  (==) = (==) `on` il_value
+
+instance Ord IntegralLit where
+  compare = compare `on` il_value
+
+instance Outputable IntegralLit where
+  ppr (IL (SourceText src) _ _) = text src
+  ppr (IL NoSourceText _ value) = text (show value)
+
 instance Eq FractionalLit where
   (==) = (==) `on` fl_value
 
@@ -1434,7 +1482,7 @@ instance Ord FractionalLit where
   compare = compare `on` fl_value
 
 instance Outputable FractionalLit where
-  ppr = text . fl_text
+  ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))
 
 {-
 ************************************************************************
index 1b02502..96bc235 100644 (file)
@@ -19,6 +19,7 @@ module Check (
 
 import TmOracle
 
+import BasicTypes
 import DynFlags
 import HsSyn
 import TcHsSyn
@@ -668,15 +669,20 @@ translateNPat :: FamInstEnvs
 translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
   | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
   = translatePat fam_insts (LitPat (HsString src s))
-  | not type_change, isIntTy    ty, HsIntegral src i <- val
-  = translatePat fam_insts (mk_num_lit HsInt src i)
-  | not type_change, isWordTy   ty, HsIntegral src i <- val
-  = translatePat fam_insts (mk_num_lit HsWordPrim src i)
+  | not type_change, isIntTy    ty, HsIntegral i <- val
+  = translatePat fam_insts
+                 (LitPat $ case mb_neg of
+                             Nothing -> HsInt i
+                             Just _  -> HsInt (negateIntegralLit i))
+  | not type_change, isWordTy   ty, HsIntegral i <- val
+  = translatePat fam_insts
+                 (LitPat $ case mb_neg of
+                             Nothing -> HsWordPrim (il_text i) (il_value i)
+                             Just _  -> let ni = negateIntegralLit i in
+                                        HsWordPrim (il_text ni) (il_value ni))
   where
     type_change = not (outer_ty `eqType` ty)
-    mk_num_lit c src i = LitPat $ case mb_neg of
-      Nothing -> c src i
-      Just _  -> c src (-i)
+
 translateNPat _ ol mb_neg _
   = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
 
index d4a96e6..ff6527f 100644 (file)
@@ -277,12 +277,12 @@ ds_expr _ (HsWrap co_fn e)
        ; warnAboutIdentities dflags e' wrapped_ty
        ; return wrapped_e }
 
-ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i })))
+ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
                   neg_expr)
   = do { expr' <- putSrcSpanDs loc $ do
           { dflags <- getDynFlags
           ; warnAboutOverflowedLiterals dflags
-                                        (lit { ol_val = HsIntegral src (-i) })
+                                        (lit { ol_val = HsIntegral (negateIntegralLit i) })
           ; dsOverLit' dflags lit }
        ; dsSyntaxExpr neg_expr [expr'] }
 
index 7880474..bb4361e 100644 (file)
@@ -2371,7 +2371,7 @@ repLiteral lit
   = do lit' <- case lit of
                    HsIntPrim _ i    -> mk_integer i
                    HsWordPrim _ w   -> mk_integer w
-                   HsInt _ i        -> mk_integer i
+                   HsInt i          -> mk_integer (il_value i)
                    HsFloatPrim r    -> mk_rational r
                    HsDoublePrim r   -> mk_rational r
                    HsCharPrim _ c   -> mk_char c
@@ -2383,7 +2383,7 @@ repLiteral lit
   where
     mb_lit_name = case lit of
                  HsInteger _ _ _  -> Just integerLName
-                 HsInt     _ _    -> Just integerLName
+                 HsInt _          -> Just integerLName
                  HsIntPrim _ _    -> Just intPrimLName
                  HsWordPrim _ _   -> Just wordPrimLName
                  HsFloatPrim _    -> Just floatPrimLName
@@ -2397,6 +2397,7 @@ repLiteral lit
 mk_integer :: Integer -> DsM HsLit
 mk_integer  i = do integer_ty <- lookupType integerTyConName
                    return $ HsInteger NoSourceText i integer_ty
+
 mk_rational :: FractionalLit -> DsM HsLit
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
@@ -2414,7 +2415,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
         -- and rationalL is sucked in when any TH stuff is used
 
 mk_lit :: OverLitVal -> DsM HsLit
-mk_lit (HsIntegral _ i)   = mk_integer  i
+mk_lit (HsIntegral i)     = mk_integer  (il_value i)
 mk_lit (HsFractional f)   = mk_rational f
 mk_lit (HsIsString _ s)   = mk_string   s
 
index abe4dc7..1416620 100644 (file)
@@ -44,7 +44,7 @@ import Maybes
 import Util
 import Name
 import Outputable
-import BasicTypes ( isGenerated, fl_value )
+import BasicTypes ( isGenerated, il_value, fl_value )
 import FastString
 import Unique
 import UniqDFM
@@ -1093,15 +1093,15 @@ patGroup _ (WildPat {})                 = PgAny
 patGroup _ (BangPat {})                 = PgBang
 patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
   case (oval, isJust mb_neg) of
-   (HsIntegral _ i, False) -> PgN (fromInteger i)
-   (HsIntegral _ i, True ) -> PgN (-fromInteger i)
+   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
+   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
    (HsFractional r, False) -> PgN (fl_value r)
    (HsFractional r, True ) -> PgN (-fl_value r)
    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
                           PgOverS s
 patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
   case oval of
-   HsIntegral _ i -> PgNpK i
+   HsIntegral i -> PgNpK (il_value i)
    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
 patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
 patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
index 6ed34f4..e04e618 100644 (file)
@@ -82,17 +82,16 @@ dsLit (HsInt64Prim  _ i) = return (Lit (MachInt64 i))
 dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
 dsLit (HsFloatPrim    f) = return (Lit (MachFloat (fl_value f)))
 dsLit (HsDoublePrim   d) = return (Lit (MachDouble (fl_value d)))
-
 dsLit (HsChar _ c)       = return (mkCharExpr c)
 dsLit (HsString _ str)   = mkStringExprFS str
 dsLit (HsInteger _ i _)  = mkIntegerExpr i
-dsLit (HsInt _ i)        = do dflags <- getDynFlags
-                              return (mkIntExpr dflags i)
+dsLit (HsInt i)          = do dflags <- getDynFlags
+                              return (mkIntExpr dflags (il_value i))
 
-dsLit (HsRat r ty) = do
-   num   <- mkIntegerExpr (numerator (fl_value r))
-   denom <- mkIntegerExpr (denominator (fl_value r))
-   return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+dsLit (HsRat (FL _ _ val) ty) = do
+  num   <- mkIntegerExpr (numerator val)
+  denom <- mkIntegerExpr (denominator val)
+  return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
   where
     (ratio_data_con, integer_ty)
         = case tcSplitTyConApp ty of
@@ -243,9 +242,9 @@ getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
 getLHsIntegralLit _ = Nothing
 
 getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
   | Just tc <- tyConAppTyCon_maybe ty
-  = Just (i, tyConName tc)
+  = Just (il_value i, tyConName tc)
 getIntegralLit _ = Nothing
 
 {-
@@ -313,8 +312,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
 
     mb_int_lit :: Maybe Integer
     mb_int_lit = case (mb_neg, val) of
-                   (Nothing, HsIntegral _ i) -> Just i
-                   (Just _,  HsIntegral _ i) -> Just (-i)
+                   (Nothing, HsIntegral i) -> Just (il_value i)
+                   (Just _,  HsIntegral i) -> Just (-(il_value i))
                    _ -> Nothing
 
     mb_str_lit :: Maybe FastString
index 8d90344..594711d 100644 (file)
@@ -1007,9 +1007,9 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 
 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral NoSourceText i placeHolderType}
+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i)   placeHolderType}
 cvtOverLit (RationalL r)
-  = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
+  = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
@@ -1043,8 +1043,8 @@ allCharLs xs
 cvtLit :: Lit -> CvtM HsLit
 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
-cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
-cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
+cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (mkFractionalLit f) }
+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (mkFractionalLit f) }
 cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
 cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
@@ -1428,9 +1428,6 @@ overloadedLit (IntegerL  _) = True
 overloadedLit (RationalL _) = True
 overloadedLit _             = False
 
-cvtFractionalLit :: Rational -> FractionalLit
-cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
-
 -- Checks that are performed when converting unboxed sum expressions and
 -- patterns alike.
 unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
index fe60748..0226591 100644 (file)
@@ -19,7 +19,8 @@ module HsLit where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
-import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText )
+import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
+                    negateFractionalLit,SourceText(..),pprWithSourceText )
 import Type       ( Type )
 import Outputable
 import FastString
@@ -48,7 +49,7 @@ data HsLit
       -- ^ String
   | HsStringPrim    SourceText ByteString
       -- ^ Packed bytes
-  | HsInt           SourceText Integer
+  | HsInt           IntegralLit
       -- ^ Genuinely an Int; arises from
       -- @TcGenDeriv@, and from TRANSLATION
   | HsIntPrim       SourceText Integer
@@ -78,7 +79,7 @@ instance Eq HsLit where
   (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2
   (HsString _ x1)     == (HsString _ x2)     = x1==x2
   (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2
-  (HsInt _ x1)        == (HsInt _ x2)        = x1==x2
+  (HsInt x1)          == (HsInt x2)          = x1==x2
   (HsIntPrim _ x1)    == (HsIntPrim _ x2)    = x1==x2
   (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2
   (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2
@@ -102,11 +103,16 @@ deriving instance (DataId id) => Data (HsOverLit id)
 -- the following
 -- | Overloaded Literal Value
 data OverLitVal
-  = HsIntegral   !SourceText !Integer    -- ^ Integer-looking literals;
+  = HsIntegral   !IntegralLit            -- ^ Integer-looking literals;
   | HsFractional !FractionalLit          -- ^ Frac-looking literals
   | HsIsString   !SourceText !FastString -- ^ String-looking literals
   deriving Data
 
+negateOverLitVal :: OverLitVal -> OverLitVal
+negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
+negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
+negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
+
 overLitType :: HsOverLit a -> PostTc a Type
 overLitType = ol_type
 
@@ -146,7 +152,7 @@ instance Eq (HsOverLit id) where
   (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
 
 instance Eq OverLitVal where
-  (HsIntegral _ i1)   == (HsIntegral _ i2)   = i1 == i2
+  (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2
   (HsFractional f1)   == (HsFractional f2)   = f1 == f2
   (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2
   _                   == _                   = False
@@ -155,14 +161,14 @@ instance Ord (HsOverLit id) where
   compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
 
 instance Ord OverLitVal where
-  compare (HsIntegral _ i1)   (HsIntegral _ i2)   = i1 `compare` i2
-  compare (HsIntegral _ _)    (HsFractional _)    = LT
-  compare (HsIntegral _ _)    (HsIsString _ _)    = LT
+  compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2
+  compare (HsIntegral _)      (HsFractional _)    = LT
+  compare (HsIntegral _)      (HsIsString _ _)    = LT
   compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2
-  compare (HsFractional _)    (HsIntegral _ _)    = GT
+  compare (HsFractional _)    (HsIntegral   _)    = GT
   compare (HsFractional _)    (HsIsString _ _)    = LT
   compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `compare` s2
-  compare (HsIsString _ _)    (HsIntegral _ _)    = GT
+  compare (HsIsString _ _)    (HsIntegral   _)    = GT
   compare (HsIsString _ _)    (HsFractional _)    = GT
 
 instance Outputable HsLit where
@@ -170,7 +176,7 @@ instance Outputable HsLit where
     ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)
     ppr (HsString st s)     = pprWithSourceText st (pprHsString s)
     ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
-    ppr (HsInt st i)        = pprWithSourceText st (integer i)
+    ppr (HsInt i)           = pprWithSourceText (il_text i) (integer (il_value i))
     ppr (HsInteger st i _)  = pprWithSourceText st (integer i)
     ppr (HsRat f _)         = ppr f
     ppr (HsFloatPrim f)     = ppr f <> primFloatSuffix
@@ -190,7 +196,7 @@ instance (OutputableBndrId id) => Outputable (HsOverLit id) where
         = ppr val <+> (ifPprDebug (parens (pprExpr witness)))
 
 instance Outputable OverLitVal where
-  ppr (HsIntegral st i)  = pprWithSourceText st (integer i)
+  ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))
   ppr (HsFractional f)   = ppr f
   ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)
 
@@ -205,7 +211,7 @@ pmPprHsLit (HsChar _ c)       = pprHsChar c
 pmPprHsLit (HsCharPrim _ c)   = pprHsChar c
 pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)
 pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
-pmPprHsLit (HsInt _ i)        = integer i
+pmPprHsLit (HsInt i)          = integer (il_value i)
 pmPprHsLit (HsIntPrim _ i)    = integer i
 pmPprHsLit (HsWordPrim _ w)   = integer w
 pmPprHsLit (HsInt64Prim _ i)  = integer i
index 1be9055..441380c 100644 (file)
@@ -219,7 +219,7 @@ nlParPat p = noLoc (ParPat p)
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
 
-mkHsIntegral   :: SourceText -> Integer -> PostTc RdrName Type
+mkHsIntegral   :: IntegralLit -> PostTc RdrName Type
                -> HsOverLit RdrName
 mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
 mkHsIsString :: SourceText -> FastString -> PostTc RdrName Type
@@ -245,7 +245,7 @@ emptyRecStmtId   :: StmtLR Id   Id      bodyR
 mkRecStmt    :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
 
 
-mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noExpr
+mkHsIntegral     i  = OverLit (HsIntegral       i) noRebindableInfo noExpr
 mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
 mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
 
@@ -377,6 +377,9 @@ nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
 nlHsLit :: HsLit -> LHsExpr id
 nlHsLit n = noLoc (HsLit n)
 
+nlHsIntLit :: Integer -> LHsExpr id
+nlHsIntLit n = noLoc (HsLit (HsInt (mkIntegralLit n)))
+
 nlVarPat :: id -> LPat id
 nlVarPat n = noLoc (VarPat (noLoc n))
 
@@ -398,9 +401,6 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
   = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
                                                      mkLHsWrap arg_wraps args))
 
-nlHsIntLit :: Integer -> LHsExpr id
-nlHsIntLit n = noLoc (HsLit (HsInt NoSourceText n))
-
 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
 
index 4c86688..6ebd087 100644 (file)
@@ -114,7 +114,8 @@ import DynFlags
 -- compiler/basicTypes
 import SrcLoc
 import Module
-import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..),
+import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..),
+                        IntegralLit(..), FractionalLit(..),
                         SourceText(..) )
 
 -- compiler/parser
@@ -707,7 +708,7 @@ data Token
 
   | ITchar     SourceText Char       -- Note [Literal source text] in BasicTypes
   | ITstring   SourceText FastString -- Note [Literal source text] in BasicTypes
-  | ITinteger  SourceText Integer    -- Note [Literal source text] in BasicTypes
+  | ITinteger  IntegralLit           -- Note [Literal source text] in BasicTypes
   | ITrational FractionalLit
 
   | ITprimchar   SourceText Char     -- Note [Literal source text] in BasicTypes
@@ -1276,15 +1277,21 @@ tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
        $! transint $ parseUnsignedInteger
        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 
--- some conveniences for use with tok_integral
 tok_num :: (Integer -> Integer)
-        -> Int -> Int
-        -> (Integer, (Char->Int)) -> Action
-tok_num = tok_integral ITinteger
+                        -> Int -> Int
+                        -> (Integer, (Char->Int)) -> Action
+tok_num = tok_integral itint
+  where
+    itint st@(SourceText ('-':str)) val = ITinteger (((IL $! st) $! True)      $! val)
+    itint st@(SourceText      str ) val = ITinteger (((IL $! st) $! False)     $! val)
+    itint st@(NoSourceText        ) val = ITinteger (((IL $! st) $! (val < 0)) $! val)
+
 tok_primint :: (Integer -> Integer)
             -> Int -> Int
             -> (Integer, (Char->Int)) -> Action
 tok_primint = tok_integral ITprimint
+
+
 tok_primword :: Int -> Int
              -> (Integer, (Char->Int)) -> Action
 tok_primword = tok_integral ITprimword positive
@@ -1299,12 +1306,14 @@ hexadecimal = (16,hexDigit)
 
 -- readRational can understand negative rationals, exponents, everything.
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float        str = ITrational   $! readFractionalLit str
-tok_primfloat    str = ITprimfloat  $! readFractionalLit str
-tok_primdouble   str = ITprimdouble $! readFractionalLit str
+tok_float      str  = ITrational   $! readFractionalLit str
+tok_primfloat  str  = ITprimfloat  $! readFractionalLit str
+tok_primdouble str  = ITprimdouble $! readFractionalLit str
 
 readFractionalLit :: String -> FractionalLit
-readFractionalLit str = (FL $! str) $! readRational str
+readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
+                        where is_neg = case str of ('-':_) -> True
+                                                   _       -> False
 
 -- -----------------------------------------------------------------------------
 -- Layout processing
index 21f564e..7af0205 100644 (file)
@@ -499,7 +499,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
 
  CHAR           { L _ (ITchar   _ _) }
  STRING         { L _ (ITstring _ _) }
- INTEGER        { L _ (ITinteger _ _) }
+ INTEGER        { L _ (ITinteger _) }
  RATIONAL       { L _ (ITrational _) }
 
  PRIMCHAR       { L _ (ITprimchar   _ _) }
@@ -928,7 +928,7 @@ impspec :: { Located (Bool, Located [LIE RdrName]) }
 prec    :: { Located (SourceText,Int) }
         : {- empty -}           { noLoc (NoSourceText,9) }
         | INTEGER
-                 {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (getINTEGER $1))) }
+                 {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }
 
 infix   :: { Located FixityDirection }
         : 'infix'                               { sL1 $1 InfixN  }
@@ -1544,9 +1544,9 @@ rule_activation :: { ([AddAnn],Maybe Activation) }
 rule_explicit_activation :: { ([AddAnn]
                               ,Activation) }  -- In brackets
         : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]
-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (getINTEGER $2))) }
+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }
         | '[' '~' INTEGER ']'   { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4]
-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) }
+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }
         | '[' '~' ']'           { ([mos $1,mj AnnTilde $2,mcs $3]
                                   ,NeverActive) }
 
@@ -1901,7 +1901,7 @@ atype :: { LHsType RdrName }
                                                      placeHolderKind ($2 : $4))
                                                  [mos $1,mcs $5] }
         | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
-                                                               (getINTEGER $1) }
+                                                               (il_value (getINTEGER $1)) }
         | STRING               { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
                                                                (getSTRING  $1) }
         | '_'                  { sL1 $1 $ mkAnonWildCardTy }
@@ -2307,10 +2307,10 @@ activation :: { ([AddAnn],Maybe Activation) }
 
 explicit_activation :: { ([AddAnn],Activation) }  -- In brackets
         : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]
-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (getINTEGER $2))) }
+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }
         | '[' '~' INTEGER ']'   { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3
                                                  ,mj AnnCloseS $4]
-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (getINTEGER $3))) }
+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }
 
 -----------------------------------------------------------------------------
 -- Expressions
@@ -2443,11 +2443,11 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
                                               ,mj AnnVal $9,mc $10],
                                                 getGENERATED_PRAGs $1)
                                               ,((getStringLiteral $2)
-                                               ,( fromInteger $ getINTEGER $3
-                                                , fromInteger $ getINTEGER $5
+                                               ,( fromInteger $ il_value $ getINTEGER $3
+                                                , fromInteger $ il_value $ getINTEGER $5
                                                 )
-                                               ,( fromInteger $ getINTEGER $7
-                                                , fromInteger $ getINTEGER $9
+                                               ,( fromInteger $ il_value $ getINTEGER $7
+                                                , fromInteger $ il_value $ getINTEGER $9
                                                 )
                                                ))
                                              , (( getINTEGERs $3
@@ -2491,7 +2491,7 @@ aexp2   :: { LHsExpr RdrName }
 -- into HsOverLit when -foverloaded-strings is on.
 --      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
 --                                       (getSTRING $1) placeHolderType) }
-        | INTEGER   { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGERs $1)
+        | INTEGER   { sL (getLoc $1) (HsOverLit $! mkHsIntegral
                                          (getINTEGER $1) placeHolderType) }
         | RATIONAL  { sL (getLoc $1) (HsOverLit $! mkHsFractional
                                           (getRATIONAL $1) placeHolderType) }
@@ -3394,7 +3394,7 @@ getIPDUPVARID   (L _ (ITdupipvarid   x)) = x
 getLABELVARID   (L _ (ITlabelvarid   x)) = x
 getCHAR         (L _ (ITchar   _ x)) = x
 getSTRING       (L _ (ITstring _ x)) = x
-getINTEGER      (L _ (ITinteger _ x)) = x
+getINTEGER      (L _ (ITinteger x))  = x
 getRATIONAL     (L _ (ITrational x)) = x
 getPRIMCHAR     (L _ (ITprimchar _ x)) = x
 getPRIMSTRING   (L _ (ITprimstring _ x)) = x
@@ -3414,9 +3414,9 @@ getDOCPREV (L _ (ITdocCommentPrev x)) = x
 getDOCNAMED (L _ (ITdocCommentNamed x)) = x
 getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
 
+getINTEGERs     (L _ (ITinteger (IL src _ _))) = src
 getCHARs        (L _ (ITchar       src _)) = src
 getSTRINGs      (L _ (ITstring     src _)) = src
-getINTEGERs     (L _ (ITinteger    src _)) = src
 getPRIMCHARs    (L _ (ITprimchar   src _)) = src
 getPRIMSTRINGs  (L _ (ITprimstring src _)) = src
 getPRIMINTEGERs (L _ (ITprimint    src _)) = src
index 987b0be..154e270 100644 (file)
@@ -152,8 +152,11 @@ rnExpr (HsLit lit)
        ; return (HsLit lit, emptyFVs) }
 
 rnExpr (HsOverLit lit)
-  = do { (lit', fvs) <- rnOverLit lit
-       ; return (HsOverLit lit', fvs) }
+  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
+       ; case mb_neg of
+              Nothing -> return (HsOverLit lit', fvs)
+              Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit'))
+                                 , fvs ) }
 
 rnExpr (HsApp fun arg)
   = do { (fun',fvFun) <- rnLExpr fun
index df13ced..77e2134 100644 (file)
@@ -414,17 +414,25 @@ rnPatAndThen mk (LitPat lit)
     normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
 
 rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
-  = do { lit'    <- liftCpsFV $ rnOverLit lit
-       ; mb_neg' <- liftCpsFV $ case mb_neg of
-                      Nothing -> return (Nothing, emptyFVs)
-                      Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
-                                    ; return (Just neg, fvs) }
+  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
+       ; mb_neg' -- See Note [Negative zero]
+           <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
+                                ; return (Just neg, fvs) }
+                  positive = return (Nothing, emptyFVs)
+              in liftCpsFV $ case (mb_neg , mb_neg') of
+                                  (Nothing, Just _ ) -> negative
+                                  (Just _ , Nothing) -> negative
+                                  (Nothing, Nothing) -> positive
+                                  (Just _ , Just _ ) -> positive
        ; eq' <- liftCpsFV $ lookupSyntaxName eqName
        ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
 
 rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
   = do { new_name <- newPatName mk rdr
-       ; lit'  <- liftCpsFV $ rnOverLit lit
+       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
+                                                -- We skip negateName as
+                                                -- negative zero doesn't make
+                                                -- sense in n + k pattenrs
        ; minus <- liftCpsFV $ lookupSyntaxName minusName
        ; ge    <- liftCpsFV $ lookupSyntaxName geName
        ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
@@ -823,11 +831,31 @@ rnLit _ = return ()
 -- Turn a Fractional-looking literal which happens to be an integer into an
 -- Integer-looking literal.
 generalizeOverLitVal :: OverLitVal -> OverLitVal
-generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val}))
-    | denominator val == 1 = HsIntegral (SourceText src) (numerator val)
+generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
+    | denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
 generalizeOverLitVal lit = lit
 
-rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
+isNegativeZeroOverLit :: HsOverLit t -> Bool
+isNegativeZeroOverLit lit
+ = case ol_val lit of
+        HsIntegral i   -> 0 == il_value i && il_neg i
+        HsFractional f -> 0 == fl_value f && fl_neg f
+        _              -> False
+
+{-
+Note [Negative zero]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There were problems with negative zero in conjunction with Negative Literals
+extension. Numeric literal value is contained in Integer and Rational types
+inside IntegralLit and FractionalLit. These types cannot represent negative
+zero value. So we had to add explicit field 'neg' which would hold information
+about literal sign. Here in rnOverLit we use it to detect negative zeroes and
+in this case return not only literal itself but also negateName so that users
+can apply it explicitly. In this case it stays negative zero.  Trac #13211
+-}
+
+rnOverLit :: HsOverLit t ->
+             RnM ((HsOverLit Name, Maybe (HsExpr Name)), FreeVars)
 rnOverLit origLit
   = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals
         ; let { lit@(OverLit {ol_val=val})
@@ -835,14 +863,20 @@ rnOverLit origLit
             | otherwise       = origLit
           }
         ; let std_name = hsOverLitName val
-        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs)
+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
             <- lookupSyntaxName std_name
         ; let rebindable = case from_thing_name of
                                 HsVar (L _ v) -> v /= std_name
                                 _             -> panic "rnOverLit"
-        ; return (lit { ol_witness = from_thing_name
-                      , ol_rebindable = rebindable
-                      , ol_type = placeHolderType }, fvs) }
+        ; let lit' = lit { ol_witness = from_thing_name
+                         , ol_rebindable = rebindable
+                         , ol_type = placeHolderType }
+        ; if isNegativeZeroOverLit lit'
+          then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
+                      <- lookupSyntaxName negateName
+                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
+                                  , fvs1 `plusFV` fvs2) }
+          else return ((lit', Nothing), fvs1) }
 
 {-
 ************************************************************************
index eff8c5f..a83bbae 100644 (file)
@@ -34,7 +34,7 @@ module Inst (
 import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
 import {-# SOURCE #-}   TcUnify( unifyType, unifyKind, noThing )
 
-import BasicTypes ( SourceText(..) )
+import BasicTypes ( IntegralLit(..), SourceText(..) )
 import FastString
 import HsSyn
 import TcHsSyn
@@ -549,9 +549,9 @@ newNonTrivialOverloadedLit _ lit _
 
 ------------
 mkOverLit :: OverLitVal -> TcM HsLit
-mkOverLit (HsIntegral src i)
+mkOverLit (HsIntegral i)
   = do  { integer_ty <- tcMetaTy integerTyConName
-        ; return (HsInteger src i integer_ty) }
+        ; return (HsInteger (il_text i) (il_value i) integer_ty) }
 
 mkOverLit (HsFractional r)
   = do  { rat_ty <- tcMetaTy rationalTyConName
index 96513da..7eca4ce 100644 (file)
@@ -607,8 +607,9 @@ gen_Enum_binds loc tycon = do
                                nlHsVarApps intDataCon_RDR [ah_RDR]])
              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
              (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
-                           (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
-                                           nlHsLit (HsInt NoSourceText (-1))]))
+                      (nlHsApps plus_RDR
+                                [ nlHsVarApps intDataCon_RDR [ah_RDR]
+                                , nlHsLit (HsInt (mkIntegralLit (-1 :: Int)))]))
 
     to_enum dflags
       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
@@ -1125,7 +1126,7 @@ gen_Show_binds get_fixity loc tycon
       | otherwise   =
          ([a_Pat, con_pat],
           showParen_Expr (genOpApp a_Expr ge_RDR
-                              (nlHsLit (HsInt NoSourceText con_prec_plus_one)))
+                              (nlHsLit (HsInt (mkIntegralLit con_prec_plus_one))))
                          (nlHsPar (nested_compose_Expr show_thingies)))
         where
              data_con_RDR  = getRdrName data_con
@@ -1209,7 +1210,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st
 -- | showsPrec :: Show a => Int -> a -> ShowS
 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
 mk_showsPrec_app p x
-  = nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x]
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt (mkIntegralLit p)), x]
 
 -- | shows :: Show a => a -> ShowS
 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
index 6ad2b28..1b9fed9 100644 (file)
@@ -18,7 +18,6 @@ module TcHsSyn (
         -- * Other HsSyn functions
         mkHsDictLet, mkHsApp,
         mkHsAppTy, mkHsCaseAlt,
-        nlHsIntLit,
         shortCutLit, hsOverLitName,
         conLikeResTy,
 
@@ -112,7 +111,7 @@ hsLitType (HsChar _ _)       = charTy
 hsLitType (HsCharPrim _ _)   = charPrimTy
 hsLitType (HsString _ _)     = stringTy
 hsLitType (HsStringPrim _ _) = addrPrimTy
-hsLitType (HsInt _ _)        = intTy
+hsLitType (HsInt _)          = intTy
 hsLitType (HsIntPrim _ _)    = intPrimTy
 hsLitType (HsWordPrim _ _)   = wordPrimTy
 hsLitType (HsInt64Prim _ _)  = int64PrimTy
@@ -125,12 +124,11 @@ hsLitType (HsDoublePrim _)   = doublePrimTy
 -- Overloaded literals. Here mainly because it uses isIntTy etc
 
 shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
-shortCutLit dflags (HsIntegral src i) ty
-  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt src i))
-  | isWordTy ty && inWordRange dflags i
-                                   = Just (mkLit wordDataCon (HsWordPrim src i))
+shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt int))
+  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
   | isIntegerTy ty = Just (HsLit (HsInteger src i ty))
-  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
+  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
         -- The 'otherwise' case is important
         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
         -- so we'll call shortCutIntLit, but of course it's a float
index 0e8ce7c..cb73b42 100644 (file)
@@ -24,7 +24,7 @@
 
 (LiteralsTest.hs:5:3,ITequal,[=]),
 
-(LiteralsTest.hs:5:5-8,ITinteger (SourceText "0003") 3,[0003]),
+(LiteralsTest.hs:5:5-8,ITinteger (IL {il_text = SourceText "0003", il_neg = False, il_value = 3}),[0003]),
 
 (LiteralsTest.hs:6:1,ITsemi,[]),
 
@@ -32,7 +32,7 @@
 
 (LiteralsTest.hs:6:3,ITequal,[=]),
 
-(LiteralsTest.hs:6:5-8,ITinteger (SourceText "0x04") 4,[0x04]),
+(LiteralsTest.hs:6:5-8,ITinteger (IL {il_text = SourceText "0x04", il_neg = False, il_value = 4}),[0x04]),
 
 (LiteralsTest.hs:8:1,ITsemi,[]),
 
@@ -80,7 +80,7 @@
 
 (LiteralsTest.hs:15:3,ITequal,[=]),
 
-(LiteralsTest.hs:15:5-8,ITrational (FL {fl_text = "0.00", fl_value = 0 % 1}),[0.00]),
+(LiteralsTest.hs:15:5-8,ITrational (FL {fl_text = SourceText "0.00", fl_neg = False, fl_value = 0 % 1}),[0.00]),
 
 (LiteralsTest.hs:17:1,ITsemi,[]),
 
 
 (LiteralsTest.hs:22:12,ITequal,[=]),
 
-(LiteralsTest.hs:22:14-18,ITprimfloat (FL {fl_text = "3.20", fl_value = 16 % 5}),[3.20#]),
+(LiteralsTest.hs:22:14-18,ITprimfloat (FL {fl_text = SourceText "3.20", fl_neg = False, fl_value = 16 % 5}),[3.20#]),
 
 (LiteralsTest.hs:23:5,ITsemi,[]),
 
 
 (LiteralsTest.hs:23:13,ITequal,[=]),
 
-(LiteralsTest.hs:23:15-21,ITprimdouble (FL {fl_text = "04.16", fl_value = 104 % 25}),[04.16##]),
+(LiteralsTest.hs:23:15-21,ITprimdouble (FL {fl_text = SourceText "04.16", fl_neg = False, fl_value = 104 % 25}),[04.16##]),
 
 (LiteralsTest.hs:24:5,ITsemi,[]),
 
 
 (LiteralsTest.hs:24:7,ITequal,[=]),
 
-(LiteralsTest.hs:24:9,ITinteger (SourceText "1") 1,[1]),
+(LiteralsTest.hs:24:9,ITinteger (IL {il_text = SourceText "1", il_neg = False, il_value = 1}),[1]),
 
 (LiteralsTest.hs:25:1,ITvccurly,[]),
 
index 0170bc2..d040a6d 100644 (file)
@@ -50,7 +50,7 @@ testOneFile libdir fileName = do
        = ["HsString [" ++ src ++ "] " ++ show c]
      doHsLit (HsStringPrim (SourceText src) c)
        = ["HsStringPrim [" ++ src ++ "] " ++ show c]
-     doHsLit (HsInt        (SourceText src) c)
+     doHsLit (HsInt        (IL (SourceText src) _ c))
        = ["HsInt [" ++ src ++ "] " ++ show c]
      doHsLit (HsIntPrim    (SourceText src) c)
        = ["HsIntPrim [" ++ src ++ "] " ++ show c]
@@ -65,7 +65,7 @@ testOneFile libdir fileName = do
      doHsLit _ = []
 
      doOverLit :: OverLitVal -> [String]
-     doOverLit (HsIntegral  (SourceText src) c)
+     doOverLit (HsIntegral  (IL (SourceText src) _ c))
        = ["HsIntegral [" ++ src ++ "] " ++ show c]
      doOverLit (HsIsString  (SourceText src) c)
        = ["HsIsString [" ++ src ++ "] " ++ show c]
diff --git a/testsuite/tests/parser/should_run/NegativeZero.hs b/testsuite/tests/parser/should_run/NegativeZero.hs
new file mode 100644 (file)
index 0000000..36e483b
--- /dev/null
@@ -0,0 +1,25 @@
+-- | Test for @NegativeLiterals@ extension (see GHC #13211)
+
+{-# LANGUAGE NegativeLiterals #-}
+
+floatZero0 = 0 :: Float
+floatZero1 = 0.0 :: Float
+
+floatNegZero0 = -0 :: Float
+floatNegZero1 = -0.0 :: Float
+
+doubleZero0 = 0 :: Double
+doubleZero1 = 0.0 :: Double
+
+doubleNegZero0 = -0 :: Double
+doubleNegZero1 = -0.0 :: Double
+
+main = do
+    print (isNegativeZero floatZero0)
+    print (isNegativeZero floatZero1)
+    print (isNegativeZero floatNegZero0)
+    print (isNegativeZero floatNegZero1)
+    print (isNegativeZero doubleZero0)
+    print (isNegativeZero doubleZero1)
+    print (isNegativeZero doubleNegZero0)
+    print (isNegativeZero doubleNegZero1)
diff --git a/testsuite/tests/parser/should_run/NegativeZero.stdout b/testsuite/tests/parser/should_run/NegativeZero.stdout
new file mode 100644 (file)
index 0000000..9dc2123
--- /dev/null
@@ -0,0 +1,8 @@
+False
+False
+True
+True
+False
+False
+True
+True
index bb5e4fd..31dea7f 100644 (file)
@@ -10,3 +10,4 @@ test('BinaryLiterals0', normal, compile_and_run, [''])
 test('BinaryLiterals1', [], compile_and_run, [''])
 test('BinaryLiterals2', [], compile_and_run, [''])
 test('T10807', normal, compile_and_run, [''])
+test('NegativeZero', normal, compile_and_run, [''])
index 4ee88d1..a5ef47e 100644 (file)
@@ -744,7 +744,7 @@ test('T9020',
 test('T9675',
      [ only_ways(['optasm']),
        compiler_stats_num_field('max_bytes_used', # Note [residency]
-          [(wordsize(64), 17675240, 15),
+          [(wordsize(64), 25381032, 15),
           # 2014-10-13    29596552
           # 2014-10-13    26570896   seq the DmdEnv in seqDmdType as well
           # 2014-10-13    18582472   different machines giving different results..
@@ -755,12 +755,13 @@ test('T9675',
           # 2016-03-14    38776008   Final demand analyzer run
           # 2016-04-01    29871032   Fix leaks in demand analysis
           # 2016-04-30    17675240   Fix leaks in tidy unfoldings
+          # 2017-05-08    25381032   Fix negative zero (see #13211)
            (wordsize(32), 18043224, 15)
           # 2015-07-11    15341228   (x86/Linux, 64-bit machine) use +RTS -G1
           # 2016-04-06    18043224   (x86/Linux, 64-bit machine)
           ]),
        compiler_stats_num_field('peak_megabytes_allocated', # Note [residency]
-          [(wordsize(64), 63, 15),
+          [(wordsize(64), 94, 15),
           # 2014-10-13    66
           # 2014-10-13    58         seq the DmdEnv in seqDmdType as well
           # 2014-10-13    49         different machines giving different results...
@@ -772,6 +773,7 @@ test('T9675',
           # 2016-04-14    144        Final demand analyzer run
           # 2016-07-26    121        Unboxed sums?
           # 2017-04-30    63         Fix leaks in tidy unfoldings
+          # 2017-05-08    94         Fix negative zero (see #13211)
             (wordsize(32), 56, 15)
           # 2015-07-11    56         (x86/Linux, 64-bit machine) use +RTS -G1
           ]),