From 787bae96f77562e603b6e9ebb86139cc5d120b8d Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Wed, 14 Jun 2023 19:04:45 +0200
Subject: [PATCH] Use extended literals when deriving Show
This implements GHC proposal
https://github.com/ghc-proposals/ghc-proposals/pull/596
Also add support for Int64# and Word64#; see testcase ShowPrim.
---
compiler/GHC/Tc/Deriv/Generate.hs | 86 +++++++------------
docs/users_guide/9.8.1-notes.rst | 4 +
.../tests/primops/should_run/ShowPrim.hs | 15 +++-
.../tests/primops/should_run/ShowPrim.stdout | 7 +-
4 files changed, 48 insertions(+), 64 deletions(-)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index c3b74ee67100..b6a1f8968165 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1282,8 +1282,7 @@ gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
show_arg b arg_ty
| isUnliftedType arg_ty
-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
- = with_conv $
- nlHsApps compose_RDR
+ = nlHsApps compose_RDR
[mk_shows_app boxed_arg, mk_showString_app postfixMod]
| otherwise
= mk_showsPrec_app arg_prec arg
@@ -1291,14 +1290,6 @@ gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
arg = nlHsVar b
boxed_arg = box "Show" arg arg_ty
postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
- with_conv expr
- | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
- nested_compose_Expr
- [ mk_showString_app ("(" ++ conv ++ " ")
- , expr
- , mk_showString_app ")"
- ]
- | otherwise = expr
-- Fixity stuff
is_infix = dataConIsInfix data_con
@@ -1514,9 +1505,8 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
- word8ToWord_RDR , int8ToInt_RDR ,
- word16ToWord_RDR, int16ToInt_RDR,
- word32ToWord_RDR, int32ToInt_RDR
+ int8DataCon_RDR, int16DataCon_RDR, int32DataCon_RDR, int64DataCon_RDR,
+ word8DataCon_RDR, word16DataCon_RDR, word32DataCon_RDR, word64DataCon_RDR
:: RdrName
gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
@@ -1619,15 +1609,14 @@ leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
-word8ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word8ToWord#")
-int8ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int8ToInt#")
-
-word16ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word16ToWord#")
-int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#")
-
-word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#")
-int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#")
-
+int8DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I8#")
+int16DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I16#")
+int32DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I32#")
+int64DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I64#")
+word8DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W8#")
+word16DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W16#")
+word32DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W32#")
+word64DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W64#")
{-
************************************************************************
* *
@@ -2416,7 +2405,6 @@ ordOpTbl
-- A mapping from a primitive type to a function that constructs its boxed
-- version.
--- NOTE: Int8#/Word8# will become Int/Word.
boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
boxConTbl =
[ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon))
@@ -2424,28 +2412,20 @@ boxConTbl =
, (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
, (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
, (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
- , (int8PrimTy,
- nlHsApp (nlHsVar $ getRdrName intDataCon)
- . nlHsApp (nlHsVar int8ToInt_RDR))
- , (word8PrimTy,
- nlHsApp (nlHsVar $ getRdrName wordDataCon)
- . nlHsApp (nlHsVar word8ToWord_RDR))
- , (int16PrimTy,
- nlHsApp (nlHsVar $ getRdrName intDataCon)
- . nlHsApp (nlHsVar int16ToInt_RDR))
- , (word16PrimTy,
- nlHsApp (nlHsVar $ getRdrName wordDataCon)
- . nlHsApp (nlHsVar word16ToWord_RDR))
- , (int32PrimTy,
- nlHsApp (nlHsVar $ getRdrName intDataCon)
- . nlHsApp (nlHsVar int32ToInt_RDR))
- , (word32PrimTy,
- nlHsApp (nlHsVar $ getRdrName wordDataCon)
- . nlHsApp (nlHsVar word32ToWord_RDR))
+ , (int8PrimTy, nlHsApp (nlHsVar int8DataCon_RDR))
+ , (word8PrimTy, nlHsApp (nlHsVar word8DataCon_RDR))
+ , (int16PrimTy, nlHsApp (nlHsVar int16DataCon_RDR))
+ , (word16PrimTy, nlHsApp (nlHsVar word16DataCon_RDR))
+ , (int32PrimTy, nlHsApp (nlHsVar int32DataCon_RDR))
+ , (word32PrimTy, nlHsApp (nlHsVar word32DataCon_RDR))
+ , (int64PrimTy, nlHsApp (nlHsVar int64DataCon_RDR))
+ , (word64PrimTy, nlHsApp (nlHsVar word64DataCon_RDR))
]
-- | A table of postfix modifiers for unboxed values.
+-- Following https://github.com/ghc-proposals/ghc-proposals/pull/596,
+-- we use the ExtendedLiterals syntax for sized literals.
postfixModTbl :: [(Type, String)]
postfixModTbl
= [(charPrimTy , "#" )
@@ -2453,22 +2433,14 @@ postfixModTbl
,(wordPrimTy , "##")
,(floatPrimTy , "#" )
,(doublePrimTy, "##")
- ,(int8PrimTy, "#")
- ,(word8PrimTy, "##")
- ,(int16PrimTy, "#")
- ,(word16PrimTy, "##")
- ,(int32PrimTy, "#")
- ,(word32PrimTy, "##")
- ]
-
-primConvTbl :: [(Type, String)]
-primConvTbl =
- [ (int8PrimTy, "intToInt8#")
- , (word8PrimTy, "wordToWord8#")
- , (int16PrimTy, "intToInt16#")
- , (word16PrimTy, "wordToWord16#")
- , (int32PrimTy, "intToInt32#")
- , (word32PrimTy, "wordToWord32#")
+ ,(int8PrimTy , "#Int8")
+ ,(word8PrimTy , "#Word8")
+ ,(int16PrimTy , "#Int16")
+ ,(word16PrimTy, "#Word16")
+ ,(int32PrimTy , "#Int32")
+ ,(word32PrimTy, "#Word32")
+ ,(int64PrimTy , "#Int64")
+ ,(word64PrimTy, "#Word64")
]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst
index e8e5529c6f17..a7c2ad4eed68 100644
--- a/docs/users_guide/9.8.1-notes.rst
+++ b/docs/users_guide/9.8.1-notes.rst
@@ -9,6 +9,10 @@ Language
- There is a new extension :extension:`ExtendedLiterals`, which enables
sized primitive literals, e.g. ``123#Int8`` is a literal of type ``Int8#``.
See the GHC proposal `#451 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0451-sized-literals.rst>`_.
+ Derived ``Show`` instances for datatypes containing sized literals (``Int8#``, ``Word8#``, ``Int16#`` etc.)
+ now use the extended literal syntax, per GHC proposal `#596 <https://github.com/ghc-proposals/ghc-proposals/pull/596>`_.
+ Furthermore, it is now possible to derive ``Show`` for datatypes containing
+ fields of types ``Int64#`` and ``Word64#``.
- GHC Proposal `#425
<https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0425-decl-invis-binders.rst>`_
diff --git a/testsuite/tests/primops/should_run/ShowPrim.hs b/testsuite/tests/primops/should_run/ShowPrim.hs
index 6213ef496cbf..bae70cb08652 100644
--- a/testsuite/tests/primops/should_run/ShowPrim.hs
+++ b/testsuite/tests/primops/should_run/ShowPrim.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MagicHash, ExtendedLiterals #-}
module Main where
@@ -13,17 +13,24 @@ data Test2 = Test2 Int16# Word16#
data Test3 = Test3 Int32# Word32#
deriving (Show)
+data Test4 = Test4 Int64# Word64#
+ deriving (Show)
+
test1 :: Test1
-test1 = Test1 (intToInt8# 1#) (wordToWord8# 2##)
+test1 = Test1 1#Int8 2#Word8
test2 :: Test2
-test2 = Test2 (intToInt16# 1#) (wordToWord16# 2##)
+test2 = Test2 1#Int16 2#Word16
test3 :: Test3
-test3 = Test3 (intToInt32# 1#) (wordToWord32# 2##)
+test3 = Test3 1#Int32 2#Word32
+
+test4 :: Test4
+test4 = Test4 -9223372036854775808#Int64 18446744073709551610#Word64
main :: IO ()
main = do
print test1
print test2
print test3
+ print test4
diff --git a/testsuite/tests/primops/should_run/ShowPrim.stdout b/testsuite/tests/primops/should_run/ShowPrim.stdout
index d4167bf32ccf..6d8c6524e687 100644
--- a/testsuite/tests/primops/should_run/ShowPrim.stdout
+++ b/testsuite/tests/primops/should_run/ShowPrim.stdout
@@ -1,3 +1,4 @@
-Test1 (intToInt8# 1#) (wordToWord8# 2##)
-Test2 (intToInt16# 1#) (wordToWord16# 2##)
-Test3 (intToInt32# 1#) (wordToWord32# 2##)
+Test1 1#Int8 2#Word8
+Test2 1#Int16 2#Word16
+Test3 1#Int32 2#Word32
+Test4 -9223372036854775808#Int64 18446744073709551610#Word64
--
GitLab