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

3 files changed, 80 insertions, 6 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