Skip to content

GitLab

GHC
GHC
Commit 0279b745 authored by Nolan's avatar Nolan Committed by Ben Gamari
Browse files
Options

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
Hide whitespace changes
Inline Side-by-side
Showing with 260 additions and 122 deletions
compiler/basicTypes/BasicTypes.hs
View file @ 0279b745
......@@ -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))
{-
************************************************************************
......
compiler/deSugar/Check.hs
View file @ 0279b745
......@@ -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 }]
......
compiler/deSugar/DsExpr.hs
View file @ 0279b745
......@@ -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'] }
......
compiler/deSugar/DsMeta.hs
View file @ 0279b745
......@@ -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
......
compiler/deSugar/Match.hs
View file @ 0279b745
......@@ -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))
......
compiler/deSugar/MatchLit.hs
View file @ 0279b745
......@@ -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
......
compiler/hsSyn/Convert.hs
View file @ 0279b745
......@@ -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 ()
......
compiler/hsSyn/HsLit.hs
View file @ 0279b745
......@@ -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
......
compiler/hsSyn/HsUtils.hs
View file @ 0279b745
......@@ -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
......
compiler/parser/Lexer.x
View file @ 0279b745
......@@ -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
......
compiler/parser/Parser.y
View file @ 0279b745
......@@ -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
......
compiler/rename/RnExpr.hs
View file @ 0279b745
......@@ -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
......
compiler/rename/RnPat.hs
View file @ 0279b745
......@@ -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