[Git][ghc/ghc][wip/int-index/ppr-space-quote] Check if the SDoc starts with a single quote (#22488)
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Tue Nov 22 13:43:26 UTC 2022
Vladislav Zavialov pushed to branch wip/int-index/ppr-space-quote at Glasgow Haskell Compiler / GHC
Commits:
8a90b2ce by Vladislav Zavialov at 2022-11-22T16:42:18+03:00
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 changed files:
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/GHC/Utils/Ppr.hs
- + testsuite/tests/printer/T22488.script
- + testsuite/tests/printer/T22488.stdout
- + testsuite/tests/printer/T22488_docHead.hs
- testsuite/tests/printer/all.T
Changes:
=====================================
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
=====================================
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
=====================================
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)
=====================================
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) ?
=====================================
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
=====================================
testsuite/tests/printer/T22488.stdout
=====================================
@@ -0,0 +1,4 @@
+T :: [Char]
+= '[ 'x']
+T :: (Char, Char)
+= '( 'x', 'y')
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a90b2ce5e14edfc9f7f74849f8526034b7be246
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a90b2ce5e14edfc9f7f74849f8526034b7be246
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221122/5f08185e/attachment-0001.html>
More information about the ghc-commits
mailing list