diff options
| -rw-r--r-- | compiler/main/DynFlags.hs | 1 | ||||
| -rw-r--r-- | compiler/parser/Lexer.x | 26 | ||||
| -rw-r--r-- | compiler/utils/Util.hs | 59 | ||||
| -rw-r--r-- | docs/users_guide/8.4.1-notes.rst | 5 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.rst | 44 | ||||
| -rw-r--r-- | libraries/base/Numeric.hs | 48 | ||||
| -rw-r--r-- | libraries/base/changelog.md | 2 | ||||
| -rw-r--r-- | libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs | 1 | ||||
| -rw-r--r-- | testsuite/tests/driver/T4437.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_run/HexFloatLiterals.hs | 16 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_run/HexFloatLiterals.stdout | 4 | ||||
| -rw-r--r-- | testsuite/tests/parser/should_run/all.T | 1 |
12 files changed, 203 insertions, 7 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 7fe7a17d33..904257e4d0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -3969,6 +3969,7 @@ xFlagsDeps = [ flagSpec "NamedFieldPuns" LangExt.RecordPuns, flagSpec "NamedWildCards" LangExt.NamedWildCards, flagSpec "NegativeLiterals" LangExt.NegativeLiterals, + flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses (deprecatedForExtension "MultiParamTypeClasses"), diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 3bf249bd7e..b2004a6cbb 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -105,7 +105,7 @@ import Outputable import StringBuffer import FastString import UniqFM -import Util ( readRational ) +import Util ( readRational, readHexRational ) -- compiler/main import ErrUtils @@ -182,6 +182,7 @@ $docsym = [\| \^ \* \$] @octal = $octit+ @hexadecimal = $hexit+ @exponent = [eE] [\-\+]? @decimal +@bin_exponent = [pP] [\-\+]? @decimal @qual = (@conid \.)+ @qvarid = @qual @varid @@ -190,6 +191,7 @@ $docsym = [\| \^ \* \$] @qconsym = @qual @consym @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent +@hex_floating_point = @hexadecimal \. @hexadecimal @bin_exponent? | @hexadecimal @bin_exponent -- normal signed numerical literals can only be explicitly negative, -- not explicitly positive (contrast @exponent) @@ -498,6 +500,9 @@ $tab { warnTab } -- Normal rational literals (:: Fractional a => a, from Rational) @floating_point { strtoken tok_float } @negative @floating_point / { ifExtension negativeLiteralsEnabled } { strtoken tok_float } + 0[xX] @hex_floating_point / { ifExtension hexFloatLiteralsEnabled } { strtoken tok_hex_float } + @negative 0[xX]@hex_floating_point / { ifExtension hexFloatLiteralsEnabled `alexAndPred` + ifExtension negativeLiteralsEnabled } { strtoken tok_hex_float } } <0> { @@ -1306,14 +1311,23 @@ 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_hex_float str = ITrational $! readHexFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str readFractionalLit :: String -> FractionalLit readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str where is_neg = case str of ('-':_) -> True _ -> False +readHexFractionalLit :: String -> FractionalLit +readHexFractionalLit str = + FL { fl_text = SourceText str + , fl_neg = case str of + '-' : _ -> True + _ -> False + , fl_value = readHexRational str + } -- ----------------------------------------------------------------------------- -- Layout processing @@ -2204,6 +2218,7 @@ data ExtBits | LambdaCaseBit | BinaryLiteralsBit | NegativeLiteralsBit + | HexFloatLiteralsBit | TypeApplicationsBit | StaticPointersBit deriving Enum @@ -2266,6 +2281,8 @@ binaryLiteralsEnabled :: ExtsBitmap -> Bool binaryLiteralsEnabled = xtest BinaryLiteralsBit negativeLiteralsEnabled :: ExtsBitmap -> Bool negativeLiteralsEnabled = xtest NegativeLiteralsBit +hexFloatLiteralsEnabled :: ExtsBitmap -> Bool +hexFloatLiteralsEnabled = xtest HexFloatLiteralsBit patternSynonymsEnabled :: ExtsBitmap -> Bool patternSynonymsEnabled = xtest PatternSynonymsBit typeApplicationEnabled :: ExtsBitmap -> Bool @@ -2323,6 +2340,7 @@ mkParserFlags flags = .|. LambdaCaseBit `setBitIf` xopt LangExt.LambdaCase flags .|. BinaryLiteralsBit `setBitIf` xopt LangExt.BinaryLiterals flags .|. NegativeLiteralsBit `setBitIf` xopt LangExt.NegativeLiterals flags + .|. HexFloatLiteralsBit `setBitIf` xopt LangExt.HexFloatLiterals flags .|. PatternSynonymsBit `setBitIf` xopt LangExt.PatternSynonyms flags .|. TypeApplicationsBit `setBitIf` xopt LangExt.TypeApplications flags .|. StaticPointersBit `setBitIf` xopt LangExt.StaticPointers flags diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 3b402f2833..7a46db7665 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -89,6 +89,7 @@ module Util ( -- * Floating point readRational, + readHexRational, -- * read helpers maybeRead, maybeReadFuzzy, @@ -143,7 +144,7 @@ import GHC.Exts import GHC.Stack (HasCallStack) import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM ) +import Control.Monad ( liftM, guard ) import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import GHC.Conc.Sync ( sharedCAF ) import System.IO (Handle, hGetEncoding, hSetEncoding) @@ -151,7 +152,8 @@ import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime ) import System.FilePath -import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper) +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper + , isHexDigit, digitToInt ) import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) @@ -1159,6 +1161,59 @@ readRational top_s _ -> error ("readRational: ambiguous parse:" ++ top_s) +readHexRational :: String -> Rational +readHexRational str = + case str of + '-' : xs -> - (readMe xs) + xs -> readMe xs + where + readMe as = + case readHexRational__ as of + Just n -> n + _ -> error ("readHexRational: no parse:" ++ str) + + +readHexRational__ :: String -> Maybe Rational +readHexRational__ ('0' : x : rest) + | x == 'X' || x == 'x' = + do let (front,rest2) = span isHexDigit rest + guard (not (null front)) + let frontNum = steps 16 0 front + case rest2 of + '.' : rest3 -> + do let (back,rest4) = span isHexDigit rest3 + guard (not (null back)) + let backNum = steps 16 frontNum back + exp1 = -4 * length back + case rest4 of + p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) + _ -> return (mk backNum exp1) + p : ps | isExp p -> fmap (mk frontNum) (getExp ps) + _ -> Nothing + + where + isExp p = p == 'p' || p == 'P' + + getExp ('+' : ds) = dec ds + getExp ('-' : ds) = fmap negate (dec ds) + getExp ds = dec ds + + mk :: Integer -> Int -> Rational + mk n e = fromInteger n * 2^^e + + dec cs = case span isDigit cs of + (ds,"") | not (null ds) -> Just (steps 10 0 ds) + _ -> Nothing + + steps base n ds = foldl' (step base) n ds + step base n d = base * n + fromIntegral (digitToInt d) + + +readHexRational__ _ = Nothing + + + + ----------------------------------------------------------------------------- -- read helpers diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst index d7e5d6d61e..21b19f1b45 100644 --- a/docs/users_guide/8.4.1-notes.rst +++ b/docs/users_guide/8.4.1-notes.rst @@ -100,6 +100,11 @@ Language :ghc-flag:`-XEmptyDataDeriving` to do so. This also goes for other classes which require extensions to derive, such as :ghc-flag:`-XDeriveFunctor`. +- Hexadecimal floating point literals (e.g. ``0x0.1p4``), enabled with + :ghc-flag:`HexFloatLiterals`. See + :ref:`Hexadecimal floating point literals <hex-float-literals>` + for the full details. + Compiler ~~~~~~~~ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 06f2263a73..3976befe57 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -509,6 +509,50 @@ integer literals in binary notation with the prefix ``0b`` or ``0B``. For instance, the binary integer literal ``0b11001001`` will be desugared into ``fromInteger 201`` when :extension:`BinaryLiterals` is enabled. +.. _hex-float-literals: + +Hexadecimal floating point literals +----------------------------------- + +.. ghc-flag:: -XHexFloatLiterals + :shortdesc: Enable support for :ref:`hexadecimal floating point literals <heax-float-literals>`. + :type: dynamic + :reverse: -XNoHexFloatLIterals + :category: + + :since: 8.4.1 + + Allow writing floating point literals using hexadecimal notation. + +The hexadecimal notation for floating point literals is useful when you +need to specify floating point constants precisely, as the literal notation +corresponds closely to the underlying bit-encoding of the number. + +In this notation floating point numbers are written using hexadecimal digits, +and so the digits are interpreted using base 16, rather then the usual 10. +This means that digits left of the decimal point correspond to positive +powers of 16, while the ones to the right correspond to negaitve ones. + +You may also write an explicit exponent, which is similar to the exponent +in decimal notation with the following differences: +- the exponent begins with ``p`` instead of ``e`` +- the exponent is written in base ``10`` (**not** 16) +- the base of the exponent is ``2`` (**not** 16). + +In terms of the underlying bit encoding, each hexadecimal digit corresponds +to 4 bits, and you may think of the exponent as "moving" the floating point +by one bit left (negative) or right (positive). Here are some examples: + +- ``0x0.1`` is the same as ``1/16`` +- ``0x0.01`` is the same as ``1/256`` +- ``0xF.FF`` is the same as ``15 + 15/16 + 15/256`` +- ``0x0.1p4`` is the same as ``1`` +- ``0x0.1p-4`` is the same as ``1/256`` +- ``0x0.1p12`` is the same as ``256`` + + + + .. _pattern-guards: Pattern guards diff --git a/libraries/base/Numeric.hs b/libraries/base/Numeric.hs index e040c455d6..00e5f674de 100644 --- a/libraries/base/Numeric.hs +++ b/libraries/base/Numeric.hs @@ -33,6 +33,7 @@ module Numeric ( showFFloatAlt, showGFloatAlt, showFloat, + showHFloat, floatToDigits, @@ -69,6 +70,7 @@ import GHC.Show import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail ) import qualified Text.Read.Lex as L + -- ----------------------------------------------------------------------------- -- Reading @@ -213,6 +215,52 @@ showGFloatAlt :: (RealFloat a) => Maybe Int -> a -> ShowS showFFloatAlt d x = showString (formatRealFloatAlt FFFixed d True x) showGFloatAlt d x = showString (formatRealFloatAlt FFGeneric d True x) +{- | Show a floating-point value in the hexadecimal format, +similar to the @%a@ specifier in C's printf. + + >>> showHFloat (212.21 :: Double) "" + "0x1.a86b851eb851fp7" + >>> showHFloat (-12.76 :: Float) "" + "-0x1.9851ecp3" + >>> showHFloat (-0 :: Double) "" + "-0x0p+0" +-} +showHFloat :: RealFloat a => a -> ShowS +showHFloat = showString . fmt + where + fmt x + | isNaN x = "NaN" + | isInfinite x = (if x < 0 then "-" else "") ++ "Infinity" + | x < 0 || isNegativeZero x = '-' : cvt (-x) + | otherwise = cvt x + + cvt x + | x == 0 = "0x0p+0" + | otherwise = + case floatToDigits 2 x of + r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r + (d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1) + + -- Given binary digits, convert them to hex in blocks of 4 + -- Special case: If all 0's, just drop it. + frac digits + | allZ digits = "" + | otherwise = "." ++ hex digits + where + hex ds = + case ds of + [] -> "" + [a] -> hexDigit a 0 0 0 "" + [a,b] -> hexDigit a b 0 0 "" + [a,b,c] -> hexDigit a b c 0 "" + a : b : c : d : r -> hexDigit a b c d (hex r) + + hexDigit a b c d = showHex (8*a + 4*b + 2*c + d) + + allZ xs = case xs of + x : more -> x == 0 && allZ more + [] -> True + -- --------------------------------------------------------------------------- -- Integer printing functions diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index bc0f4d4189..34911a9f09 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -3,6 +3,8 @@ ## 4.11.0.0 *TBA* * Bundled with GHC 8.4.1 + * Add `showHFloat` to `Numeric` + * Add `Div`, `Mod`, and `Log2` functions on type-level naturals in `GHC.TypeLits`. diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 1979838a07..3e8c2a0e15 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -120,6 +120,7 @@ data Extension | MultiWayIf | BinaryLiterals | NegativeLiterals + | HexFloatLiterals | DuplicateRecordFields | OverloadedLabels | EmptyCase diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index c26a38861c..4e7ddd7482 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -41,7 +41,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRuleTransitional", "UnboxedSums", "DerivingStrategies", - "EmptyDataDeriving"] + "EmptyDataDeriving", + "HexFloatLiterals"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/parser/should_run/HexFloatLiterals.hs b/testsuite/tests/parser/should_run/HexFloatLiterals.hs new file mode 100644 index 0000000000..5e71ac340d --- /dev/null +++ b/testsuite/tests/parser/should_run/HexFloatLiterals.hs @@ -0,0 +1,16 @@ +{-# Language HexFloatLiterals #-} + +import Numeric(showHFloat) + +main :: IO () +main = + do print [ 0xF.0 + , 0xF.1, 0xF.01 + , 0xF1p-4, 0xF01p-8 + , 0x0.F1p4, 0x0.00F01p12 + ] + + mapM_ putStrLn [ showHFloat (212.21 :: Double) "" + , showHFloat (-12.76 :: Float) "" + , showHFloat (-0 :: Double) "" + ] diff --git a/testsuite/tests/parser/should_run/HexFloatLiterals.stdout b/testsuite/tests/parser/should_run/HexFloatLiterals.stdout new file mode 100644 index 0000000000..20ce2a245a --- /dev/null +++ b/testsuite/tests/parser/should_run/HexFloatLiterals.stdout @@ -0,0 +1,4 @@ +[15.0,15.0625,15.00390625,15.0625,15.00390625,15.0625,15.00390625] +0x1.a86b851eb851fp7 +-0x1.9851ecp3 +-0x0p+0 diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T index 31dea7f5b7..bcf0bc83f3 100644 --- a/testsuite/tests/parser/should_run/all.T +++ b/testsuite/tests/parser/should_run/all.T @@ -11,3 +11,4 @@ test('BinaryLiterals1', [], compile_and_run, ['']) test('BinaryLiterals2', [], compile_and_run, ['']) test('T10807', normal, compile_and_run, ['']) test('NegativeZero', normal, compile_and_run, ['']) +test('HexFloatLiterals', normal, compile_and_run, ['']) |