[Git][ghc/ghc][wip/sized-literals-deriving] Use extended literals when deriving Show

Krzysztof Gogolewski (@monoidal) gitlab at gitlab.haskell.org
Mon Jul 17 11:02:18 UTC 2023



Krzysztof Gogolewski pushed to branch wip/sized-literals-deriving at Glasgow Haskell Compiler / GHC


Commits:
00a8d3fb by Krzysztof Gogolewski at 2023-07-17T13:02:05+02:00
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.

- - - - -


4 changed files:

- compiler/GHC/Tc/Deriv/Generate.hs
- docs/users_guide/9.8.1-notes.rst
- testsuite/tests/primops/should_run/ShowPrim.hs
- testsuite/tests/primops/should_run/ShowPrim.stdout


Changes:

=====================================
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)]


=====================================
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>`_


=====================================
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


=====================================
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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/00a8d3fb7839ba9f922c04653d39e3dcc9337919

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/00a8d3fb7839ba9f922c04653d39e3dcc9337919
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230717/da4f6ede/attachment-0001.html>


More information about the ghc-commits mailing list