[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
Sun Nov 20 19:24:45 UTC 2022
Vladislav Zavialov pushed to branch wip/int-index/ppr-space-quote at Glasgow Haskell Compiler / GHC
Commits:
7b758aff by Vladislav Zavialov at 2022-11-20T22:22:28+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.
- - - - -
7 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/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,13 @@ zString :: FastZString -> String
zString (FastZString bs) =
inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen
+-- | @zStringTakeN k = take k . zString@
+-- but is performed in \(O(\min(k,n))\) rather than \(O(n)\).
+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 +595,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 +675,13 @@ mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#))
unpackPtrString :: PtrString -> String
unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n#
+-- | @unpackPtrStringTakeN k = take k . unpackPtrString@
+-- but is performed in \(O(\min(k,n))\) rather than \(O(n)\).
+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,38 @@ 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 Empty = False
+ go NoDoc = False
+ go (NilAbove _) = False
+ go (Beside d1 _ _) = go d1
+ go (Above d1 _ _) = go d1
+ go (TextBeside td _ _) = go_td td
+ go (Nest _ d1) = go d1
+ go (Union d1 _d2) =
+ -- No need to check d2 because of the invariant that d1 and d2 flatten to
+ -- the same string.
+ go d1
+
+ go_td :: TextDetails -> Bool
+ go_td (Chr c) = go_chr 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) = n > 0 && go_chr c
+
+ go_str :: String -> Bool
+ go_str [] = False
+ 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/all.T
=====================================
@@ -181,3 +181,5 @@ 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'])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b758aff2973ebe939ba4b34a75f2b5a10a41234
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b758aff2973ebe939ba4b34a75f2b5a10a41234
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/20221120/b84d3fd2/attachment-0001.html>
More information about the ghc-commits
mailing list