Commit 47175e06 authored by thomie's avatar thomie Committed by Austin Seipp

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
parent a293925d
......@@ -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")
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......
{-# 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##
Positives 42# 4.23# 4.23## '4'# 4##
Negatives -4# -4.0# -4.0##
{-# LANGUAGE MagicHash #-}
module Main where
import GHC.Prim
data A = A Word# deriving Show
main = print (A (int2Word# 4#))
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment