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

3 files changed, 39 insertions, 13 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