summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/BasicTypes.hs62
-rw-r--r--compiler/deSugar/Check.hs20
-rw-r--r--compiler/deSugar/DsExpr.hs4
-rw-r--r--compiler/deSugar/DsMeta.hs7
-rw-r--r--compiler/deSugar/Match.hs8
-rw-r--r--compiler/deSugar/MatchLit.hs21
-rw-r--r--compiler/hsSyn/Convert.hs11
-rw-r--r--compiler/hsSyn/HsLit.hs32
-rw-r--r--compiler/hsSyn/HsUtils.hs10
-rw-r--r--compiler/parser/Lexer.x29
-rw-r--r--compiler/parser/Parser.y28
-rw-r--r--compiler/rename/RnExpr.hs7
-rw-r--r--compiler/rename/RnPat.hs60
-rw-r--r--compiler/typecheck/Inst.hs6
-rw-r--r--compiler/typecheck/TcGenDeriv.hs9
-rw-r--r--compiler/typecheck/TcHsSyn.hs12
-rw-r--r--testsuite/tests/ghc-api/annotations-literals/literals.stdout12
-rw-r--r--testsuite/tests/ghc-api/annotations-literals/parsed.hs4
-rw-r--r--testsuite/tests/parser/should_run/NegativeZero.hs25
-rw-r--r--testsuite/tests/parser/should_run/NegativeZero.stdout8
-rw-r--r--testsuite/tests/parser/should_run/all.T1
-rw-r--r--testsuite/tests/perf/compiler/all.T6
22 files changed, 260 insertions, 122 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 03e588cd93..b67e6628ee 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -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))
{-
************************************************************************
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 1b02502a31..96bc235f51 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -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 }]
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index d4a96e6f3f..ff6527f6d4 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -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'] }
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 78804746d4..bb4361e34a 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index abe4dc77b2..14166205e2 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -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))
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 6ed34f42db..e04e618341 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -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
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 8d90344f2f..594711de6f 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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 ()
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index fe60748602..0226591729 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 1be9055402..441380c36b 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 4c86688ea9..6ebd0877e7 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 21f564e2b9..7af02053fd 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 987b0bec49..154e270b5a 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -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
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index df13cedf59..77e213410a 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -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) }
{-
************************************************************************
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index eff8c5f51b..a83bbae36f 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -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
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 96513da376..7eca4cebc4 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -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
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 6ad2b281f9..1b9fed98b6 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -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
diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
index 0e8ce7c9dc..cb73b42d4f 100644
--- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout
+++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout
@@ -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,[]),
@@ -122,7 +122,7 @@
(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,[]),
@@ -130,7 +130,7 @@
(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,[]),
@@ -138,7 +138,7 @@
(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,[]),
diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
index 0170bc2949..d040a6d3b2 100644
--- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs
+++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
@@ -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
index 0000000000..36e483bd37
--- /dev/null
+++ b/testsuite/tests/parser/should_run/NegativeZero.hs
@@ -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
index 0000000000..9dc212300a
--- /dev/null
+++ b/testsuite/tests/parser/should_run/NegativeZero.stdout
@@ -0,0 +1,8 @@
+False
+False
+True
+True
+False
+False
+True
+True
diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T
index bb5e4fde39..31dea7f5b7 100644
--- a/testsuite/tests/parser/should_run/all.T
+++ b/testsuite/tests/parser/should_run/all.T
@@ -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, [''])
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 4ee88d1b64..a5ef47e9bf 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -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
]),
View Lorry Controller Status