From 32e18420b328b1f939dd92333d3b7637c26ef3a8 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 23 Mar 2018 11:40:02 -0400
Subject: [PATCH] Special-case record fields ending with hash when deriving
Read
Summary:
In commit dbd81f7e86514498218572b9d978373b1699cc5b, a
regression was inadvertently introduced which caused derived `Read`
instances for record data types with fields ending in a `#` symbol
(using `MagicHash`) would no longer parse on valid output. This
is ultimately due to the same reasons as #5041, as we cannot parse
a field name like `foo#` as a single identifier. We fix this issue
by employing the same workaround as in #5041: first parse the
identifier name `foo`, then then symbol `#`.
This is accomplished by the new `readFieldHash` function in
`GHC.Read`. This will likely warrant a `base-4.11.1.0` release.
Test Plan: make test TEST=T14918
Reviewers: tdammers, hvr, bgamari
Reviewed By: bgamari
Subscribers: rwbarton, thomie, carter
GHC Trac Issues: #14918
Differential Revision: https://phabricator.haskell.org/D4502
(cherry picked from commit d5577f44eaf3b9dfdfc77828038782bf818c176a)
---
compiler/prelude/PrelNames.hs | 3 +-
compiler/typecheck/TcGenDeriv.hs | 16 ++--
docs/users_guide/8.4.2-notes.rst | 88 +++++++++++++++++++
docs/users_guide/index.rst | 1 +
libraries/base/GHC/Read.hs | 17 ++++
libraries/base/changelog.md | 4 +
testsuite/tests/deriving/should_run/T14918.hs | 18 ++++
.../tests/deriving/should_run/T14918.stdout | 2 +
testsuite/tests/deriving/should_run/all.T | 1 +
9 files changed, 143 insertions(+), 7 deletions(-)
create mode 100644 docs/users_guide/8.4.2-notes.rst
create mode 100644 testsuite/tests/deriving/should_run/T14918.hs
create mode 100644 testsuite/tests/deriving/should_run/T14918.stdout
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 47b146559fef..d8947815116e 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -744,8 +744,9 @@ choose_RDR = varQual_RDR gHC_READ (fsLit "choose")
lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP")
expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP")
-readField_RDR, readSymField_RDR :: RdrName
+readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName
readField_RDR = varQual_RDR gHC_READ (fsLit "readField")
+readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash")
readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField")
punc_RDR, ident_RDR, symbol_RDR :: RdrName
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 1ac350523a8e..5d02b9b52946 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1080,19 +1080,23 @@ gen_Read_binds get_fixity loc tycon
[noLoc
(mkBindStmt
(nlVarPat a)
- (nlHsApps
+ (nlHsApp
read_field
- [ nlHsLit (mkHsString lbl_str)
- , nlHsVarApps reset_RDR [readPrec_RDR]
- ]
+ (nlHsVarApps reset_RDR [readPrec_RDR])
)
)
]
where
lbl_str = unpackFS lbl
+ mk_read_field read_field_rdr lbl
+ = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
read_field
- | isSym lbl_str = readSymField_RDR
- | otherwise = readField_RDR
+ | isSym lbl_str
+ = mk_read_field readSymField_RDR lbl_str
+ | Just (ss, '#') <- snocView lbl_str -- #14918
+ = mk_read_field readFieldHash_RDR ss
+ | otherwise
+ = mk_read_field readField_RDR lbl_str
{-
************************************************************************
diff --git a/docs/users_guide/8.4.2-notes.rst b/docs/users_guide/8.4.2-notes.rst
new file mode 100644
index 000000000000..7002caae0d2f
--- /dev/null
+++ b/docs/users_guide/8.4.2-notes.rst
@@ -0,0 +1,88 @@
+.. _release-8-4-2:
+
+Release notes for version 8.4.2
+===============================
+
+TODO
+
+Highlights
+----------
+
+The highlights, since the 8.4.1 release, are:
+
+- TODO
+
+
+Full details
+------------
+
+
+Language
+~~~~~~~~
+
+- Fix a regression in which derived `Read` instances for record data types
+ with field names ending with `#` (by way of :ghc-flag:`-XMagicHash`) would
+ no longer parse valid output.
+
+Compiler
+~~~~~~~~
+
+
+Runtime system
+~~~~~~~~~~~~~~
+
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+
+
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+
+``base`` library
+~~~~~~~~~~~~~~~~
+
+- Add the `readFieldHash` function to `GHC.Read` which behaves like
+ `readField`, but for a field that ends with a `#` symbol.
+
+Build system
+~~~~~~~~~~~~
+
+
+Included libraries
+------------------
+
+The package database provided with this distribution also contains a number of
+packages other than GHC itself. See the changelogs provided with these packages
+for further change information.
+
+.. ghc-package-list::
+
+ libraries/array/array.cabal: Dependency of ``ghc`` library
+ libraries/base/base.cabal: Core library
+ libraries/binary/binary.cabal: Dependency of ``ghc`` library
+ libraries/bytestring/bytestring.cabal: Deppendency of ``ghc`` library
+ libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/containers/containers.cabal: Dependency of ``ghc`` library
+ libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
+ libraries/directory/directory.cabal: Dependency of ``ghc`` library
+ libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
+ compiler/ghc.cabal: The compiler itself
+ libraries/ghci/ghci.cabal: The REPL interface
+ libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
+ libraries/ghc-compact/ghc-compact.cabal: Core library
+ libraries/ghc-prim/ghc-prim.cabal: Core library
+ libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
+ libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
+ libraries/integer-gmp/integer-gmp.cabal: Core library
+ libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
+ libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
+ libraries/process/process.cabal: Dependency of ``ghc`` library
+ libraries/template-haskell/template-haskell.cabal: Core library
+ libraries/text/text.cabal: Dependency of ``Cabal`` library
+ libraries/time/time.cabal: Dependency of ``ghc`` library
+ libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
+ libraries/unix/unix.cabal: Dependency of ``ghc`` library
+ libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
+ libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
diff --git a/docs/users_guide/index.rst b/docs/users_guide/index.rst
index 55dfc086b918..3ddeb6487dfb 100644
--- a/docs/users_guide/index.rst
+++ b/docs/users_guide/index.rst
@@ -13,6 +13,7 @@ Contents:
license
intro
8.4.1-notes
+ 8.4.2-notes
ghci
runghc
usage
diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs
index 2d8ee3de5192..559848d11c1c 100644
--- a/libraries/base/GHC/Read.hs
+++ b/libraries/base/GHC/Read.hs
@@ -37,6 +37,7 @@ module GHC.Read
, readListDefault, readListPrecDefault
, readNumber
, readField
+ , readFieldHash
, readSymField
-- Temporary
@@ -376,6 +377,22 @@ readField fieldName readVal = do
-- See Note [Why readField]
+-- | 'Read' parser for a record field, of the form @fieldName#=value@. That is,
+-- an alphanumeric identifier @fieldName@ followed by the symbol @#@. The
+-- second argument is a parser for the field value.
+--
+-- Note that 'readField' does not suffice for this purpose due to
+-- <https://ghc.haskell.org/trac/ghc/ticket/5041 Trac #5041>.
+readFieldHash :: String -> ReadPrec a -> ReadPrec a
+readFieldHash fieldName readVal = do
+ expectP (L.Ident fieldName)
+ expectP (L.Symbol "#")
+ expectP (L.Punc "=")
+ readVal
+{-# NOINLINE readFieldHash #-}
+
+-- See Note [Why readField]
+
-- | 'Read' parser for a symbol record field, of the form @(###)=value@ (where
-- @###@ is the field name). The field name must be a symbol (operator-style),
-- e.g. @(#)@. For regular (alphanumeric) field names, use 'readField'. The
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index dd0a4af7c808..cc3a8057ea9b 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -1,6 +1,10 @@
# Changelog for [`base` package](http://hackage.haskell.org/package/base)
+## 4.11.1.0 *TBA*
+ * Add the `readFieldHash` function to `GHC.Read` which behaves like
+ `readField`, but for a field that ends with a `#` symbol (#14918).
+
## 4.11.0.0 *TBA*
* Bundled with GHC 8.4.1
diff --git a/testsuite/tests/deriving/should_run/T14918.hs b/testsuite/tests/deriving/should_run/T14918.hs
new file mode 100644
index 000000000000..2ad293724ba1
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T14918.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE MagicHash #-}
+module Main where
+
+data T a = MkT { runT :: a, (##) :: a } deriving (Read, Show)
+data T# a = MkT# { runT# :: a, (###) :: a } deriving (Read, Show)
+
+t1, t2 :: T Int
+t1 = MkT (-1) 1
+t2 = read $ show t1
+
+t1#, t2# :: T# Int
+t1# = MkT# (-1) 1
+t2# = read $ show t1#
+
+main :: IO ()
+main = do
+ print t2
+ print t2#
diff --git a/testsuite/tests/deriving/should_run/T14918.stdout b/testsuite/tests/deriving/should_run/T14918.stdout
new file mode 100644
index 000000000000..b85e2a219efe
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T14918.stdout
@@ -0,0 +1,2 @@
+MkT {runT = -1, (##) = 1}
+MkT# {runT# = -1, (###) = 1}
diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T
index c5605f627e3a..cf0cb922edca 100644
--- a/testsuite/tests/deriving/should_run/all.T
+++ b/testsuite/tests/deriving/should_run/all.T
@@ -45,3 +45,4 @@ test('T10598_bug', normal, compile_and_run, [''])
test('T10598_run', normal, compile_and_run, [''])
test('T11535', when(opsys('mingw32'), expect_broken_for(12210, ['ghci'])),
compile_and_run, [''])
+test('T14918', normal, compile_and_run, [''])
--
GitLab