Implement the basics of hex floating point literals
authorIavor Diatchki <iavor.diatchki@gmail.com>
Thu, 2 Nov 2017 16:02:22 +0000 (12:02 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 2 Nov 2017 17:19:35 +0000 (13:19 -0400)
Implement hexadecmial floating point literals.

The digits of the mantissa are hexadecimal.
The exponent is written in base 10, and the base for the exponentiation is 2.
Hexadecimal literals look a lot like ordinary decimal literals, except that
they use hexadecmial digits, and the exponent is written using `p` rather than `e`.

The specification of the feature is available here:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0004-hexFloats.rst

For a discussion of the various choices:
https://github.com/ghc-proposals/ghc-proposals/pull/37

Reviewers: mpickering, goldfire, austin, bgamari, hvr

Reviewed By: bgamari

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D3066

12 files changed:
compiler/main/DynFlags.hs
compiler/parser/Lexer.x
compiler/utils/Util.hs
docs/users_guide/8.4.1-notes.rst
docs/users_guide/glasgow_exts.rst
libraries/base/Numeric.hs
libraries/base/changelog.md
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
testsuite/tests/driver/T4437.hs
testsuite/tests/parser/should_run/HexFloatLiterals.hs [new file with mode: 0644]
testsuite/tests/parser/should_run/HexFloatLiterals.stdout [new file with mode: 0644]
testsuite/tests/parser/should_run/all.T

index 7fe7a17..904257e 100644 (file)
@@ -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"),
index 3bf249b..b2004a6 100644 (file)
@@ -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
index 3b402f2..7a46db7 100644 (file)
@@ -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
 
index d7e5d6d..21b19f1 100644 (file)
@@ -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
 ~~~~~~~~
 
index 06f2263..3976bef 100644 (file)
@@ -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
index e040c45..00e5f67 100644 (file)
@@ -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
 
index bc0f4d4..34911a9 100644 (file)
@@ -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`.
 
index 1979838..3e8c2a0 100644 (file)
@@ -120,6 +120,7 @@ data Extension
    | MultiWayIf
    | BinaryLiterals
    | NegativeLiterals
+   | HexFloatLiterals
    | DuplicateRecordFields
    | OverloadedLabels
    | EmptyCase
index c26a388..4e7ddd7 100644 (file)
@@ -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 (file)
index 0000000..5e71ac3
--- /dev/null
@@ -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 (file)
index 0000000..20ce2a2
--- /dev/null
@@ -0,0 +1,4 @@
+[15.0,15.0625,15.00390625,15.0625,15.00390625,15.0625,15.00390625]
+0x1.a86b851eb851fp7
+-0x1.9851ecp3
+-0x0p+0
index 31dea7f..bcf0bc8 100644 (file)
@@ -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, [''])