[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
Mon Nov 21 10:22:59 UTC 2022
Vladislav Zavialov pushed to branch wip/int-index/ppr-space-quote at Glasgow Haskell Compiler / GHC
Commits:
42e61a4f by Vladislav Zavialov at 2022-11-21T13:22:35+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.
- - - - -
9 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_docStartsWith.hs
- + testsuite/tests/printer/T22488_docStartsWith.stdout
- 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 d = m ctx
+ in if Pretty.docStartsWith '\'' d
+ 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,
+ docStartsWith,
-- * Rendering documents
@@ -350,6 +351,35 @@ isEmpty :: Doc -> Bool
isEmpty Empty = True
isEmpty _ = False
+-- | Does the document start with the specified character?
+docStartsWith :: Char -> Doc -> Bool
+docStartsWith expected = go
+ where
+ go :: Doc -> Bool
+ go NoDoc = error "docStartsWith: NoDoc"
+ go Empty = False
+ go (NilAbove _) = go_chr '\n'
+ go (Beside p g q) = go (beside p g q) -- TODO (int-index): optimize this case
+ go (Above p g q) = go (above p g q) -- TODO (int-index): optimize this case
+ go (TextBeside s _ p) = go_td s (go p)
+ go (Nest _ p) = go p
+ go (Union p q) = go (first p q)
+
+ go_td :: TextDetails -> Bool -> Bool
+ go_td (Chr c) _ = go_chr c
+ go_td (Str s) b = go_str s b
+ go_td (PStr s) b = go_str (unpackFS s) b -- O(1) because unpackFS is lazy
+ go_td (ZStr s) b = go_str (zStringTakeN 1 s) b
+ go_td (LStr s) b = go_str (unpackPtrStringTakeN 1 s) b
+ go_td (RStr n c) b = if n > 0 then go_chr c else b
+
+ go_str :: String -> Bool -> Bool
+ go_str [] b = b
+ go_str (c:_) _ = go_chr c
+
+ go_chr :: Char -> Bool
+ go_chr c = c == expected
+
{-
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_docStartsWith.hs
=====================================
@@ -0,0 +1,36 @@
+module Main where
+
+import Prelude hiding ((<>))
+import Data.Foldable (for_)
+import GHC.Utils.Ppr
+
+xChar :: Char
+xChar = 'X'
+
+-- Check docStartsWith for correctness by comparing its result to the result of
+-- the reference implementation.
+check_docStartsWith ::Doc -> IO ()
+check_docStartsWith d =
+ for_ [' ', xChar] $ \c ->
+ if docStartsWith c d == docStartsWith_ref c d
+ then putStrLn "OK"
+ else putStrLn ("Fail: " ++ show d)
+
+-- Reference implementation of docStartsWith. Slow but obviously correct.
+docStartsWith_ref :: Char -> Doc -> Bool
+docStartsWith_ref expected d =
+ case renderStyle style{mode = LeftMode} d of
+ [] -> False
+ c:_ -> c == expected
+
+strStartsWith :: Char -> String -> Bool
+strStartsWith expected s =
+ case s of
+ [] -> False
+ c:_ -> c == expected
+
+main :: IO ()
+main = do
+ check_docStartsWith empty
+ check_docStartsWith (empty <> char xChar)
+ check_docStartsWith (text "" <> char xChar)
\ No newline at end of file
=====================================
testsuite/tests/printer/T22488_docStartsWith.stdout
=====================================
@@ -0,0 +1,6 @@
+OK
+OK
+OK
+OK
+OK
+OK
=====================================
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_docStartsWith', normal, compile_and_run, ['-package ghc'])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42e61a4f8fc8a3493a2daa4de0fb8ca3dcce5a36
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42e61a4f8fc8a3493a2daa4de0fb8ca3dcce5a36
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/20221121/07311ea5/attachment-0001.html>
More information about the ghc-commits
mailing list