Check if the SDoc starts with a single quote (#22488)

This patch fixes pretty-printing of character literals
inside promoted lists and tuples.

When we pretty-print a promoted list or tuple whose first element
starts with a single quote, we want to add a space between the opening
bracket and the element:

	'[True]    -- ok
	'[ 'True]  -- ok
	'['True]   -- not ok

If we don't add the space, we accidentally produce a character
literal '['.

Before this patch, pprSpaceIfPromotedTyCon inspected the type as an AST
and tried to guess if it would be rendered with a single quote. However,
it missed the case when the inner type was itself a character literal:

	'[ 'x']  -- ok
	'['x']   -- not ok

Instead of adding this particular case, I opted for a more future-proof
solution: check the SDoc directly. This way we can detect if the single
quote is actually there instead of trying to predict it from the AST.
The new function is called spaceIfSingleQuote.

8 files changed, 123 insertions, 17 deletions

diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs
index 53fd8e63b0..1e0acae583 100644
--- a/compiler/GHC/Data/FastString.hs
+++ b/compiler/GHC/Data/FastString.hs
@@ -56,6 +56,7 @@ module GHC.Data.FastString
         FastZString,
         hPutFZS,
         zString,
+        zStringTakeN,
         lengthFZS,
 
         -- * FastStrings
@@ -103,6 +104,7 @@ module GHC.Data.FastString
 
         -- ** Deconstruction
         unpackPtrString,
+        unpackPtrStringTakeN,
 
         -- ** Operations
         lengthPS
@@ -179,6 +181,14 @@ zString :: FastZString -> String
 zString (FastZString bs) =
     inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen
 
+-- | @zStringTakeN n = 'take' n . 'zString'@
+-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\),
+-- where \(l\) is the length of the 'FastZString'.
+zStringTakeN :: Int -> FastZString -> String
+zStringTakeN n (FastZString bs) =
+    inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(cp, len) ->
+        peekCAStringLen (cp, min n len)
+
 lengthFZS :: FastZString -> Int
 lengthFZS (FastZString bs) = BS.length bs
 
@@ -586,7 +596,7 @@ lengthFS fs = n_chars fs
 nullFS :: FastString -> Bool
 nullFS fs = SBS.null $ fs_sbs fs
 
--- | Unpacks and decodes the FastString
+-- | Lazily unpacks and decodes the FastString
 unpackFS :: FastString -> String
 unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs
 
@@ -666,6 +676,14 @@ mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#))
 unpackPtrString :: PtrString -> String
 unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n#
 
+-- | @unpackPtrStringTakeN n = 'take' n . 'unpackPtrString'@
+-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\),
+-- where \(l\) is the length of the 'PtrString'.
+unpackPtrStringTakeN :: Int -> PtrString -> String
+unpackPtrStringTakeN n (PtrString (Ptr p#) len) =
+  case min n len of
+    I# n# -> unpackNBytes# p# n#
+
 -- | Return the length of a 'PtrString'
 lengthPS :: PtrString -> Int
 lengthPS (PtrString _ n) = n
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 04b34849f8..3873b9133f 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -1450,23 +1450,20 @@ Consider this GHCi session (#14343)
       Found hole: _ :: Proxy '['True]
 
 This would be bad, because the '[' looks like a character literal.
+
+A similar issue arises if the element is a character literal (#22488)
+    ghci> type T = '[ 'x' ]
+    ghci> :kind! T
+    T :: [Char]
+    = '['x']
+
 Solution: in type-level lists and tuples, add a leading space
-if the first type is itself promoted.  See pprSpaceIfPromotedTyCon.
+if the first element is printed with a single quote.
 -}
 
 
 -------------------
 
--- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
--- See Note [Printing promoted type constructors]
-pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
-pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
-  = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
-      IsPromoted -> (space <>)
-      _ -> id
-pprSpaceIfPromotedTyCon _
-  = id
-
 -- See equivalent function in "GHC.Core.TyCo.Rep"
 pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
 -- Given a type-level list (t1 ': t2), see if we can print
@@ -1475,7 +1472,7 @@ pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
 pprIfaceTyList ctxt_prec ty1 ty2
   = case gather ty2 of
       (arg_tys, Nothing)
-        -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep
+        -> char '\'' <> brackets (spaceIfSingleQuote (fsep
                         (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys)))))
       (arg_tys, Just tl)
         -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
@@ -1714,12 +1711,9 @@ pprTuple ctxt_prec sort promoted args =
     IsPromoted
       -> let tys = appArgsIfaceTypes args
              args' = drop (length tys `div` 2) tys
-             spaceIfPromoted = case args' of
-               arg0:_ -> pprSpaceIfPromotedTyCon arg0
-               _ -> id
          in ppr_tuple_app args' $
             pprPromotionQuoteI IsPromoted <>
-            tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
+            tupleParens sort (spaceIfSingleQuote (pprWithCommas pprIfaceType args'))
 
     NotPromoted
       |  ConstraintTuple <- sort
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 87bfd89909..09be4b1c2d 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -32,6 +32,7 @@ module GHC.Utils.Outputable (
         interppSP, interpp'SP, interpp'SP',
         pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
         pprWithBars,
+        spaceIfSingleQuote,
         isEmpty, nest,
         ptext,
         int, intWithCommas, integer, word, float, double, rational, doublePrec,
@@ -1287,6 +1288,16 @@ pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use
                            -- bar-separated and finally packed into a paragraph.
 pprWithBars pp xs = fsep (intersperse vbar (map pp xs))
 
+-- Prefix the document with a space if it starts with a single quote.
+-- See Note [Printing promoted type constructors] in GHC.Iface.Type
+spaceIfSingleQuote :: SDoc -> SDoc
+spaceIfSingleQuote (SDoc m) =
+  SDoc $ \ctx ->
+    let (mHead, d) = Pretty.docHead (m ctx)
+    in if mHead == Just '\''
+       then Pretty.space Pretty.<> d
+       else d
+
 -- | Returns the separated concatenation of the pretty printed things.
 interppSP  :: Outputable a => [a] -> SDoc
 interppSP  xs = sep (map ppr xs)
diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs
index ad68b40dc9..4c28f083af 100644
--- a/compiler/GHC/Utils/Ppr.hs
+++ b/compiler/GHC/Utils/Ppr.hs
@@ -93,6 +93,7 @@ module GHC.Utils.Ppr (
 
         -- * Predicates on documents
         isEmpty,
+        docHead,
 
         -- * Rendering documents
 
@@ -112,6 +113,7 @@ module GHC.Utils.Ppr (
   ) where
 
 import GHC.Prelude.Basic hiding (error)
+import Control.Applicative ((<|>))
 
 import GHC.Utils.BufHandle
 import GHC.Data.FastString
@@ -350,6 +352,37 @@ isEmpty :: Doc -> Bool
 isEmpty Empty = True
 isEmpty _     = False
 
+-- | Get the first character of a document. We also return a new document,
+-- equivalent to the original one but faster to render. Use it to avoid work
+-- duplication.
+docHead :: Doc -> (Maybe Char, Doc)
+docHead d = (headChar, rdoc)
+  where
+    rdoc = reduceDoc d
+    headChar = go rdoc
+
+    go :: RDoc -> Maybe Char
+    go (Union p q)  = go (first p q)
+    go (Nest _ p)   = go p
+    go Empty        = Nothing
+    go (NilAbove _) = Just '\n'
+    go (TextBeside td _ p) = go_td td <|> go p
+    go NoDoc       = error "docHead: NoDoc"
+    go (Above {})  = error "docHead: Above"
+    go (Beside {}) = error "docHead: Beside"
+
+    go_td :: TextDetails -> Maybe Char
+    go_td (Chr c)  = Just c
+    go_td (Str s)  = go_str s
+    go_td (PStr s) = go_str (unpackFS s) -- O(1) because unpackFS is lazy
+    go_td (ZStr s) = go_str (zStringTakeN 1 s)
+    go_td (LStr s) = go_str (unpackPtrStringTakeN 1 s)
+    go_td (RStr n c) = if n > 0 then Just c else Nothing
+
+    go_str :: String -> Maybe Char
+    go_str []    = Nothing
+    go_str (c:_) = Just c
+
 {-
 Q: What is the reason for negative indentation (i.e. argument to indent
    is < 0) ?
diff --git a/testsuite/tests/printer/T22488.script b/testsuite/tests/printer/T22488.script
new file mode 100644
index 0000000000..7e4d10a4c1
--- /dev/null
+++ b/testsuite/tests/printer/T22488.script
@@ -0,0 +1,5 @@
+:set -XDataKinds
+type T = '[ 'x' ]
+:kind! T
+type T = '( 'x', 'y' )
+:kind! T
\ No newline at end of file
diff --git a/testsuite/tests/printer/T22488.stdout b/testsuite/tests/printer/T22488.stdout
new file mode 100644
index 0000000000..44e0bd9932
--- /dev/null
+++ b/testsuite/tests/printer/T22488.stdout
@@ -0,0 +1,4 @@
+T :: [Char]
+= '[ 'x']
+T :: (Char, Char)
+= '( 'x', 'y')
diff --git a/testsuite/tests/printer/T22488_docHead.hs b/testsuite/tests/printer/T22488_docHead.hs
new file mode 100644
index 0000000000..7fbc89aa08
--- /dev/null
+++ b/testsuite/tests/printer/T22488_docHead.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import Prelude hiding ((<>))
+import Data.Foldable (for_, traverse_)
+import Control.Monad (unless)
+import Data.Maybe (listToMaybe)
+import GHC.Data.FastString
+import GHC.Utils.Ppr
+
+check_docHead :: Doc -> IO ()
+check_docHead d = do
+  let str = renderStyle style{mode = LeftMode} d
+  unless (fst (docHead d) == listToMaybe str) $
+    putStrLn $ "Fail: " ++ show str
+
+main :: IO ()
+main =
+  traverse_ check_docHead $
+    units ++ pairs ++ triples ++ misc
+  where
+    units   = [id, nest 4] <*> [empty, text "", char 'x']
+    ops     = [(<>), (<+>), ($$), ($+$), \a b -> hang a 4 b]
+    pairs   = [id, nest 4] <*> (ops <*> units <*> units)
+    triples =
+      (ops <*> pairs <*> units) ++
+      (ops <*> units <*> pairs)
+    misc =
+      [
+        text "xString",
+        ftext (fsLit "xFastString"),
+        ftext (fsLit "") <> char 'x',
+        ztext (zEncodeFS (fsLit "xFastZString")),
+        ztext (zEncodeFS (fsLit "")) <> char 'x',
+        ptext (mkPtrString# "xPtrString"#),
+        ptext (mkPtrString# ""#)
+      ]
\ No newline at end of file
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 29e64f096a..5acd8867ab 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -181,3 +181,6 @@ test('Test20315', normal, compile_fail, [''])
 test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])
 test('Test21355', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21355'])
 test('Test21805', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21805'])
+
+test('T22488', normal, ghci_script, ['T22488.script'])
+test('T22488_docHead', normal, compile_and_run, ['-package ghc'])
\ No newline at end of file