Rework group and remove fail

Author: 1Jajen1

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

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

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)

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

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