Show '#' on unboxed literals

Test Plan: deriving/should_run/T10104

Reviewers: austin, jstolarek

Reviewed By: austin, jstolarek

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D672

GHC Trac Issues: #10104

9 files changed, 55 insertions, 24 deletions

diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index dbee720135..a3d00996fd 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -667,11 +667,12 @@ reset_RDR               = varQual_RDR  rEAD_PREC (fsLit "reset")
 prec_RDR                = varQual_RDR  rEAD_PREC (fsLit "prec")
 pfail_RDR               = varQual_RDR  rEAD_PREC (fsLit "pfail")
 
-showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR,
+showList_RDR, showList___RDR, showsPrec_RDR, shows_RDR, showString_RDR,
     showSpace_RDR, showParen_RDR :: RdrName
 showList_RDR            = varQual_RDR gHC_SHOW (fsLit "showList")
 showList___RDR          = varQual_RDR gHC_SHOW (fsLit "showList__")
 showsPrec_RDR           = varQual_RDR gHC_SHOW (fsLit "showsPrec")
+shows_RDR               = varQual_RDR gHC_SHOW (fsLit "shows")
 showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")
 showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")
 showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 90737209e6..166d2f91b4 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -1171,8 +1171,9 @@ Note [Deriving and unboxed types]
 We have some special hacks to support things like
    data T = MkT Int# deriving ( Show )
 
-Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
-(which we know how to show). It's a bit ad hoc.
+Specifically, we use TcGenDeriv.box to box the Int# into an Int
+(which we know how to show), and append a '#'. Parenthesis are not required
+for unboxed values (`MkT -3#` is a valid expression).
 
 Note [Deriving any class]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 3141311bd5..1df57d1197 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1184,12 +1184,18 @@ gen_Show_binds get_fixity loc tycon
                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
                                                         labels show_args ]
 
-                -- Generates (showsPrec p x) for argument x, but it also boxes
-                -- the argument first if necessary.  Note that this prints unboxed
-                -- things without any '#' decorations; could change that if need be
-             show_arg b arg_ty = nlHsApps showsPrec_RDR
-                                    [nlHsLit (HsInt "" arg_prec),
-                                    box_if_necy "Show" tycon (nlHsVar b) arg_ty]
+             show_arg :: RdrName -> Type -> LHsExpr RdrName
+             show_arg b arg_ty
+               | isUnLiftedType arg_ty
+               -- See Note [Deriving and unboxed types].
+               = nlHsApps compose_RDR [mk_shows_app boxed_arg,
+                                       mk_showString_app postfixMod]
+               | otherwise
+               = mk_showsPrec_app arg_prec arg
+                 where
+                   arg        = nlHsVar b
+                   boxed_arg  = box "Show" tycon arg arg_ty
+                   postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
 
                 -- Fixity stuff
              is_infix = dataConIsInfix data_con
@@ -1209,9 +1215,18 @@ isSym :: String -> Bool
 isSym ""      = False
 isSym (c : _) = startsVarSym c || startsConSym c
 
+-- | showString :: String -> ShowS
 mk_showString_app :: String -> LHsExpr RdrName
 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 
+-- | showsPrec :: Show a => Int -> a -> ShowS
+mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
+mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
+
+-- | shows :: Show a => a -> ShowS
+mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
+mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
+
 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
 getPrec is_infix get_fixity nm
   | not is_infix   = appPrecedence
@@ -2093,15 +2108,13 @@ mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
               else matches
    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
 
-box_if_necy :: String           -- The class involved
+box ::         String           -- The class involved
             -> TyCon            -- The tycon involved
             -> LHsExpr RdrName  -- The argument
             -> Type             -- The argument type
             -> LHsExpr RdrName  -- Boxed version of the arg
 -- See Note [Deriving and unboxed types]
-box_if_necy cls_str tycon arg arg_ty
-  | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
-  | otherwise             = arg
+box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
   where
     box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
 
@@ -2131,6 +2144,17 @@ boxConTbl
     ,(doublePrimTy, getRdrName doubleDataCon)
     ]
 
+-- | A table of postfix modifiers for unboxed values.
+postfixModTbl :: [(Type, String)]
+postfixModTbl
+  = [(charPrimTy  , "#" )
+    ,(intPrimTy   , "#" )
+    ,(wordPrimTy  , "##")
+    ,(floatPrimTy , "#" )
+    ,(doublePrimTy, "##")
+    ]
+
+-- | Lookup `Type` in an association list.
 assoc_ty_id :: String           -- The class involved
             -> TyCon            -- The tycon involved
             -> [(Type,a)]       -- The table
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index ef3c86143b..362c5a1db5 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -419,7 +419,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/deriving/should_run/T5628
 /tests/deriving/should_run/T5712
 /tests/deriving/should_run/T7931
-/tests/deriving/should_run/T8280
+/tests/deriving/should_run/T10104
 /tests/deriving/should_run/drvrun-foldable1
 /tests/deriving/should_run/drvrun-functor1
 /tests/deriving/should_run/drvrun001
diff --git a/testsuite/tests/deriving/should_run/T10104.hs b/testsuite/tests/deriving/should_run/T10104.hs
new file mode 100644
index 0000000000..154a6097f7
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T10104.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE MagicHash #-}
+module Main where
+
+import GHC.Prim
+
+data P = Positives Int# Float# Double# Char# Word# deriving Show
+data N = Negatives Int# Float# Double# deriving Show
+
+main = do
+  print $ Positives 42# 4.23# 4.23## '4'# 4##
+  print $ Negatives -4# -4.0# -4.0##
diff --git a/testsuite/tests/deriving/should_run/T10104.stdout b/testsuite/tests/deriving/should_run/T10104.stdout
new file mode 100644
index 0000000000..3213680109
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T10104.stdout
@@ -0,0 +1,2 @@
+Positives 42# 4.23# 4.23## '4'# 4##
+Negatives -4# -4.0# -4.0##
diff --git a/testsuite/tests/deriving/should_run/T8280.hs b/testsuite/tests/deriving/should_run/T8280.hs
deleted file mode 100644
index 4ccc5b4164..0000000000
--- a/testsuite/tests/deriving/should_run/T8280.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-module Main where
-
-import GHC.Prim
-
-data A = A Word# deriving Show
-
-main = print (A (int2Word# 4#))
diff --git a/testsuite/tests/deriving/should_run/T8280.stdout b/testsuite/tests/deriving/should_run/T8280.stdout
deleted file mode 100644
index 4e5c0aa287..0000000000
--- a/testsuite/tests/deriving/should_run/T8280.stdout
+++ /dev/null
@@ -1 +0,0 @@
-A 4
diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T
index 13858a85c2..00856a6a86 100644
--- a/testsuite/tests/deriving/should_run/all.T
+++ b/testsuite/tests/deriving/should_run/all.T
@@ -35,6 +35,7 @@ test('T5041', normal, compile_and_run, [''])
 test('T5628', exit_code(1), compile_and_run, [''])
 test('T5712', normal, compile_and_run, [''])
 test('T7931', normal, compile_and_run, [''])
-test('T8280', normal, compile_and_run, [''])
+# T8280 is superseded by T10104
 test('T9576', exit_code(1), compile_and_run, [''])
 test('T9830', extra_clean(['T9830a.hi', 'T9830a.o']), multimod_compile_and_run, ['T9830','-v0'])
+test('T10104', normal, compile_and_run, [''])