diff options
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 49 | ||||
-rw-r--r-- | testsuite/tests/th/T20454.hs | 23 | ||||
-rw-r--r-- | testsuite/tests/th/T20454.stdout | 15 | ||||
-rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 80 insertions, 8 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 9627f5c256..7a6fbb0db9 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -287,9 +287,42 @@ pprLit _ (CharPrimL c) = text (show c) <> char '#' pprLit _ (StringL s) = pprString s pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' pprLit _ (BytesPrimL {}) = pprString "<binary data>" -pprLit i (RationalL rat) = parensIf (i > noPrec) $ - integer (numerator rat) <+> char '/' - <+> integer (denominator rat) +pprLit i (RationalL rat) + | withoutFactor 2 (withoutFactor 5 $ denominator rat) /= 1 + -- if the denominator has prime factors other than 2 and 5, show as fraction + = parensIf (i > noPrec) $ + integer (numerator rat) <+> char '/' <+> integer (denominator rat) + | rat /= 0 && (zeroes < -1 || zeroes > 7), + let (n, d) = properFraction (rat' / magnitude) + (rat', zeroes') + | abs rat < 1 = (10 * rat, zeroes - 1) + | otherwise = (rat, zeroes) + -- if < 0.01 or >= 100_000_000, use scientific notation + = parensIf (i > noPrec && rat < 0) + (integer n + <> (if d == 0 then empty else char '.' <> decimals (abs d)) + <> char 'e' <> integer zeroes') + | let (n, d) = properFraction rat + = parensIf (i > noPrec && rat < 0) + (integer n <> char '.' + <> if d == 0 then char '0' else decimals (abs d)) + where zeroes :: Integer + zeroes = truncate (logBase 10 (abs (fromRational rat) :: Double) + * (1 - epsilon)) + epsilon = 0.0000001 + magnitude :: Rational + magnitude = 10 ^^ zeroes + withoutFactor :: Integer -> Integer -> Integer + withoutFactor _ 0 = 0 + withoutFactor p n + | (n', 0) <- divMod n p = withoutFactor p n' + | otherwise = n + -- | Expects the argument 0 <= x < 1 + decimals :: Rational -> Doc + decimals x + | x == 0 = empty + | otherwise = integer n <> decimals d + where (n, d) = properFraction (x * 10) bytesToString :: [Word8] -> String bytesToString = map (chr . fromIntegral) @@ -927,13 +960,13 @@ ppr_cxt_preds ts = parens (commaSep ts) instance Ppr Range where ppr = brackets . pprRange where pprRange :: Range -> Doc - pprRange (FromR e) = ppr e <> text ".." + pprRange (FromR e) = ppr e <+> text ".." pprRange (FromThenR e1 e2) = ppr e1 <> text "," - <> ppr e2 <> text ".." - pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2 + <+> ppr e2 <+> text ".." + pprRange (FromToR e1 e2) = ppr e1 <+> text ".." <+> ppr e2 pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text "," - <> ppr e2 <> text ".." - <> ppr e3 + <+> ppr e2 <+> text ".." + <+> ppr e3 ------------------------------ where_clause :: [Dec] -> Doc diff --git a/testsuite/tests/th/T20454.hs b/testsuite/tests/th/T20454.hs new file mode 100644 index 0000000000..bdc5a7e382 --- /dev/null +++ b/testsuite/tests/th/T20454.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +e1, e2 :: ExpQ + +e1 = [| -- Test the Template Haskell pretty-printing of rational literals + [0.0, 123.0, -321.0, 9e3, 10000.0, -500000000.0, 345e67, -456e78, + 0.01, -0.002, 0.04e-56, -0.3e-65, + 0.33333333333333333333333333333, $(pure $ LitE $ RationalL $ 1/3)] + |] + +e2 = [| + [[-4 .. -1], + [-4, -3 .. -1], + [-4, -3 ..], + [-1 ..]] + |] + +main = runQ e1 >>= putStrLn . pprint + >> runQ e2 >>= putStrLn . pprint diff --git a/testsuite/tests/th/T20454.stdout b/testsuite/tests/th/T20454.stdout new file mode 100644 index 0000000000..9035052bbe --- /dev/null +++ b/testsuite/tests/th/T20454.stdout @@ -0,0 +1,15 @@ +[0.0, + 123.0, + -321.0, + 9000.0, + 10000.0, + -5e8, + 3.45e69, + -4.56e80, + 0.01, + -2e-3, + 4e-58, + -3e-66, + 0.33333333333333333333333333333, + 1 / 3] +[[-4 .. -1], [-4, -3 .. -1], [-4, -3 ..], [-1 ..]] diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 79cd9ca7d1..ebf4c0f1bf 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -540,6 +540,7 @@ test('T17820b', normal, compile_fail, ['']) test('T17820c', normal, compile_fail, ['']) test('T17820d', normal, compile_fail, ['']) test('T17820e', normal, compile_fail, ['']) +test('T20454', normal, compile_and_run, ['']) test('T20590', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T20773', only_ways(['ghci']), ghci_script, ['T20773.script']) test('T20884', normal, compile_fail, ['']) |