Commit 0279b745 authored by Nolan's avatar Nolan Committed by Ben Gamari

Make XNegativeLiterals treat -0.0 as negative 0

Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, mpickering

GHC Trac Issues: #13211

Differential Revision: https://phabricator.haskell.org/D3543
parent dc3b4af6
......@@ -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))
{-
************************************************************************
......
......@@ -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 }]
......
......@@ -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'] }
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 =