-- Copyright 2015 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{- | This is a library to lay out text with line wrapping and indenting.

    The basic theory is that you concatenate text with 'BreakType's.  In
    addition, you can increment the indent level with 'withIndent'.  When
    'render' wraps the text, it will break on the lowest indent level, or as
    soon as the indent level decreases.

    A further wrinkle is that you can mark alternate layouts with 'shortForm'.
-}
module Util.Format (
    Doc, shortForm, text, string
    , (</>), (<+/>), (<//>), (<+>)
    , newline, unlines, paragraphs, wrap, wrapWords
    , withIndent, indent, indent_, indentLine
    , Width, render, renderFlat
    , simplify, denest
#ifdef TESTING
    , module Util.Format
#endif
) where
import           Prelude hiding (unlines)
import qualified Data.Char.WCWidth as WCWidth
import qualified Data.List as List
import qualified Data.String as String
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.Builder as Builder

import qualified Util.Num as Num
import qualified Util.Seq as Seq


data Doc =
    -- | Use 'text' instead of this constructor to get newlines right.
    Text !Text
    | Doc :+ Doc -- intentionally lazy
    -- | Use 'shortForm'.
    | ShortForm Doc Doc
    -- | Change the indent by the given number of steps.  The new indent level
    -- only takes effect after the first Break.
    | Indent !Indent
    -- | Line break.
    | Break !BreakType
    deriving (Doc -> Doc -> Bool
(Doc -> Doc -> Bool) -> (Doc -> Doc -> Bool) -> Eq Doc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Doc -> Doc -> Bool
$c/= :: Doc -> Doc -> Bool
== :: Doc -> Doc -> Bool
$c== :: Doc -> Doc -> Bool
Eq, Width -> Doc -> ShowS
[Doc] -> ShowS
Doc -> String
(Width -> Doc -> ShowS)
-> (Doc -> String) -> ([Doc] -> ShowS) -> Show Doc
forall a.
(Width -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Doc] -> ShowS
$cshowList :: [Doc] -> ShowS
show :: Doc -> String
$cshow :: Doc -> String
showsPrec :: Width -> Doc -> ShowS
$cshowsPrec :: Width -> Doc -> ShowS
Show)
infixr :+

-- | Number of indent levels.  The provided indent text will be replicated this
-- many times.
type Indent = Int

{-
    I tried to define (:+) as @Union Doc Break Doc@ to enforce that exactly
    one break is between each Doc.  I also hoped to avoid awkward constructions
    like @"text" <> indented "x"@ or text <> ShortForm by making Doc
    no longer a Monoid.  Unfortunately, I do in fact want to stick text on
    Docs, e.g. @map (","<+>) docs@, and I can no longer write
    @"a" <> "b" </> "c"@ since I'd have to manually wrap the text parts in
    a constructor.  Trying to automatically promote with a typeclass runs into
    ambiguity errors with IsString.

    It's probably still possible if I don't mind some manual promotion, but
    (<>) sticking text inside Indent or ShortForm doesn't seem that bad.
-}

instance Semigroup Doc where <> :: Doc -> Doc -> Doc
(<>) = Doc -> Doc -> Doc
(:+)
instance Monoid Doc where
    mempty :: Doc
mempty = Text -> Doc
Text Text
forall a. Monoid a => a
mempty
    mappend :: Doc -> Doc -> Doc
mappend = Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>)

instance String.IsString Doc where
    fromString :: String -> Doc
fromString = Text -> Doc
text (Text -> Doc) -> (String -> Text) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
String.fromString

{- | The first Doc is the short form, which will be used if it doesn't have
    to wrap.  So you can give a compact form which will render if it can fit
    without breaking, and then a form with more fancy layout that will be used
    if it does have to break.  For example, @[1, 2, 3]@ for short lists, and
    @[1\\n, 2\\n, 3\\n]@ for long ones.

    Prepending text to a shortForm will distribute over both short and long
    forms.  Otherwise, if you write @"prefix " <> x@, and @x@ happens to be
    a shortForm, the long form loses the prefix.

    Appending two shortForms will make you lose the long form of the second
    one.  So don't do that.  TODO I'd rather both short and long forms be
    appended, but haven't figured out how to do that yet.
-}
shortForm :: Doc -> Doc -> Doc
shortForm :: Doc -> Doc -> Doc
shortForm = Doc -> Doc -> Doc
ShortForm

text :: Text -> Doc
text :: Text -> Doc
text Text
t = case Text -> [Doc]
make Text
t of
    [] -> Doc
forall a. Monoid a => a
mempty
    [Doc]
ts -> (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(:+) ([Doc] -> [Doc]
merge [Doc]
ts)
    where
    merge :: [Doc] -> [Doc]
merge [] = []
    merge [Doc]
breaks = case (Doc -> Maybe Width) -> [Doc] -> ([Width], [Doc])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.span_while Doc -> Maybe Width
isHard [Doc]
breaks of
        ([], []) -> []
        ([], Doc
x : [Doc]
xs) -> Doc
x Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
merge [Doc]
xs
        ([Width]
hs, [Doc]
rest) -> BreakType -> Doc
Break (Width -> BreakType
Hard ([Width] -> Width
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Width]
hs)) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc] -> [Doc]
merge [Doc]
rest
    isHard :: Doc -> Maybe Width
isHard (Break (Hard Width
n)) = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
n
    isHard Doc
_ = Maybe Width
forall a. Maybe a
Nothing
    make :: Text -> [Doc]
make = (Doc -> Bool) -> [Doc] -> [Doc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Doc -> Bool) -> Doc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Bool
isEmpty) ([Doc] -> [Doc]) -> (Text -> [Doc]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse (Width -> Doc
newline Width
1) ([Doc] -> [Doc]) -> (Text -> [Doc]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
Text
        ([Text] -> [Doc]) -> (Text -> [Text]) -> Text -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')

string :: String -> Doc
string :: String -> Doc
string = Text -> Doc
text (Text -> Doc) -> (String -> Text) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

isEmpty :: Doc -> Bool
isEmpty :: Doc -> Bool
isEmpty (Text Text
t) = Text -> Bool
Text.null Text
t
isEmpty Doc
_ = Bool
False

-- | Space becomes a space when it doesn't break, NoSpace doesn't.  Hard
-- breaks can insert >=1 newlines.
data BreakType = NoSpace | Space | Hard !Int deriving (BreakType -> BreakType -> Bool
(BreakType -> BreakType -> Bool)
-> (BreakType -> BreakType -> Bool) -> Eq BreakType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BreakType -> BreakType -> Bool
$c/= :: BreakType -> BreakType -> Bool
== :: BreakType -> BreakType -> Bool
$c== :: BreakType -> BreakType -> Bool
Eq, Eq BreakType
Eq BreakType
-> (BreakType -> BreakType -> Ordering)
-> (BreakType -> BreakType -> Bool)
-> (BreakType -> BreakType -> Bool)
-> (BreakType -> BreakType -> Bool)
-> (BreakType -> BreakType -> Bool)
-> (BreakType -> BreakType -> BreakType)
-> (BreakType -> BreakType -> BreakType)
-> Ord BreakType
BreakType -> BreakType -> Bool
BreakType -> BreakType -> Ordering
BreakType -> BreakType -> BreakType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BreakType -> BreakType -> BreakType
$cmin :: BreakType -> BreakType -> BreakType
max :: BreakType -> BreakType -> BreakType
$cmax :: BreakType -> BreakType -> BreakType
>= :: BreakType -> BreakType -> Bool
$c>= :: BreakType -> BreakType -> Bool
> :: BreakType -> BreakType -> Bool
$c> :: BreakType -> BreakType -> Bool
<= :: BreakType -> BreakType -> Bool
$c<= :: BreakType -> BreakType -> Bool
< :: BreakType -> BreakType -> Bool
$c< :: BreakType -> BreakType -> Bool
compare :: BreakType -> BreakType -> Ordering
$ccompare :: BreakType -> BreakType -> Ordering
Ord, Width -> BreakType -> ShowS
[BreakType] -> ShowS
BreakType -> String
(Width -> BreakType -> ShowS)
-> (BreakType -> String)
-> ([BreakType] -> ShowS)
-> Show BreakType
forall a.
(Width -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BreakType] -> ShowS
$cshowList :: [BreakType] -> ShowS
show :: BreakType -> String
$cshow :: BreakType -> String
showsPrec :: Width -> BreakType -> ShowS
$cshowsPrec :: Width -> BreakType -> ShowS
Show)

-- | Hard breaks with more newlines win over those with fewer.
instance Semigroup BreakType where <> :: BreakType -> BreakType -> BreakType
(<>) = BreakType -> BreakType -> BreakType
forall a. Ord a => a -> a -> a
max

instance Monoid BreakType where
    mempty :: BreakType
mempty = BreakType
NoSpace
    mappend :: BreakType -> BreakType -> BreakType
mappend = BreakType -> BreakType -> BreakType
forall a. Semigroup a => a -> a -> a
(<>)

-- | Soft break with no space.
(</>) :: Doc -> Doc -> Doc
Doc
d1 </> :: Doc -> Doc -> Doc
</> Doc
d2 = Doc
d1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> BreakType -> Doc
Break BreakType
NoSpace Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d2
infixr 5 </> -- looser than <>

-- | Soft break with a space.
(<+/>) :: Doc -> Doc -> Doc
Doc
d1 <+/> :: Doc -> Doc -> Doc
<+/> Doc
d2 = Doc
d1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> BreakType -> Doc
Break BreakType
Space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d2
infixr 5 <+/> -- looser than <>

-- | Hard break with a single 'newline'.
(<//>) :: Doc -> Doc -> Doc
Doc
d1 <//> :: Doc -> Doc -> Doc
<//> Doc
d2 = Doc
d1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Width -> Doc
newline Width
1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d2
infixr 4 <//> -- looser than </>

{- | Increase the indent level for the given Doc.  The indent change only
    takes effect after the first break, so if you want it to take effect
    immediately, use one of 'indent', 'indent_', or 'indentLine'.

    The reason indent is delayed is that this way you can do a hanging indent,
    where the current line is unindented, but it will be indented if it wraps.
    Otherwise you don't know where to put the indent, since you don't know
    where the break will happen.
-}
withIndent :: Doc -> Doc
withIndent :: Doc -> Doc
withIndent Doc
doc = Width -> Doc
Indent Width
1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
doc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Width -> Doc
Indent (-Width
1)

indentBreak :: BreakType -> Doc -> Doc
indentBreak :: BreakType -> Doc -> Doc
indentBreak BreakType
break Doc
doc = Width -> Doc
Indent Width
1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> BreakType -> Doc
Break BreakType
break Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
doc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Width -> Doc
Indent (-Width
1)

-- | Change the indent level and add a no-space break so it takes effect
-- immediately.
indent :: Doc -> Doc
indent :: Doc -> Doc
indent = BreakType -> Doc -> Doc
indentBreak BreakType
NoSpace

-- | Change the indent level and add a spaced break so it takes effect
-- immediately.
indent_ :: Doc -> Doc
indent_ :: Doc -> Doc
indent_ = BreakType -> Doc -> Doc
indentBreak BreakType
Space

-- | Change the indent level and add a hard break so it takes effect
-- immediately.
indentLine :: Doc -> Doc
indentLine :: Doc -> Doc
indentLine = BreakType -> Doc -> Doc
indentBreak (Width -> BreakType
Hard Width
1)

-- | Join two docs with a space.
(<+>) :: Doc -> Doc -> Doc
Doc
d1 <+> :: Doc -> Doc -> Doc
<+> Doc
d2 = Doc
d1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Text Text
" " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d2
infixr 6 <+> -- same as <>

-- | Insert a number of newlines.
--
-- Consecutive breaks are merged together, and a hard break always wins.
-- Also, multiple hard breaks are merged into one, and ones with greater
-- newlines win other those with fewer.  The rationale is that if you are
-- formatting a list of sub-Docs, and you want to put each on its own line, you
-- need a hard break after each one, but if one of them does the same thing,
-- you wind up with two breaks in a row.
newline :: Int -> Doc
newline :: Width -> Doc
newline Width
n = BreakType -> Doc
Break (Width -> BreakType
Hard Width
n)

-- | Analogous to 'Prelude.unlines', terminate each Doc with a newline.
unlines :: [Doc] -> Doc
unlines :: [Doc] -> Doc
unlines [] = Doc
forall a. Monoid a => a
mempty
unlines [Doc]
docs = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse (Width -> Doc
newline Width
1) [Doc]
docs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Width -> Doc
newline Width
1

-- | This is just like 'unlines', but separate docs with two newlines, and
-- terminate the last with one.
paragraphs :: [Doc] -> Doc
paragraphs :: [Doc] -> Doc
paragraphs [] = Doc
forall a. Monoid a => a
mempty
paragraphs [Doc]
docs = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse (Width -> Doc
newline Width
2) [Doc]
docs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Width -> Doc
newline Width
1


wrapWords :: [Doc] -> Doc
wrapWords :: [Doc] -> Doc
wrapWords (Doc
d:[Doc]
ds) = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Doc -> Doc -> Doc
(<+/>) Doc
d [Doc]
ds
wrapWords [] = Doc
forall a. Monoid a => a
mempty

wrap :: [Doc] -> Doc
wrap :: [Doc] -> Doc
wrap (Doc
d:[Doc]
ds) = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Doc -> Doc -> Doc
(</>) Doc
d [Doc]
ds
wrap [] = Doc
forall a. Monoid a => a
mempty

-- * render

-- | Width of monospace text, in characters.
type Width = Int

data State = State {
    -- | Collect text for each Section, for 'sectionB'.
    State -> B
stateCollect :: !B
    -- | Collect long form Sections for 'sectionSubs'.  Like stateSections,
    -- this is in reverse order.
    , State -> [Section]
stateSubs :: ![Section]
    -- | Collect sections in reverse order.
    , State -> [Section]
stateSections :: ![Section]

    -- | Track the current indent.  This is updated whenever I see a Indented.
    , State -> Width
stateIndent :: !Indent
    -- | This is the previous value of 'stateIndent'.  It's needed because it
    -- goes into 'sectionEndIndent', details there.
    , State -> Width
statePreviousIndent :: !Indent
    -- | Indent for the next break.  This is different from 'stateIndent',
    -- which is the current indent value because the new indent only applies
    -- *after* the next break.  Also, after a dedent I still need the indented
    -- value to apply to the section.
    , State -> Width
stateBreakIndent :: !Indent
    } deriving (Width -> State -> ShowS
[State] -> ShowS
State -> String
(Width -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Width -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Width -> State -> ShowS
$cshowsPrec :: Width -> State -> ShowS
Show)

data Section = Section {
    -- | This is the indent in effect when the section starts, and will be the
    -- physical indent of the section if it gets wrapped.
    Section -> Width
sectionStartIndent :: !Indent
    -- | The indent of this section for breaking, see [NOTE end-indent].
    , Section -> Width
sectionEndIndent :: !Indent
    -- | Text of the section.
    , Section -> B
sectionB :: !B
    -- | If present, the B is a short version.  If it doesn't fit on a line of
    -- its own, then flatten the subs.  Normally I put down Sections until
    -- I have to break.  A short layout stands in for a list of Sections.  When
    -- I see one, I try to place it, and if it doesn't fit, use the
    -- sub-Sections.
    , Section -> [Section]
sectionSubs :: ![Section]
    , Section -> BreakType
sectionBreak :: !BreakType
    } deriving (Width -> Section -> ShowS
[Section] -> ShowS
Section -> String
(Width -> Section -> ShowS)
-> (Section -> String) -> ([Section] -> ShowS) -> Show Section
forall a.
(Width -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Section] -> ShowS
$cshowList :: [Section] -> ShowS
show :: Section -> String
$cshow :: Section -> String
showsPrec :: Width -> Section -> ShowS
$cshowsPrec :: Width -> Section -> ShowS
Show)

{- [NOTE end-indent]
    If there are multiple 'withIndent's during a section, a Section will will
    start with one indent but end with another.  This is important because
    while the physical indent is 'sectionStartIndent', when it wraps it should
    be counted as the sectionEndIndent.  For example, given

    "{ " Indent "[ " Indent "k1" Break ": v1" Dedent Break
        ", " Indent "k2" Break ": v2" Dedent Dedent

    0 1 2 /  1/ 2 /     <- current indent / break
    01    22  11  22    <- section (start indent, end indent)
    { [ k1: v1
              , k2: v2

    by the time I get to the first Break, I'm logically at a syntactic indent
    level of 1, even though the physical indent is 0.  So when I later wrap,
    I need to count "{ [ k1" as a level 1 rather than 0.  Otherwise, it will
    prefer to break right there, and I will get this:

    { [ k1:
        v1
      , k2: v2

    instead of this:

    { [ k1: v1
      , k2: v2
-}

sectionBuilder :: Section -> Builder.Builder
sectionBuilder :: Section -> Builder
sectionBuilder = B -> Builder
bBuilder (B -> Builder) -> (Section -> B) -> Section -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Section -> B
sectionB

flatten :: Doc -> [Section]
flatten :: Doc -> [Section]
flatten = [Section] -> [Section]
postprocSections ([Section] -> [Section]) -> (Doc -> [Section]) -> Doc -> [Section]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> [Section]
stateSections (State -> [Section]) -> (Doc -> State) -> Doc -> [Section]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
flush (State -> State) -> (Doc -> State) -> Doc -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> State -> State) -> State -> Doc -> State
forall a b c. (a -> b -> c) -> b -> a -> c
flip Doc -> State -> State
go State
initialState
    where
    initialState :: State
initialState = State
        { stateCollect :: B
stateCollect = B
forall a. Monoid a => a
mempty
        , stateSubs :: [Section]
stateSubs = []
        , stateSections :: [Section]
stateSections = []
        , stateIndent :: Width
stateIndent = Width
0
        , stateBreakIndent :: Width
stateBreakIndent = Width
0
        , statePreviousIndent :: Width
statePreviousIndent = Width
0
        }
    go :: Doc -> State -> State
go Doc
doc State
state = case Doc
doc of
        Text Text
t -> State
state { stateCollect :: B
stateCollect = State -> B
stateCollect State
state B -> B -> B
forall a. Semigroup a => a -> a -> a
<> Text -> B
bFromText Text
t }
        Doc
d1 :+ Doc
d2 -> Doc -> State -> State
go Doc
d2 (Doc -> State -> State
go Doc
d1 State
state)
        ShortForm Doc
short Doc
long -> State
state
            { stateCollect :: B
stateCollect =
                State -> B
stateCollect State
state B -> B -> B
forall a. Semigroup a => a -> a -> a
<> [Section] -> B
renderSectionsB (Doc -> [Section]
flatten Doc
short)
            -- Whatever is in stateSubs state will be lost.  But if I collect
            -- it into stateSubs I get even more confusing results.  I can't
            -- figure out how to get ShortForm <> ShortForm to yield something
            -- sensible, so I'm giving up for now.
            , stateSubs :: [Section]
stateSubs = State -> [Section]
stateSections State
sub
            }
            where
            -- I need a break to collect the last part of the long form
            -- sub-doc.  But I can only know the break once I see it, after
            -- this ShortForm.  So this break is temporary and will be replaced
            -- by 'replaceBreaks' below.  If you see a Hard 0 in the Sections
            -- you know this failed.
            sub :: State
sub = BreakType -> State -> State
addSection (Width -> BreakType
Hard Width
0) (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ Doc -> State -> State
go Doc
long State
subState
                where
                subState :: State
subState = State
initialState
                    -- This causes @a <> ShortForm b c@ to distribute the @a@
                    -- over @b@ and @c@, as documented by 'shortForm'.
                    { stateCollect :: B
stateCollect = State -> B
stateCollect State
state
                    , stateIndent :: Width
stateIndent = State -> Width
stateIndent State
state
                    , statePreviousIndent :: Width
statePreviousIndent = State -> Width
statePreviousIndent State
state
                    , stateBreakIndent :: Width
stateBreakIndent = State -> Width
stateBreakIndent State
state
                    }
        Indent Width
n -> State
state
            { stateIndent :: Width
stateIndent = State -> Width
stateIndent State
state Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
n
            , statePreviousIndent :: Width
statePreviousIndent = State -> Width
stateIndent State
state
            }
        Break BreakType
break -> BreakType -> State -> State
addSection BreakType
break State
state
    -- When I see a Break, I can create a Section for it.
    addSection :: BreakType -> State -> State
addSection BreakType
break State
state = State
state
        { stateCollect :: B
stateCollect = B
forall a. Monoid a => a
mempty
        , stateSubs :: [Section]
stateSubs = []
        , stateSections :: [Section]
stateSections = (Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: State -> [Section]
stateSections State
state) (Section -> [Section]) -> Section -> [Section]
forall a b. (a -> b) -> a -> b
$ Section
            { sectionStartIndent :: Width
sectionStartIndent = State -> Width
stateBreakIndent State
state
            , sectionEndIndent :: Width
sectionEndIndent = State -> Width
statePreviousIndent State
state
            , sectionB :: B
sectionB = State -> B
stateCollect State
state
            -- If there are subs, then they have been collected by the long
            -- part of a ShortForm.
            , sectionSubs :: [Section]
sectionSubs = [Section] -> [Section]
replaceBreaks ([Section] -> [Section]) -> [Section] -> [Section]
forall a b. (a -> b) -> a -> b
$ State -> [Section]
stateSubs State
state
            , sectionBreak :: BreakType
sectionBreak = BreakType
break
            }
        , stateBreakIndent :: Width
stateBreakIndent = State -> Width
stateIndent State
state
        , statePreviousIndent :: Width
statePreviousIndent = State -> Width
stateIndent State
state
        }
        where
        -- Recursively replace all the first breaks in the subs.  Since subs
        -- are collected in reverse, this replaces the final break, which was
        -- just a placeholder.
        replaceBreaks :: [Section] -> [Section]
replaceBreaks [] = []
        replaceBreaks (Section
sub:[Section]
subs) = Section
sub
            { sectionBreak :: BreakType
sectionBreak = BreakType
break
            , sectionSubs :: [Section]
sectionSubs = [Section] -> [Section]
replaceBreaks ([Section] -> [Section]) -> [Section] -> [Section]
forall a b. (a -> b) -> a -> b
$ Section -> [Section]
sectionSubs Section
sub
            } Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section]
subs

    -- If there is trailing text, break it with a Hard newline.  Otherwise,
    -- convert the last break to Hard.
    flush :: State -> State
flush State
state
        | Bool -> Bool
not (B -> Bool
bNull (State -> B
stateCollect State
state)) = BreakType -> State -> State
addSection (Width -> BreakType
Hard Width
1) State
state
        | Section
final : [Section]
sections <- State -> [Section]
stateSections State
state = State
state
            { stateSections :: [Section]
stateSections = Section
final { sectionBreak :: BreakType
sectionBreak = Width -> BreakType
Hard Width
1 } Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section]
sections }
        | Bool
otherwise = State
state

-- | Clean up 'stateSections' after 'flatten'.
postprocSections :: [Section] -> [Section]
postprocSections :: [Section] -> [Section]
postprocSections = (Section -> Section) -> [Section] -> [Section]
forall a b. (a -> b) -> [a] -> [b]
map Section -> Section
subs ([Section] -> [Section])
-> ([Section] -> [Section]) -> [Section] -> [Section]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Section] -> [Section]
mergeBreaks ([Section] -> [Section])
-> ([Section] -> [Section]) -> [Section] -> [Section]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Section] -> [Section]
forall a. [a] -> [a]
reverse
    -- TODO use dlist so I don't have to reverse, but benchmark first
    where
    -- sectionSubs are also reversed, and need their breaks merged.
    subs :: Section -> Section
subs Section
section
        | [Section] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Section -> [Section]
sectionSubs Section
section) = Section
section
        | Bool
otherwise = Section
section
            { sectionSubs :: [Section]
sectionSubs = [Section] -> [Section]
postprocSections ([Section] -> [Section]) -> [Section] -> [Section]
forall a b. (a -> b) -> a -> b
$ Section -> [Section]
sectionSubs Section
section }

-- | Collapse consecutive breaks into the strongest one.  Empty sections can
-- happen after dedents.  I don't want them, but I do want to get the break if
-- it's stronger.
mergeBreaks :: [Section] -> [Section]
mergeBreaks :: [Section] -> [Section]
mergeBreaks [] = []
mergeBreaks (Section
section : [Section]
sections) = case (Section -> Bool) -> [Section] -> ([Section], [Section])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Section -> Bool
empty [Section]
sections of
    ([], [Section]
_) -> Section
section Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section] -> [Section]
mergeBreaks [Section]
sections
    ([Section]
nulls, [Section]
rest) -> Section
section { sectionBreak :: BreakType
sectionBreak = BreakType
break } Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section] -> [Section]
mergeBreaks [Section]
rest
        where break :: BreakType
break = Section -> BreakType
sectionBreak Section
section BreakType -> BreakType -> BreakType
forall a. Semigroup a => a -> a -> a
<> [BreakType] -> BreakType
forall a. Monoid a => [a] -> a
mconcat ((Section -> BreakType) -> [Section] -> [BreakType]
forall a b. (a -> b) -> [a] -> [b]
map Section -> BreakType
sectionBreak [Section]
nulls)
    where empty :: Section -> Bool
empty Section
section = B -> Bool
bNull (Section -> B
sectionB Section
section)

-- | Render a Doc, wrapping after the given Width.
render :: Text -> Width -> Doc -> Lazy.Text
render :: Text -> Width -> Doc -> Text
render Text
indent Width
width = Text -> Width -> [Section] -> Text
renderText Text
indent Width
width ([Section] -> Text) -> (Doc -> [Section]) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Section]
flatten

-- | Render the Doc all on one line, with no newlines.
renderFlat :: Doc -> Lazy.Text
renderFlat :: Doc -> Text
renderFlat = [Section] -> Text
renderTextFlat ([Section] -> Text) -> (Doc -> [Section]) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Section]
flatten

-- | Take sections until they go over the width, or I see a hard newline, or
-- run out.  If they went over, then find a break in the collected, emit before
-- the break, and try again.
renderText :: Text -> Width -> [Section] -> Lazy.Text
renderText :: Text -> Width -> [Section] -> Text
renderText Text
indentS Width
maxWidth = Builder -> Text
Builder.toLazyText (Builder -> Text) -> ([Section] -> Builder) -> [Section] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Section] -> Builder -> Builder)
-> Builder -> [Section] -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Section] -> Builder -> Builder
renderLine Builder
forall a. Monoid a => a
mempty
    where
    renderLine :: [Section] -> Builder -> Builder
renderLine [] Builder
out = Builder
out
    renderLine (Section Width
indent Width
_ B
b [Section]
subs BreakType
_ : [Section]
sections) Builder
out
        -- break is ignored, because the last sub should have the same break.
        | Bool -> Bool
not ([Section] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Section]
subs) Bool -> Bool -> Bool
&& Width
indent Width -> Width -> Width
forall a. Num a => a -> a -> a
* Text -> Width
textWidth Text
indentS Width -> Width -> Width
forall a. Num a => a -> a -> a
+ B -> Width
bWidth B
b Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
maxWidth =
            [Section] -> Builder -> Builder
renderLine ([Section]
subs [Section] -> [Section] -> [Section]
forall a. [a] -> [a] -> [a]
++ [Section]
sections) Builder
out
    renderLine allSections :: [Section]
allSections@(Section
section1 : [Section]
_) Builder
out =
        Builder
out Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> case Width -> Width -> [Section] -> (Text, Bool, [Section], [Section])
spanLine (Text -> Width
textWidth Text
indentS) Width
maxWidth [Section]
allSections of
            (Text
_, Bool
_, [], []) -> Builder
forall a. Monoid a => a
mempty
            (Text
_, Bool
_, [], Section
section : [Section]
sections) ->
                [Section] -> Builder -> Builder
renderLine [Section]
sections (Builder -> Builder
emitLine (Section -> Builder
sectionBuilder Section
section))
            (Text
_, Bool
False, [Section]
line, [Section]
rest) ->
                [Section] -> Builder -> Builder
renderLine [Section]
rest (Builder -> Builder
emitLine ([Section] -> Builder
renderSections [Section]
line))
            (Text
_, Bool
True, [Section]
line, [Section]
rest) -> case [Section] -> ([Section], [Section])
findBreak [Section]
line of
                ([], []) -> Builder
forall a. Monoid a => a
mempty -- shouldn't be possible
                ([], Section
section : [Section]
sections) -> [Section] -> Builder -> Builder
renderLine ([Section]
sections [Section] -> [Section] -> [Section]
forall a. [a] -> [a] -> [a]
++ [Section]
rest)
                    (Builder -> Builder
emitLine (Section -> Builder
sectionBuilder Section
section))
                ([Section]
line, [Section]
rest2) ->
                    [Section] -> Builder -> Builder
renderLine ([Section]
rest2 [Section] -> [Section] -> [Section]
forall a. [a] -> [a] -> [a]
++ [Section]
rest) (Builder -> Builder
emitLine ([Section] -> Builder
renderSections [Section]
line))
        where
        indent :: Width
indent = Section -> Width
sectionStartIndent Section
section1
        emitLine :: Builder -> Builder
emitLine Builder
b = Builder
indentB Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl
            where
            indentB :: Builder
indentB = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Width -> Builder -> [Builder]
forall a. Width -> a -> [a]
replicate Width
indent Builder
indent1
            nl :: Builder
nl = Char -> Builder
Builder.singleton Char
'\n'
    indent1 :: Builder
indent1 = Text -> Builder
Builder.fromText Text
indentS

{- This is for debugging, but I don't want it in the real version, and I don't
know how to make the debugging part free when disabled.

data Output = Output {
    outputLogs :: ![Text]
    , outputText :: !Builder.Builder
    } deriving (Show)

instance Monoid Output where
    mempty = Output mempty mempty
    mappend (Output logs1 text1) (Output logs2 text2) =
        Output (logs1<>logs2) (text1<>text2)

renderLogged :: Text -> Width -> Doc -> (Lazy.Text, [Text])
renderLogged indent width doc = (Builder.toLazyText builder, logs)
    where Output logs builder = renderTextLogged indent width (flatten doc)

renderTextLogged :: Text -> Width -> [Section] -> Output
renderTextLogged indentS maxWidth = flip renderLine mempty
    where
    renderLine [] out = out
    renderLine (Section indent _ b subs _ : sections) out
        -- break is ignored, because the last sub should have the same break.
        | not (null subs) && indent * textWidth indentS + bWidth b > maxWidth =
            log ("short version " <> showt b <> " too wide: "
                    <> showt (indent * textWidth indentS) <> " + "
                    <> showt (bWidth b))
                <> renderLine (subs ++ sections) out
    renderLine allSections@(section1 : _) out =
        out <> case spanLine (textWidth indentS) maxWidth allSections of
            (_, _, [], []) -> mempty
            (msg, _, [], section : sections) -> log msg
                <> log ("single section doesn't fit, it gets its own line: "
                    <> showt section)
                <> renderLine sections (emitLine (sectionBuilder section))
            (msg, False, line, rest) -> log msg
                <> log ("hard break or dedent: "
                    <> showt (map eSection line)
                    <> " rest: " <> showt (map eSection rest))
                <> renderLine rest (emitLine (renderSections line))
            (msg, True, line, rest) -> log msg <> case findBreak line of
                ([], []) -> mempty -- shouldn't be possible
                ([], section : sections) ->
                    log ("break before lowest indent: "
                        <> showt (sectionBuilder section)
                        <> " " <> showt (map eSection line))
                    <> renderLine (sections ++ rest)
                        (emitLine (sectionBuilder section))
                (line, rest2) ->
                    log ("break on lowest indent: "
                        <> showt (renderSections line))
                    <> renderLine (rest2 ++ rest)
                        (emitLine (renderSections line))
        where
        indent = sectionStartIndent section1
        emitLine b = txt (indentB <> b <> nl)
            where
            indentB = mconcat $ replicate indent indent1
            nl = Builder.singleton '\n'
    indent1 = Builder.fromText indentS
    txt t = mempty { outputText = t }
    log t = mempty { outputLogs = [t] }
    eSection s = (sectionStartIndent s, sectionB s)
-}

renderTextFlat :: [Section] -> Lazy.Text
renderTextFlat :: [Section] -> Text
renderTextFlat = Builder -> Text
Builder.toLazyText (Builder -> Text) -> ([Section] -> Builder) -> [Section] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Section] -> Builder
renderSections

renderSectionsB :: [Section] -> B
renderSectionsB :: [Section] -> B
renderSectionsB [Section]
sections =
    [B] -> B
forall a. Monoid a => [a] -> a
mconcat ([B] -> B) -> [B] -> B
forall a b. (a -> b) -> a -> b
$ [B] -> [B] -> [B]
forall a. [a] -> [a] -> [a]
interleave ((Section -> B) -> [Section] -> [B]
forall a b. (a -> b) -> [a] -> [b]
map Section -> B
sectionB [Section]
sections) [B]
spaces
    where
    spaces :: [B]
spaces = (Section -> B) -> [Section] -> [B]
forall a b. (a -> b) -> [a] -> [b]
map (BreakType -> B
toSpace (BreakType -> B) -> (Section -> BreakType) -> Section -> B
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Section -> BreakType
sectionBreak) [Section]
sections
    toSpace :: BreakType -> B
toSpace BreakType
Space = Builder -> Width -> B
B (Char -> Builder
Builder.singleton Char
' ') Width
1
    toSpace BreakType
_ = Builder -> Width -> B
B Builder
forall a. Monoid a => a
mempty Width
0

renderSections :: [Section] -> Builder.Builder
renderSections :: [Section] -> Builder
renderSections = B -> Builder
bBuilder (B -> Builder) -> ([Section] -> B) -> [Section] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Section] -> B
renderSectionsB

-- | Collect a line's worth of Sections.
-- TODO 'findBreak' should probably be integrated into this.
spanLine :: Width -> Width -> [Section]
    -> (Text, Bool, [Section], [Section])
    -- ^ (log, break, pre_break, post_break).  If break is False, then pre_break
    -- can be emitted as-is.  If break is True, then the line went over the
    -- maxWidth and must be broken.  pre_break will then have one Section past
    -- the break point.  This is so 'findBreak' can know what the next indent
    -- break is, so it can know if it's ok to break there.
spanLine :: Width -> Width -> [Section] -> (Text, Bool, [Section], [Section])
spanLine Width
_ Width
_ [] = (Text
"out of sections", Bool
False, [], [])
spanLine Width
indentWidth Width
maxWidth sections :: [Section]
sections@(Section
section1 : [Section]
_) =
    Width -> [Section] -> (Text, Bool, [Section], [Section])
go (Width
indentWidth Width -> Width -> Width
forall a. Num a => a -> a -> a
* Width
indent) [Section]
sections
    where
    indent :: Width
indent = Section -> Width
sectionStartIndent Section
section1
    go :: Width -> [Section] -> (Text, Bool, [Section], [Section])
go Width
_ [] = (Text
"out of sections", Bool
False, [], [])
    go Width
col (Section
section : [Section]
sections)
        -- Break as soon as the indent goes below the initial indent.
        | Section -> Width
sectionStartIndent Section
section Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
indent =
            ( Text
"indent decreased: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Text
forall a. Show a => a -> Text
showt (Section -> Width
sectionStartIndent Section
section)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" < " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Text
forall a. Show a => a -> Text
showt Width
indent
            , Bool
False, [], Section
section Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section]
sections
            )
        | Width
col Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
width Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
maxWidth =
            ( Text
"too wide: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Text
forall a. Show a => a -> Text
showt Width
col Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" + "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Text
forall a. Show a => a -> Text
showt Width
width Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" > " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Text
forall a. Show a => a -> Text
showt Width
maxWidth
            , Bool
True, [Section
section], [Section]
sections
            )
        | Hard Width
n <- Section -> BreakType
sectionBreak Section
section, Width
n Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
0 =
            ( Text
"hard break"
            , Bool
False, [Section
section]
            , if Width
n Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
1 then BreakType -> Section -> Section
strip (Width -> BreakType
Hard (Width
nWidth -> Width -> Width
forall a. Num a => a -> a -> a
-Width
1)) Section
section Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section]
sections else [Section]
sections
            )
        | Bool
otherwise =
            let (Text
msg, Bool
break, [Section]
pre, [Section]
post) = Width -> [Section] -> (Text, Bool, [Section], [Section])
go (Width
col Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
space Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Width
width) [Section]
sections
            in (Text
msg, Bool
break, Section
section Section -> [Section] -> [Section]
forall a. a -> [a] -> [a]
: [Section]
pre, [Section]
post)
        where
        space :: Width
space = if Section -> BreakType
sectionBreak Section
section BreakType -> BreakType -> Bool
forall a. Eq a => a -> a -> Bool
== BreakType
Space then Width
1 else Width
0
        width :: Width
width = B -> Width
bWidth (Section -> B
sectionB Section
section)
    strip :: BreakType -> Section -> Section
strip BreakType
break Section
section = Section
        { sectionStartIndent :: Width
sectionStartIndent = Section -> Width
sectionStartIndent Section
section
        , sectionEndIndent :: Width
sectionEndIndent = Section -> Width
sectionEndIndent Section
section
        , sectionB :: B
sectionB = B
forall a. Monoid a => a
mempty
        , sectionSubs :: [Section]
sectionSubs = []
        , sectionBreak :: BreakType
sectionBreak = BreakType
break
        }

-- | Given a list of Sections that I know need to be broken, find the best
-- place to break.  Split before the last lowest indent.
findBreak :: [Section] -> ([Section], [Section])
findBreak :: [Section] -> ([Section], [Section])
findBreak [Section]
sections = case Maybe (Width, Width)
lowest of
    Maybe (Width, Width)
Nothing -> ([], [])
    Just (Width
i, Width
_) -> Width -> [Section] -> ([Section], [Section])
forall a. Width -> [a] -> ([a], [a])
splitAt Width
i [Section]
sections
    where lowest :: Maybe (Width, Width)
lowest = ((Width, Width) -> Width)
-> [(Width, Width)] -> Maybe (Width, Width)
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
lastMinimumOn (Width, Width) -> Width
forall a b. (a, b) -> b
snd ([(Width, Width)] -> Maybe (Width, Width))
-> [(Width, Width)] -> Maybe (Width, Width)
forall a b. (a -> b) -> a -> b
$ [Width] -> [Width] -> [(Width, Width)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Width
0..] ((Section -> Width) -> [Section] -> [Width]
forall a b. (a -> b) -> [a] -> [b]
map Section -> Width
sectionEndIndent [Section]
sections)

showt :: Show a => a -> Text
showt :: forall a. Show a => a -> Text
showt = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show


-- * B

-- | A 'Builder.Builder' that keeps track of its length.
data B = B {
    B -> Builder
bBuilder :: !Builder.Builder
    , B -> Width
bWidth :: !Width
    }

instance Show B where
    show :: B -> String
show (B Builder
b Width
_) = Builder -> String
forall a. Show a => a -> String
show Builder
b

instance Semigroup B where
    B Builder
b1 Width
len1 <> :: B -> B -> B
<> B Builder
b2 Width
len2 = Builder -> Width -> B
B (Builder
b1Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Builder
b2) (Width
len1Width -> Width -> Width
forall a. Num a => a -> a -> a
+Width
len2)

instance Monoid B where
    mempty :: B
mempty = Builder -> Width -> B
B Builder
forall a. Monoid a => a
mempty Width
0
    mappend :: B -> B -> B
mappend = B -> B -> B
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [B] -> B
mconcat [] = B
forall a. Monoid a => a
mempty
    mconcat [B]
bs = Builder -> Width -> B
B ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
builders) ([Width] -> Width
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Width]
lens)
        where ([Builder]
builders, [Width]
lens) = [(Builder, Width)] -> ([Builder], [Width])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Builder
b, Width
len) | B Builder
b Width
len <- [B]
bs, Width
len Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= Width
0]

bFromText :: Text -> B
bFromText :: Text -> B
bFromText Text
text = Builder -> Width -> B
B (Text -> Builder
Builder.fromText Text
text) (Text -> Width
textWidth Text
text)

-- | Number of columns this text should need in a monospace font.
textWidth :: Text -> Width
textWidth :: Text -> Width
textWidth = (Width -> Char -> Width) -> Width -> Text -> Width
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl' (\Width
n Char
c -> Width
n Width -> Width -> Width
forall a. Num a => a -> a -> a
+ Char -> Width
WCWidth.wcwidth Char
c) Width
0

bNull :: B -> Bool
bNull :: B -> Bool
bNull = (Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
==Width
0) (Width -> Bool) -> (B -> Width) -> B -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. B -> Width
bWidth

-- * debug

-- | Merge Texts so the Doc is easier to read.
simplify :: Doc -> Doc
simplify :: Doc -> Doc
simplify Doc
doc = case Doc
doc of
    Text Text
t1 :+ Doc
d1 -> case Doc -> Doc
simplify Doc
d1 of
        Text Text
t2 :+ Doc
d2 -> Text -> Doc
Text (Text
t1Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
t2) Doc -> Doc -> Doc
:+ Doc
d2
        Text Text
t2 -> Text -> Doc
Text (Text
t1Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
t2)
        Doc
doc -> Text -> Doc
Text Text
t1 Doc -> Doc -> Doc
:+ Doc
doc
    Doc
d1 :+ Doc
d2 -> case (Doc -> Doc
simplify Doc
d1, Doc -> Doc
simplify Doc
d2) of
        (Text Text
t1, Text Text
t2) -> Text -> Doc
Text (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2)
        (Doc
d1, Doc
d2) -> Doc
d1 Doc -> Doc -> Doc
:+ Doc
d2
    ShortForm Doc
d1 Doc
d2 ->
        Doc -> Doc -> Doc
ShortForm (Text -> Doc
Text (Text -> Text
Lazy.toStrict (Doc -> Text
renderFlat Doc
d1))) (Doc -> Doc
simplify Doc
d2)
    Doc
_ -> Doc
doc

-- | Reduce the Doc to a flattened easier to read version.
denest :: Doc -> Text
denest :: Doc -> Text
denest Doc
doc = case Doc
doc of
    Doc
d1 :+ Doc
d2 -> Doc -> Text
denest Doc
d1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc -> Text
denest Doc
d2
    Text Text
t -> Text -> Text
forall a. Show a => a -> Text
showt Text
t
    Indent Width
n -> if Width
n Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
0 then Text
"^" else Text
"v"
    Break BreakType
b -> case BreakType
b of
        BreakType
NoSpace -> Text
"/"
        BreakType
Space -> Text
"/+"
        Hard Width
_ -> Text
"//"
    ShortForm Doc
_ Doc
doc -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc -> Text
denest Doc
doc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"


-- * misc

-- | Find the *last* minimum element.
lastMinimumOn :: Ord k => (a -> k) -> [a] -> Maybe a
lastMinimumOn :: forall k a. Ord k => (a -> k) -> [a] -> Maybe a
lastMinimumOn a -> k
_ [] = Maybe a
forall a. Maybe a
Nothing
lastMinimumOn a -> k
key [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just ((a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
List.foldl1' a -> a -> a
f [a]
xs)
    where f :: a -> a -> a
f a
low a
x = if a -> k
key a
x k -> k -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> k
key a
low then a
x else a
low

-- | Interleave so there is a y between each x.
interleave :: [a] -> [a] -> [a]
interleave :: forall a. [a] -> [a] -> [a]
interleave [a
x] [a]
_ = [a
x]
interleave (a
x:[a]
xs) (a
y:[a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
xs [a]
ys
interleave [a]
xs [a]
_ = [a]
xs