From 4ab01d1971b5eab47c38bc2bbc17381656c16888 Mon Sep 17 00:00:00 2001 From: Jannis Date: Thu, 23 Jan 2020 00:20:52 +0100 Subject: [PATCH] Rework group and remove fail --- .../Doc/Render/Terminal/Internal.hs | 2 - .../src/Text/PrettyPrint/Annotated/Leijen.hs | 4 - .../Text/Prettyprint/Convert/AnsiWlPprint.hs | 3 +- .../src/Data/Text/Prettyprint/Doc/Internal.hs | 190 ++++++------------ .../Text/Prettyprint/Doc/Internal/Debug.hs | 4 +- .../Data/Text/Prettyprint/Doc/Render/Text.hs | 1 - .../Render/Tutorials/StackMachineTutorial.hs | 1 - .../Text/Prettyprint/Doc/Render/Util/Panic.hs | 7 - .../Doc/Render/Util/SimpleDocTree.hs | 1 - .../Doc/Render/Util/StackMachine.hs | 2 - prettyprinter/test/Testsuite/Main.hs | 1 - 11 files changed, 58 insertions(+), 158 deletions(-) diff --git a/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs b/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs index 2093328b..b4d91b33 100644 --- a/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs +++ b/prettyprinter-ansi-terminal/src/Data/Text/Prettyprint/Doc/Render/Terminal/Internal.hs @@ -133,7 +133,6 @@ renderLazy sdoc = runST (do writeOutput x = modifySTRef outputRef (<> x) let go = \sds -> case sds of - SFail -> panicUncaughtFail SEmpty -> pure () SChar c rest -> do writeOutput (TLB.singleton c) @@ -194,7 +193,6 @@ renderIO h sdoc = do x:xs -> writeIORef styleStackRef xs >> pure x let go = \sds -> case sds of - SFail -> panicUncaughtFail SEmpty -> pure () SChar c rest -> do hPutChar h c diff --git a/prettyprinter-compat-annotated-wl-pprint/src/Text/PrettyPrint/Annotated/Leijen.hs b/prettyprinter-compat-annotated-wl-pprint/src/Text/PrettyPrint/Annotated/Leijen.hs index de5cba27..0e3e4d8a 100644 --- a/prettyprinter-compat-annotated-wl-pprint/src/Text/PrettyPrint/Annotated/Leijen.hs +++ b/prettyprinter-compat-annotated-wl-pprint/src/Text/PrettyPrint/Annotated/Leijen.hs @@ -119,7 +119,6 @@ displayDecorated decor sd = go id id [] sd "" in go (sf' . showString formatted) d' stk x go _ _ [] (SAnnPop _) = error "stack underflow" go _ _ _ SEmpty = error "stack not consumed by rendering" - go _ _ _ SFail = panicUncaughtFail displayDecoratedA :: (Applicative f, Monoid b) => (String -> f b) -> (a -> f b) -> (a -> f b) @@ -136,7 +135,6 @@ displayDecoratedA str start end sd = go [] sd -- malformed documents go [] (SAnnPop _) = error "stack underflow" go _ SEmpty = error "stack not consumed by rendering" - go _ SFail = panicUncaughtFail (<++>) = liftA2 mappend @@ -157,7 +155,6 @@ displaySpans sd = go 0 [] sd -- malformed documents go _ [] (SAnnPop _) = error "stack underflow" go _ _ SEmpty = error "Stack not consumed by rendering" - go _ _ SFail = panicUncaughtFail mapFst :: (a -> b) -> (a, c) -> (b, c) mapFst f (x, y) = (f x, y) @@ -168,7 +165,6 @@ displaySpans sd = go 0 [] sd displayIO :: Handle -> SimpleDoc a -> IO () displayIO h simpleDoc = go simpleDoc where - go SFail = panicUncaughtFail go SEmpty = pure () go (SChar c x) = hPutChar h c >> go x go (SText _ s x) = T.hPutStr h s >> go x diff --git a/prettyprinter-convert-ansi-wl-pprint/src/Data/Text/Prettyprint/Convert/AnsiWlPprint.hs b/prettyprinter-convert-ansi-wl-pprint/src/Data/Text/Prettyprint/Convert/AnsiWlPprint.hs index d2cb7f86..bc9b82b8 100644 --- a/prettyprinter-convert-ansi-wl-pprint/src/Data/Text/Prettyprint/Convert/AnsiWlPprint.hs +++ b/prettyprinter-convert-ansi-wl-pprint/src/Data/Text/Prettyprint/Convert/AnsiWlPprint.hs @@ -33,7 +33,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen.Internal as Old -- | @ansi-wl-pprint ───▷ prettyprinter@ fromAnsiWlPprint :: Old.Doc -> New.Doc NewTerm.AnsiStyle fromAnsiWlPprint = \doc -> case doc of - Old.Fail -> New.Fail + Old.Fail -> undefined -- TODO Old.Empty -> New.Empty Old.Char c -> New.Char c Old.Text l t -> New.Text l (T.pack t) @@ -86,7 +86,6 @@ fromAnsiWlPprint = \doc -> case doc of -- | @prettyprinter ───▷ ansi-wl-pprint@ toAnsiWlPprint :: New.Doc NewTerm.AnsiStyle -> Old.Doc toAnsiWlPprint = \doc -> case doc of - New.Fail -> Old.Fail New.Empty -> Old.Empty New.Char c -> Old.Char c New.Text l t -> Old.Text l (T.unpack t) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs index 74914b39..8fc55ff9 100755 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs @@ -80,13 +80,8 @@ import Data.Text.Prettyprint.Doc.Render.Util.Panic -- hello -- world data Doc ann = - - -- | Occurs when flattening a line. The layouter will reject this document, - -- choosing a more suitable rendering. - Fail - -- | The empty document; conceptually the unit of 'Cat' - | Empty + Empty -- | invariant: not '\n' | Char !Char @@ -523,88 +518,61 @@ hardline = Line -- use of it. group :: Doc ann -> Doc ann -- See note [Group: special flattening] -group x = case changesUponFlattening x of - Flattened x' -> Union x' x - AlreadyFlat -> x - NeverFlat -> x - --- Note [Group: special flattening] --- --- Since certain documents do not change under removal of newlines etc, there is --- no point in creating a 'Union' of the flattened and unflattened version – all --- this does is introducing two branches for the layout algorithm to take, --- resulting in potentially exponential behavior on deeply nested examples, such --- as --- --- pathological n = iterate (\x -> hsep [x, sep []] ) "foobar" !! n --- --- See https://github.com/quchen/prettyprinter/issues/22 for the corresponding --- ticket. - -data FlattenResult a - = Flattened a - -- ^ @a@ is likely flatter than the input. - | AlreadyFlat - -- ^ The input was already flat, e.g. a 'Text'. - | NeverFlat - -- ^ The input couldn't be flattened: It contained a 'Line' or 'Fail'. +group = \doc -> case doc of + FlatAlt x y -> Union (group y) x + x@(Union _ _) -> x + + x@(Cat a b) -> case groupNoLine a of + -- We could not flatten the left side + HasLine -> x + -- Left side flattened without a problem + FlatNoLine a' -> Cat a' (group b) + -- Left side may contain a Line, need to wrap in Union + FlatMaybeLine a' -> Union (Cat a' (group b)) x + + Annotated a x -> Annotated a (group x) + Nest i x -> Nest i (group x) + Column f -> Column (group . f) + Nesting f -> Nesting (group . f) + WithPageWidth f -> WithPageWidth (group . f) + + x@Text{} -> x + x@Char{} -> x + x@Empty -> x + x@Line -> x + where + groupNoLine :: Doc ann -> FlattenResult (Doc ann) + groupNoLine = \doc -> case doc of + FlatAlt x y -> (flip Union $ x) <$> (groupNoLine y) + Union x _ -> FlatNoLine x + Line -> HasLine + Cat x y -> case (groupNoLine x, groupNoLine y) of + (HasLine , _ ) -> HasLine + (_ , HasLine ) -> HasLine + (FlatMaybeLine a , FlatMaybeLine b) -> FlatMaybeLine (Cat a b) + (FlatMaybeLine a , FlatNoLine b ) -> FlatMaybeLine (Cat a b) + (FlatNoLine a , FlatMaybeLine b) -> FlatMaybeLine (Cat a b) + (FlatNoLine a , FlatNoLine b ) -> FlatNoLine (Cat a b) + + Annotated a x -> Annotated a <$> groupNoLine x + Nest i x -> Nest i <$> groupNoLine x + Column f -> FlatMaybeLine (Column (group . f)) + Nesting f -> FlatMaybeLine (Nesting (group . f)) + WithPageWidth f -> FlatMaybeLine (WithPageWidth (group . f)) + + x@Text{} -> FlatNoLine x + x@Char{} -> FlatNoLine x + x@Empty -> FlatNoLine x + +data FlattenResult a = + FlatNoLine a + | FlatMaybeLine a + | HasLine instance Functor FlattenResult where - fmap f (Flattened a) = Flattened (f a) - fmap _ AlreadyFlat = AlreadyFlat - fmap _ NeverFlat = NeverFlat - --- | Choose the first element of each @Union@, and discard the first field of --- all @FlatAlt@s. --- --- The result is 'Flattened' if the element might change depending on the layout --- algorithm (i.e. contains differently renderable sub-documents), and 'AlreadyFlat' --- if the document is static (e.g. contains only a plain 'Empty' node). --- 'NeverFlat' is returned when the document cannot be flattened because it --- contains a hard 'Line' or 'Fail'. --- See [Group: special flattening] for further explanations. -changesUponFlattening :: Doc ann -> FlattenResult (Doc ann) -changesUponFlattening = \doc -> case doc of - FlatAlt _ y -> Flattened (flatten y) - Line -> NeverFlat - Union x _ -> Flattened x - Nest i x -> fmap (Nest i) (changesUponFlattening x) - Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x) - - Column f -> Flattened (Column (flatten . f)) - Nesting f -> Flattened (Nesting (flatten . f)) - WithPageWidth f -> Flattened (WithPageWidth (flatten . f)) - - Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of - (NeverFlat , _ ) -> NeverFlat - (_ , NeverFlat ) -> NeverFlat - (Flattened x' , Flattened y') -> Flattened (Cat x' y') - (Flattened x' , AlreadyFlat ) -> Flattened (Cat x' y) - (AlreadyFlat , Flattened y') -> Flattened (Cat x y') - (AlreadyFlat , AlreadyFlat ) -> AlreadyFlat - - Empty -> AlreadyFlat - Char{} -> AlreadyFlat - Text{} -> AlreadyFlat - Fail -> NeverFlat - where - -- Flatten, but don’t report whether anything changes. - flatten :: Doc ann -> Doc ann - flatten = \doc -> case doc of - FlatAlt _ y -> flatten y - Cat x y -> Cat (flatten x) (flatten y) - Nest i x -> Nest i (flatten x) - Line -> Fail - Union x _ -> flatten x - Column f -> Column (flatten . f) - WithPageWidth f -> WithPageWidth (flatten . f) - Nesting f -> Nesting (flatten . f) - Annotated ann x -> Annotated ann (flatten x) - - x@Fail -> x - x@Empty -> x - x@Char{} -> x - x@Text{} -> x + fmap f (FlatNoLine a) = FlatNoLine (f a) + fmap f (FlatMaybeLine a) = FlatMaybeLine (f a) + fmap _ HasLine = HasLine @@ -1266,7 +1234,6 @@ alterAnnotations :: (ann -> [ann']) -> Doc ann -> Doc ann' alterAnnotations re = go where go = \doc -> case doc of - Fail -> Fail Empty -> Empty Char c -> Char c Text l t -> Text l t @@ -1292,7 +1259,6 @@ unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx unAnnotateS = go where go = \doc -> case doc of - SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go rest) SText l t rest -> SText l t (go rest) @@ -1305,7 +1271,6 @@ reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann' reAnnotateS re = go where go = \doc -> case doc of - SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go rest) SText l t rest -> SText l t (go rest) @@ -1329,7 +1294,6 @@ alterAnnotationsS re = go [] -- We keep a stack of whether to remove a pop so that we can remove exactly -- the pops corresponding to annotations that mapped to Nothing. go stack = \sds -> case sds of - SFail -> SFail SEmpty -> SEmpty SChar c rest -> SChar c (go stack rest) SText l t rest -> SText l t (go stack rest) @@ -1445,8 +1409,7 @@ fuse depth = go -- convert from @'SimpleDocStream'@. The »Render« submodules provide some -- built-in converters to do so, and helpers to create own ones. data SimpleDocStream ann = - SFail - | SEmpty + SEmpty | SChar Char (SimpleDocStream ann) -- | Some layout algorithms use the Since the frequently used 'T.length' of @@ -1494,7 +1457,6 @@ removeTrailingWhitespace = go (RecordedWhitespace [] 0) -- 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) @@ -1508,7 +1470,6 @@ removeTrailingWhitespace = go (RecordedWhitespace [] 0) -- 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 @@ -1577,7 +1538,6 @@ instance Foldable SimpleDocStream where foldMap f = go where go = \sds -> case sds of - SFail -> mempty SEmpty -> mempty SChar _ rest -> go rest SText _ _ rest -> go rest @@ -1591,7 +1551,6 @@ instance Traversable SimpleDocStream where traverse f = go where go = \sds -> case sds of - SFail -> pure SFail SEmpty -> pure SEmpty SChar c rest -> SChar c <$> go rest SText l t rest -> SText l t <$> go rest @@ -1679,7 +1638,6 @@ layoutPretty = layoutWadlerLeijen -> SimpleDocStream ann -> Bool fits w _ | w < 0 = False - fits _ SFail = False fits _ SEmpty = True fits w (SChar _ x) = fits (w - 1) x fits w (SText l _t x) = fits (w - l) x @@ -1751,7 +1709,6 @@ layoutSmart = layoutWadlerLeijen (FittingPredicate fits) -> SimpleDocStream ann -> Bool fits _ _ w _ | w < 0 = False - fits _ _ _ SFail = False fits _ _ _ SEmpty = True fits pw m w (SChar _ x) = fits pw m (w - 1) x fits pw m w (SText l _t x) = fits pw m (w - l) x @@ -1784,7 +1741,6 @@ layoutWadlerLeijen best !_ !_ Nil = SEmpty best nl cc (UndoAnn ds) = SAnnPop (best nl cc ds) best nl cc (Cons i d ds) = case d of - Fail -> SFail Empty -> best nl cc ds Char c -> let !cc' = cc+1 in SChar c (best nl cc' ds) Text l t -> let !cc' = cc+l in SText l t (best nl cc' ds) @@ -1827,41 +1783,9 @@ layoutWadlerLeijen ribbonWidth = (max 0 . min lineLength . round) (fromIntegral lineLength * ribbonFraction) - Unbounded - -- See the Note [Detecting failure with Unbounded page width]. - | not (failsOnFirstLine x) -> x + Unbounded -> x _ -> y - failsOnFirstLine :: SimpleDocStream ann -> Bool - failsOnFirstLine = go - where - go sds = case sds of - SFail -> True - SEmpty -> False - SChar _ s -> go s - SText _ _ s -> go s - SLine _ _ -> False - SAnnPush _ s -> go s - SAnnPop s -> go s - - --- Note [Detecting failure with Unbounded page width] --- --- To understand why it is sufficient to check the first line of the --- SimpleDocStream, trace how an SFail ends up there: --- --- 1. We group a Doc containing a Line, producing a (Union x y) where --- x contains Fail. --- --- 2. In best, any Unions are handled recursively, rejecting any --- alternatives that would result in SFail. --- --- So once a SimpleDocStream reaches selectNicer, any SFail in it must --- appear before the first linebreak – any other SFail would have been --- detected and rejected in a previous iteration. - - - -- | @(layoutCompact x)@ lays out the document @x@ without adding any -- indentation. Since no \'pretty\' printing is involved, this layouter is very -- fast. The resulting output contains fewer characters than a prettyprinted @@ -1885,7 +1809,6 @@ layoutCompact doc = scan 0 [doc] where scan _ [] = SEmpty scan !col (d:ds) = case d of - Fail -> SFail Empty -> scan col ds Char c -> SChar c (scan (col+1) ds) Text l t -> let !col' = col+l in SText l t (scan col' ds) @@ -1913,7 +1836,6 @@ instance Show (Doc ann) where -- @ renderShowS :: SimpleDocStream ann -> ShowS renderShowS = \sds -> case sds of - SFail -> panicUncaughtFail SEmpty -> id SChar c x -> showChar c . renderShowS x SText _l t x -> showString (T.unpack t) . renderShowS x diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs index c6f0bc79..54e40274 100644 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Internal/Debug.hs @@ -34,8 +34,7 @@ import qualified Data.Text.Prettyprint.Doc.Internal as Doc -- constructors don't contain functions but are \"sampled\" to allow -- simple inspection with 'show'. data Diag ann = - Fail - | Empty + Empty | Char !Char | Text !Int !Text | Line @@ -76,7 +75,6 @@ diag' diag' columns pageWidths nestings = go where go doc = case doc of - Doc.Fail -> Fail Doc.Empty -> Empty Doc.Char c -> Char c Doc.Text l t -> Text l t diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Text.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Text.hs index f6513154..5cbda252 100644 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Text.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Text.hs @@ -79,7 +79,6 @@ renderIO h = go where go :: SimpleDocStream ann -> IO () go = \sds -> case sds of - SFail -> panicUncaughtFail SEmpty -> pure () SChar c rest -> do hPutChar h c go rest diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs index 9c5a61cc..b35feddf 100644 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Tutorials/StackMachineTutorial.hs @@ -82,7 +82,6 @@ color c = annotate (Color c) -- 'Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial.renderTree'. renderStackMachine :: SimpleDocStream SimpleHtml -> StackMachine TLB.Builder SimpleHtml () renderStackMachine = \sds -> case sds of - SFail -> panicUncaughtFail SEmpty -> pure () SChar c x -> do writeOutput (TLB.singleton c) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs index 582a7f23..501b8f7d 100644 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/Panic.hs @@ -1,17 +1,10 @@ module Data.Text.Prettyprint.Doc.Render.Util.Panic ( - panicUncaughtFail, panicUnpairedPop, panicSimpleDocTreeConversionFailed, panicInputNotFullyConsumed, panicPeekedEmpty, panicPoppedEmpty, ) where - --- | Raise a hard 'error' if there is a 'Data.Text.Prettyprint.Doc.SFail' in a --- 'Data.Text.Prettyprint.Doc.SimpleDocStream'. -panicUncaughtFail :: void -panicUncaughtFail = error ("»SFail« must not appear in a rendered »SimpleDocStream«. This is a bug in the layout algorithm! " ++ report) - -- | Raise a hard 'error' when an annotation terminator is encountered in an -- unannotated region. panicUnpairedPop :: void diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs index db310e4a..ff7596cd 100644 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/SimpleDocTree.hs @@ -184,7 +184,6 @@ instance Functor SimpleDocTree where -- | Get the next token, consuming it in the process. nextToken :: UniqueParser (SimpleDocStream ann) (SimpleDocTok ann) nextToken = UniqueParser (\sds -> case sds of - SFail -> panicUncaughtFail SEmpty -> empty SChar c rest -> Just (TokChar c , rest) SText l t rest -> Just (TokText l t , rest) diff --git a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs index 054ef059..dd881945 100644 --- a/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs +++ b/prettyprinter/src/Data/Text/Prettyprint/Doc/Render/Util/StackMachine.hs @@ -73,7 +73,6 @@ renderSimplyDecorated -> out renderSimplyDecorated text push pop = go [] where - go _ SFail = panicUncaughtFail go [] SEmpty = mempty go (_:_) SEmpty = panicInputNotFullyConsumed go stack (SChar c rest) = text (T.singleton c) <> go stack rest @@ -94,7 +93,6 @@ renderSimplyDecoratedA -> f out renderSimplyDecoratedA text push pop = go [] where - go _ SFail = panicUncaughtFail go [] SEmpty = pure mempty go (_:_) SEmpty = panicInputNotFullyConsumed go stack (SChar c rest) = text (T.singleton c) <++> go stack rest diff --git a/prettyprinter/test/Testsuite/Main.hs b/prettyprinter/test/Testsuite/Main.hs index d8492d32..1230bc98 100644 --- a/prettyprinter/test/Testsuite/Main.hs +++ b/prettyprinter/test/Testsuite/Main.hs @@ -231,7 +231,6 @@ instance Arbitrary (FittingPredicate ann) where instance CoArbitrary (SimpleDocStream ann) where coarbitrary s0 = case s0 of - SFail -> variant' 0 SEmpty -> variant' 1 SChar _c s -> variant' 2 . coarbitrary s SText l _t s -> variant' 3 . coarbitrary (l, s)