template-haskell: Fix two prettyprinter issues

Fix two issues regarding printing numeric literals.

Fixing #20454.

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, [''])