Skip to content

Commit

Permalink
Rework group and remove fail
Browse files Browse the repository at this point in the history
  • Loading branch information
1Jajen1 committed Jan 22, 2020
1 parent 83d7471 commit 4ab01d1
Show file tree
Hide file tree
Showing 11 changed files with 58 additions and 158 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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

Expand All @@ -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)
Expand All @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down
190 changes: 56 additions & 134 deletions prettyprinter/src/Data/Text/Prettyprint/Doc/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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



Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit 4ab01d1

Please sign in to comment.