Optimization potential

[sjakobi]

In #116 (comment) I shared a profile from a prettyprinter-heavy dhall task. Multiple functions from prettyprinter and prettyprinter-ansi-terminal show up:

COST CENTRE               MODULE                                             SRC                                                                         %time %alloc
layoutWadlerLeijen        Data.Text.Prettyprint.Doc.Internal                 src/Data/Text/Prettyprint/Doc/Internal.hs:(1775,1)-(1843,60)                  5.5    3.0
renderLazy                Data.Text.Prettyprint.Doc.Render.Terminal.Internal src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs:(108,1)-(148,60)    3.7    3.7
removeTrailingWhitespace  Data.Text.Prettyprint.Doc.Internal                 src/Data/Text/Prettyprint/Doc/Internal.hs:(1477,1)-(1537,119)                 2.3    1.1
styleToRawText            Data.Text.Prettyprint.Doc.Render.Terminal.Internal src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs:(278,1)-(304,29)    1.8    2.0
layoutSmart               Data.Text.Prettyprint.Doc.Internal                 src/Data/Text/Prettyprint/Doc/Internal.hs:(1741,1)-(1767,59)                  1.6    0.2
changesUponFlattening     Data.Text.Prettyprint.Doc.Internal                 src/Data/Text/Prettyprint/Doc/Internal.hs:(567,1)-(607,21)                    1.5    1.1

The most interesting candidates are IMHO removeTrailingWhitespace and styleToRawText:

prettyprinter/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs

Lines 1458 to 1519 in fa8ed27

	removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann
	removeTrailingWhitespace = go (RecordedWhitespace [] 0)
	where
	commitWhitespace
	:: [Int] -- Withheld lines
	-> Int -- Withheld spaces
	-> SimpleDocStream ann
	-> SimpleDocStream ann
	commitWhitespace is0 n0 = commitLines is0 . commitSpaces n0
	where
	commitLines [] = id
	commitLines (i:is) = foldr (\_ f -> SLine 0 . f) (SLine i) is
	commitSpaces 0 = id
	commitSpaces 1 = SChar ' '
	commitSpaces n = SText n (T.replicate n " ")
	go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann
	-- We do not strip whitespace inside annotated documents, since it might
	-- actually be relevant there.
	go annLevel@(AnnotationLevel annLvl) = \sds -> case sds of
	SFail -> SFail
	SEmpty -> SEmpty
	SChar c rest -> SChar c (go annLevel rest)
	SText l text rest -> SText l text (go annLevel rest)
	SLine i rest -> SLine i (go annLevel rest)
	SAnnPush ann rest -> let !annLvl' = annLvl+1
	in SAnnPush ann (go (AnnotationLevel annLvl') rest)
	SAnnPop rest
	| annLvl > 1 -> let !annLvl' = annLvl-1
	in SAnnPop (go (AnnotationLevel annLvl') rest)
	| otherwise -> SAnnPop (go (RecordedWhitespace [] 0) rest)
	-- Record all spaces/lines encountered, and once proper text starts again,
	-- release only the necessary ones.
	go (RecordedWhitespace withheldLines withheldSpaces) = \sds -> case sds of
	SFail -> SFail
	SEmpty -> foldr (\_i sds' -> SLine 0 sds') SEmpty withheldLines
	SChar c rest
	| c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest
	| otherwise -> commitWhitespace
	withheldLines
	withheldSpaces
	(SChar c (go (RecordedWhitespace [] 0) rest))
	SText textLength text rest ->
	let stripped = T.dropWhileEnd (== ' ') text
	strippedLength = T.length stripped
	trailingLength = textLength - strippedLength
	isOnlySpace = strippedLength == 0
	in if isOnlySpace
	then go (RecordedWhitespace withheldLines (withheldSpaces + textLength)) rest
	else commitWhitespace
	withheldLines
	withheldSpaces
	(SText strippedLength
	stripped
	(go (RecordedWhitespace [] trailingLength) rest))
	SLine i rest -> go (RecordedWhitespace (i:withheldLines) 0) rest
	SAnnPush ann rest -> commitWhitespace
	withheldLines
	withheldSpaces
	(SAnnPush ann (go (AnnotationLevel 1) rest))
	SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'."

prettyprinter/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs

Lines 291 to 318 in fa8ed27

	styleToRawText :: AnsiStyle -> Text
	styleToRawText = T.pack . ANSI.setSGRCode . stylesToSgrs
	where
	stylesToSgrs :: AnsiStyle -> [ANSI.SGR]
	stylesToSgrs (SetAnsiStyle fg bg b i u) = catMaybes
	[ Just ANSI.Reset
	, fmap (\(intensity, c) -> ANSI.SetColor ANSI.Foreground (convertIntensity intensity) (convertColor c)) fg
	, fmap (\(intensity, c) -> ANSI.SetColor ANSI.Background (convertIntensity intensity) (convertColor c)) bg
	, fmap (\_ -> ANSI.SetConsoleIntensity ANSI.BoldIntensity) b
	, fmap (\_ -> ANSI.SetItalicized True) i
	, fmap (\_ -> ANSI.SetUnderlining ANSI.SingleUnderline) u
	]
	convertIntensity :: Intensity -> ANSI.ColorIntensity
	convertIntensity = \i -> case i of
	Vivid -> ANSI.Vivid
	Dull -> ANSI.Dull
	convertColor :: Color -> ANSI.Color
	convertColor = \c -> case c of
	Black -> ANSI.Black
	Red -> ANSI.Red
	Green -> ANSI.Green
	Yellow -> ANSI.Yellow
	Blue -> ANSI.Blue
	Magenta -> ANSI.Magenta
	Cyan -> ANSI.Cyan
	White -> ANSI.White

[sjakobi]

A few remarks regarding styleToRawText:

• styleToRawText is only used internally by renderLazy and renderIO:

  prettyprinter/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs

  Lines 147 to 157 in fa8ed27

  	SAnnPush style rest -> do
  	currentStyle <- unsafePeek
  	let newStyle = style <> currentStyle
  	push newStyle
  	writeOutput (TLB.fromText (styleToRawText newStyle))
  	go rest
  	SAnnPop rest -> do
  	_currentStyle <- unsafePop
  	newStyle <- unsafePeek
  	writeOutput (TLB.fromText (styleToRawText newStyle))
  	go rest

  
  

  prettyprinter/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs

  Lines 209 to 219 in fa8ed27

  	SAnnPush style rest -> do
  	currentStyle <- unsafePeek
  	let newStyle = style <> currentStyle
  	push newStyle
  	T.hPutStr h (styleToRawText newStyle)
  	go rest
  	SAnnPop rest -> do
  	_currentStyle <- unsafePop
  	newStyle <- unsafePeek
  	T.hPutStr h (styleToRawText newStyle)
  	go rest

• Typical documents probably use only a very limited number of AnsiStyles. It might make sense to cache the corresponding SGRs or even Texts.

• renderIO could skip translation to Text by using hSetSGR.

[sjakobi]

Regarding what's happening inside styleToRawText, I wonder why there are convertIntensity and convertColor:

prettyprinter/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs

Lines 304 to 318 in fa8ed27

	convertIntensity :: Intensity -> ANSI.ColorIntensity
	convertIntensity = \i -> case i of
	Vivid -> ANSI.Vivid
	Dull -> ANSI.Dull
	convertColor :: Color -> ANSI.Color
	convertColor = \c -> case c of
	Black -> ANSI.Black
	Red -> ANSI.Red
	Green -> ANSI.Green
	Yellow -> ANSI.Yellow
	Blue -> ANSI.Blue
	Magenta -> ANSI.Magenta
	Cyan -> ANSI.Cyan
	White -> ANSI.White

These convert to the ansi-terminal types with the very same constructors:

• Color
• ColorIntensity

Why does prettyprinter-ansi-terminal define its own versions of these at all, when it could simply re-export those from ansi-terminal?

prettyprinter/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs

Lines 56 to 62 in fa8ed27

	-- | The 8 ANSI terminal colors.
	data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
	deriving (Eq, Ord, Show)
	-- | Dull or vivid coloring, as supported by ANSI terminals.
	data Intensity = Vivid | Dull
	deriving (Eq, Ord, Show)

[sjakobi]

Regarding styleToRawText, maybe we could take some ideas from basement's ANSI color support.