From 43e8e4f388db80a57d8633de761540dcca21a16b Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Fri, 17 May 2024 16:57:37 +0200
Subject: [PATCH] Float/double unboxed literal support for HexFloatLiterals
(fix #22155)
---
compiler/GHC/Parser/Lexer.x | 9 +++++++--
docs/users_guide/9.12.1-notes.rst | 2 ++
testsuite/tests/parser/should_compile/T22155.hs | 9 +++++++++
.../tests/parser/should_compile/T22155.stderr | 15 +++++++++++++++
testsuite/tests/parser/should_compile/all.T | 3 +++
5 files changed, 36 insertions(+), 2 deletions(-)
create mode 100644 testsuite/tests/parser/should_compile/T22155.hs
create mode 100644 testsuite/tests/parser/should_compile/T22155.stderr
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 318903fadfb7..3f2c5dd1def0 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -565,9 +565,12 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
-- prim_{float,double} work with signed literals
@floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat }
@floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble }
-
@negative @floating_point \# / { negHashLitPred MagicHashBit } { tok_frac 1 tok_primfloat }
@negative @floating_point \# \# / { negHashLitPred MagicHashBit } { tok_frac 2 tok_primdouble }
+ 0[xX] @numspc @hex_floating_point \# / { ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit } { tok_frac 1 tok_prim_hex_float }
+ 0[xX] @numspc @hex_floating_point \# \# / { ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit } { tok_frac 2 tok_prim_hex_double }
+ @negative 0[xX] @numspc @hex_floating_point \# / { ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit } { tok_frac 1 tok_prim_hex_float }
+ @negative 0[xX] @numspc @hex_floating_point \# \# / { ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit } { tok_frac 2 tok_prim_hex_double }
@decimal \#"Int8" / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 0 decimal }
@binarylit \#"Int8" / { ifExtension ExtendedLiteralsBit `alexAndPred`
@@ -1989,11 +1992,13 @@ tok_frac drop f span buf len _buf2 = do
addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
return (L span $! (f $! src))
-tok_float, tok_primfloat, tok_primdouble :: String -> Token
+tok_float, tok_primfloat, tok_primdouble, tok_prim_hex_float, tok_prim_hex_double :: String -> Token
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
+tok_prim_hex_float str = ITprimfloat $! readHexFractionalLit str
+tok_prim_hex_double str = ITprimdouble $! readHexFractionalLit str
readFractionalLit, readHexFractionalLit :: String -> FractionalLit
readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2
diff --git a/docs/users_guide/9.12.1-notes.rst b/docs/users_guide/9.12.1-notes.rst
index 9eddb916b49e..61d3ddf1ab55 100644
--- a/docs/users_guide/9.12.1-notes.rst
+++ b/docs/users_guide/9.12.1-notes.rst
@@ -29,6 +29,8 @@ Language
This means that code using :extension:`UnliftedDatatypes` or
:extension:`UnliftedNewtypes` can now use :extension:`OverloadedRecordDot`.
+- Unboxed Float#/Double# literals now support the HexFloatLiterals extension
+ (`#22155 <https://gitlab.haskell.org/ghc/ghc/-/issues/22155>`_).
Compiler
~~~~~~~~
diff --git a/testsuite/tests/parser/should_compile/T22155.hs b/testsuite/tests/parser/should_compile/T22155.hs
new file mode 100644
index 000000000000..79ea364e8bff
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T22155.hs
@@ -0,0 +1,9 @@
+{-# language HexFloatLiterals, MagicHash, NegativeLiterals #-}
+module T22155 where
+
+import GHC.Types
+
+a = D# 0x0.1p12##
+b = D# -0x0.1p12##
+c = F# 0x0.1p12#
+d = F# -0x0.1p12#
diff --git a/testsuite/tests/parser/should_compile/T22155.stderr b/testsuite/tests/parser/should_compile/T22155.stderr
new file mode 100644
index 000000000000..a3f4fdcd6a09
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T22155.stderr
@@ -0,0 +1,15 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 12, types: 4, coercions: 0, joins: 0/0}
+
+a = D# 256.0##
+
+b = D# -256.0##
+
+c = F# 256.0#
+
+d = F# -256.0#
+
+
+
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 79966ae1a8bb..e3df05bda0ed 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -199,3 +199,6 @@ test('T19372consym', normal, compile, [''])
test('ListTuplePunsSuccess1', extra_files(['ListTuplePunsSuccess1.hs']), ghci_script, ['ListTuplePunsSuccess1.script'])
test('ListTuplePunsFamiliesCompat', expect_broken(23135), compile, [''])
test('ListTuplePunsFamilies', [expect_broken(23135), extra_files(['ListTuplePunsFamilies.hs'])], ghci_script, ['ListTuplePunsFamilies.script'])
+
+
+test('T22155', normal, compile, ['-dsuppress-uniques -ddump-simpl -dsuppress-all -dno-typeable-binds'])
--
GitLab