Implement the basics of hex floating point literals

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, 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, [''])