diff options
-rw-r--r-- | compiler/basicTypes/BasicTypes.hs | 62 | ||||
-rw-r--r-- | compiler/deSugar/Check.hs | 20 | ||||
-rw-r--r-- | compiler/deSugar/DsExpr.hs | 4 | ||||
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 7 | ||||
-rw-r--r-- | compiler/deSugar/Match.hs | 8 | ||||
-rw-r--r-- | compiler/deSugar/MatchLit.hs | 21 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.hs | 11 | ||||
-rw-r--r-- | compiler/hsSyn/HsLit.hs | 32 | ||||
-rw-r--r-- | compiler/hsSyn/HsUtils.hs | 10 | ||||
-rw-r--r-- | compiler/parser/Lexer.x | 29 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 28 | ||||
-rw-r--r-- | compiler/rename/RnExpr.hs | 7 | ||||
-rw-r--r-- | compiler/rename/RnPat.hs | 60 | ||||
-rw-r--r-- | compiler/typecheck/Inst.hs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 9 | ||||
-rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations-literals/literals.stdout | 12 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations-literals/parsed.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/parser/should_run/NegativeZero.hs | 25 | ||||
-rw-r--r-- | testsuite/tests/parser/should_run/NegativeZero.stdout | 8 | ||||
-rw-r--r-- | testsuite/tests/parser/should_run/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/perf/compiler/all.T | 6 |
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 ]), |