diff --git a/dynamic-pp.cabal b/dynamic-pp.cabal --- a/dynamic-pp.cabal +++ b/dynamic-pp.cabal @@ -1,6 +1,6 @@ Name: dynamic-pp Category: Text -Version: 0.1.0 +Version: 0.2.0 License: BSD3 License-File: LICENSE Author: Eric McCorkle @@ -22,6 +22,8 @@ . This library also provides two simpler rendering engines for uses where the full optimal layout engine is not necessary. These engines are much simpler and consume fewer resources. + . + NOTE: This library is still in development. It may contain bugs, performance issues, and the interface may change. Build-type: Simple Cabal-version: >= 1.16 diff --git a/src/Text/Format.hs b/src/Text/Format.hs --- a/src/Text/Format.hs +++ b/src/Text/Format.hs @@ -53,6 +53,7 @@ empty, line, linebreak, + hardline, softline, softbreak, @@ -139,6 +140,7 @@ -- *** Derived (<>), (<+>), + (), (<$>), (<$$>), (), @@ -173,10 +175,12 @@ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 +import Control.Arrow((***)) import Control.Monad import Data.Hashable -import Data.HashMap.Strict(HashMap) -import Data.List(intersperse, minimumBy) +import Data.HashSet(HashSet) +--import Data.HashMap.Strict(HashMap) +import Data.List(intersperse, minimumBy, sort) import Data.Maybe import Data.Monoid hiding ((<>)) import Data.Word @@ -189,10 +193,20 @@ import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8 import qualified Data.ByteString.Lazy.UTF8 as Lazy.UTF8 -import qualified Data.HashMap.Strict as HashMap +--import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet -- | Datatype representing a formatted document. +data LineKind = + -- | Unerasable linebreak + Hard + -- | Linebreak replaced with nothing + | Soft + -- | Linebreak replaced with a space + | Break + deriving (Ord, Eq, Enum) + -- Docs are organized into a tree structure whose nodes dictate the -- formatting of the generated text. These are rendered by the -- various rendering engines into a Builder (from the blaze-builder @@ -202,16 +216,16 @@ Char { charContent :: !Char } -- | A raw Builder that constructs a string containing no -- newlines. This is used to represent basic text. - | Builder { + | Content { -- | Length of the text that gets built. - builderLength :: !Int, + contentLength :: !Int, -- | A Builder that constructs the text. - builderContent :: !Builder + contentString :: !Lazy.ByteString } - -- | A newline. + -- | An erasable newline. | Line { -- | Whether to insert a space when undone by a group. - insertSpace :: !Bool + lineKind :: !LineKind } -- | Concatenated documents. An empty list here represents an empty @Doc@. | Cat { @@ -232,7 +246,7 @@ -- | Choose the \"best\" from among a list of options. | Choose { -- | The list of options. - chooseOptions :: [Doc] + chooseOptions :: HashSet Doc } -- | Set graphics mode options when rendering the child @Doc@. | Graphics { @@ -241,6 +255,7 @@ -- | Document to render with graphic mode. graphicsDoc :: Doc } + deriving (Eq) -- | Graphics options for ANSI terminals. All options are wrapped in -- the 'Maybe' datatype, with 'Nothing' meaning \"leave this option @@ -264,7 +279,81 @@ } -- | Reset the terminal in this mode. | Default + deriving (Ord, Eq) +instance Ord Doc where + compare Char { charContent = c1 } Char { charContent = c2 } = compare c1 c2 + compare Char {} _ = LT + compare _ Char {} = GT + compare Content { contentString = str1 } Content { contentString = str2 } = + compare str1 str2 + compare Content {} _ = LT + compare _ Content {} = GT + compare Line { lineKind = kind1 } Line { lineKind = kind2 } = + compare kind1 kind2 + compare Line {} _ = LT + compare _ Line {} = GT + compare Cat { catDocs = docs1 } Cat { catDocs = docs2 } = compare docs1 docs2 + compare Cat {} _ = LT + compare _ Cat {} = GT + compare Nest { nestLevel = lvl1, nestAlign = al1, + nestDelay = delay1, nestDoc = doc1 } + Nest { nestLevel = lvl2, nestAlign = al2, + nestDelay = delay2, nestDoc = doc2 } = + case compare lvl1 lvl2 of + EQ -> case compare al1 al2 of + EQ -> case compare delay1 delay2 of + EQ -> compare doc1 doc2 + out -> out + out -> out + out -> out + compare Nest {} _ = LT + compare _ Nest {} = GT + compare Choose { chooseOptions = opts1 } Choose { chooseOptions = opts2 } = + compare (sort (HashSet.toList opts1)) (sort (HashSet.toList opts2)) + compare Choose {} _ = LT + compare _ Choose {} = GT + compare Graphics { graphicsSGR = sgr1, graphicsDoc = doc1 } + Graphics { graphicsSGR = sgr2, graphicsDoc = doc2 } = + case compare sgr1 sgr2 of + EQ -> compare doc1 doc2 + out -> out + +instance Hashable LineKind where + hashWithSalt s = hashWithSalt s . fromEnum + +instance Hashable Doc where + hashWithSalt s Char { charContent = c } = + s `hashWithSalt` (0 :: Int) `hashWithSalt` c + hashWithSalt s Content { contentLength = len, contentString = str } = + s `hashWithSalt` (1 :: Int) `hashWithSalt` len `hashWithSalt` str + hashWithSalt s Line { lineKind = kind } = + s `hashWithSalt` (2 :: Int) `hashWithSalt` kind + hashWithSalt s Cat { catDocs = docs } = + s `hashWithSalt` (3 :: Int) `hashWithSalt` docs + hashWithSalt s Nest { nestLevel = lvl, nestAlign = al, + nestDelay = delay, nestDoc = doc } = + s `hashWithSalt` (4 :: Int) `hashWithSalt` lvl `hashWithSalt` + al `hashWithSalt` delay `hashWithSalt` doc + hashWithSalt s Choose { chooseOptions = opts } = + s `hashWithSalt` (5 :: Int) `hashWithSalt` sort (HashSet.toList opts) + hashWithSalt s Graphics { graphicsSGR = sgr, graphicsDoc = doc } = + s `hashWithSalt` (6 :: Int) `hashWithSalt` sgr `hashWithSalt` doc + +instance Hashable Graphics where + hashWithSalt s Options { consoleIntensity = consIntensity, + swapForegroundBackground = swap, + underlining = underline, + foreground = fore, + background = back, + blinkSpeed = blink } = + s `hashWithSalt` (0 :: Int) `hashWithSalt` + fmap fromEnum consIntensity `hashWithSalt` + fmap fromEnum swap `hashWithSalt` fmap fromEnum underline `hashWithSalt` + fmap (fromEnum *** fromEnum) fore `hashWithSalt` + fmap (fromEnum *** fromEnum) back `hashWithSalt` fmap fromEnum blink + hashWithSalt s Default = s `hashWithSalt` (1 :: Int) + -- | Generate a 'Doc' representing a graphics mode switch. switchGraphics :: Graphics -> Graphics -> Builder switchGraphics _ Default = fromString (setSGRCode [Reset]) @@ -342,22 +431,26 @@ -- | A 'Doc' consisting of a linebreak, that is not turned into a -- space when erased by a 'group'. line :: Doc -line = Line { insertSpace = False } +line = Line { lineKind = Soft } -- | A 'Doc' consisting of a linebreak, that is turned into a space -- when erased by a 'group'. linebreak :: Doc -linebreak = Line { insertSpace = True } +linebreak = Line { lineKind = Break } +-- | A 'Doc' consisting of a linebreak that cannot be erased by a 'group'. +hardline :: Doc +hardline = Line { lineKind = Hard } + -- | A 'Doc' consisting of a space character, that can be turned into -- a linebreak in order to break lines that are too long. softline :: Doc -softline = Choose { chooseOptions = [ char ' ', linebreak ] } +softline = Choose { chooseOptions = HashSet.fromList [ char ' ', linebreak ] } -- | An empty 'Doc' that can be turned into a linebreak in order to -- break lines that are too long. softbreak :: Doc -softbreak = Choose { chooseOptions = [ empty, line ] } +softbreak = Choose { chooseOptions = HashSet.fromList [ empty, line ] } -- | A 'Doc' containing a single character. char :: Char -> Doc @@ -366,22 +459,22 @@ -- | Create a 'Doc' containing a string. string :: String -> Doc -string str = Builder { builderContent = fromString str, - builderLength = length str } +string str = Content { contentString = Lazy.UTF8.fromString str, + contentLength = length str } -- | Create a 'Doc' containing a bytestring. bytestring :: Strict.ByteString -> Doc bytestring txt | Strict.null txt = empty - | otherwise = Builder { builderLength = Strict.UTF8.length txt, - builderContent = fromByteString txt } + | otherwise = Content { contentLength = Strict.UTF8.length txt, + contentString = Lazy.fromStrict txt } -- | Create a 'Doc' containing a lazy bytestring lazyBytestring :: Lazy.ByteString -> Doc lazyBytestring txt | Lazy.null txt = empty - | otherwise = Builder { builderLength = Lazy.UTF8.length txt, - builderContent = fromLazyByteString txt } + | otherwise = Content { contentLength = Lazy.UTF8.length txt, + contentString = txt } -- | The character @(@ lparen :: Doc @@ -443,7 +536,7 @@ dot :: Doc dot = char '.' --- | The character @\@ +-- | The character @\\@ backslash :: Doc backslash = char '\\' @@ -798,6 +891,10 @@ (<+>) :: Doc -> Doc -> Doc left <+> right = left <> space <> right +-- | Join two 'Doc's with a 'hardline' in between them. +() :: Doc -> Doc -> Doc +left right = left <> hardline <> right + -- | Join two 'Doc's with a 'line' in between them. (<$>) :: Doc -> Doc -> Doc left <$> right = left <> line <> right @@ -832,7 +929,7 @@ choose :: [Doc] -> Doc choose [] = empty choose [doc] = doc -choose docs = Choose { chooseOptions = docs } +choose docs = Choose { chooseOptions = HashSet.fromList docs } -- | Concatenate a list of 'Doc's. This is generally more efficient -- than repeatedly using 'beside' or '<>'. @@ -856,11 +953,11 @@ -- | Join a list of 'Doc's using either 'hsep' or 'vsep'. sep :: [Doc] -> Doc -sep docs = Choose { chooseOptions = [hsep docs, vsep docs] } +sep docs = Choose { chooseOptions = HashSet.fromList [hsep docs, vsep docs] } -- | Join a list of 'Doc's using either 'hcat' or 'vcat'. cat :: [Doc] -> Doc -cat docs = Choose { chooseOptions = [hcat docs, vcat docs] } +cat docs = Choose { chooseOptions = HashSet.fromList [hcat docs, vcat docs] } -- | Join a list of 'Doc's with 'softline's in between each. This is -- generally more efficient than repeatedly using ''. @@ -897,30 +994,42 @@ -- | Erase all linebreaks in a 'Doc' and replace them with either -- spaces or nothing, depending on the kind of linebreak. -flatten :: Doc -> Doc -flatten Line { insertSpace = True } = Char { charContent = ' ' } -flatten Line { insertSpace = False } = empty -flatten Cat { catDocs = docs } = Cat { catDocs = map flatten docs } +flatten :: Doc -> Maybe Doc +flatten Line { lineKind = Hard } = Nothing +flatten Line { lineKind = Break } = Just Char { charContent = ' ' } +flatten Line { lineKind = Soft } = Just empty +flatten Cat { catDocs = docs } = + case mapMaybe flatten docs of + [] -> Nothing + flatinner -> Just Cat { catDocs = flatinner } flatten Choose { chooseOptions = docs } = - Choose { chooseOptions = map flatten docs } -flatten n @ Nest { nestDoc = inner } = n { nestDoc = flatten inner } -flatten doc = doc + case mapMaybe flatten (HashSet.toList docs) of + [] -> Nothing + flatdocs -> Just Choose { chooseOptions = HashSet.fromList flatdocs } +flatten n @ Nest { nestDoc = inner } = + do + flatinner <- flatten inner + return n { nestDoc = flatinner } +flatten doc = Just doc -- | A 'Doc' that 'choose's between the unmodified argument, or the -- 'flatten'ed version of the argument. group :: Doc -> Doc -group doc = Choose { chooseOptions = [ doc, flatten doc ] } +group doc = case flatten doc of + Just flatdoc -> Choose { chooseOptions = HashSet.fromList [ doc, flatdoc ] } + Nothing -> doc -- | Produce a 'Builder' that renders the 'Doc' to one line. buildOneLine :: Doc -> Builder buildOneLine Char { charContent = chr } = fromChar chr -buildOneLine Builder { builderContent = builder } = builder -buildOneLine Line { insertSpace = True } = fromChar ' ' -buildOneLine Line { insertSpace = False } = mempty +buildOneLine Content { contentString = builder } = fromLazyByteString builder +buildOneLine Line { lineKind = Break } = fromChar ' ' +buildOneLine Line { lineKind = Soft } = mempty +buildOneLine Line { lineKind = Hard } = fromChar '\n' buildOneLine Cat { catDocs = docs } = mconcat (map buildOneLine docs) buildOneLine Nest { nestDoc = inner } = buildOneLine inner -buildOneLine Choose { chooseOptions = first : _ } = buildOneLine first -buildOneLine Choose {} = error "Choose with no options" +buildOneLine Choose { chooseOptions = opts } = + buildOneLine (head (HashSet.toList opts)) buildOneLine Graphics { graphicsDoc = inner } = buildOneLine inner -- | Render the entire 'Doc' to one line. Good for output that @@ -937,12 +1046,12 @@ -- | Produce a 'Builder' that renders the 'Doc' quickly. buildFast :: Doc -> Builder buildFast Char { charContent = chr } = fromChar chr -buildFast Builder { builderContent = builder } = builder +buildFast Content { contentString = builder } = fromLazyByteString builder buildFast Line {} = fromChar '\n' buildFast Cat { catDocs = docs } = mconcat (map buildFast docs) buildFast Nest { nestDoc = inner } = buildFast inner -buildFast Choose { chooseOptions = first : _ } = buildFast first -buildFast Choose {} = error "Choose with no options" +buildFast Choose { chooseOptions = opts } = + buildFast (head (HashSet.toList opts)) buildFast Graphics { graphicsDoc = inner } = buildFast inner -- | Render the entire 'Doc', preserving newlines, but without any @@ -957,24 +1066,6 @@ putFast handle = toByteStringIO (Strict.hPut handle) . buildFast --- | A rendering of a document. - --- Renderings store three basic things: A notion of the "badness" of --- this particular rendering (represented by the overrun and the --- number of lines), the indentation mode for the next document, and a --- function that actually produces the Builder. -data Render = - Render { - -- | The number of lines in the document. - renderLines :: !Word, - -- | The largest amount by which we've overrun. - renderOverrun :: !Column, - -- | A builder that constructs the document. - renderBuilder :: !(Int -> Int -> Builder), - -- | Indentation mode for the next document. - renderIndent :: !Indent - } - -- | Column data type. Represents how rendered documents affect the -- current column. @@ -1094,26 +1185,65 @@ Maximum { maxFixed = fixed2, maxRelative = rel2 } = Maximum { maxFixed = max fixed2 (fixed1 + rel2), maxRelative = rel1 + rel2 } --- | Offsets structure. this is used as a key in a hash table. It is --- also important to how the algorithm works. Renderings represent --- "chunks", which have an ending column and a maximum column. The --- algorithm glues these chunks together, then evaluates their --- "badness" using the 'advance' function to recalculate the ending --- column and the maximum starting offset. -data Offsets = - Offsets { +-- | A rendering of a document. +-- Renderings store three basic things: A notion of the "badness" of +-- this particular rendering (represented by the overrun and the +-- number of lines), the indentation mode for the next document, and a +-- function that actually produces the Builder. +data Render = + Render { -- | Upper-bound: Highest starting column for this document -- without causing overrun. If this is negative, it means you've -- overrun by that much. - offsetUpper :: !Int, + renderUpper :: !Int, -- | Ending column. - offsetCol :: !Column + renderCol :: !Column, + -- | The number of lines in the document. + renderLines :: !Word, + -- | The largest amount by which we've overrun. + renderOverrun :: !Column, + -- | A builder that constructs the document. + renderBuilder :: !(Int -> Int -> Builder), + -- | Indentation mode for the next document. + renderIndent :: !Indent } - deriving Eq -instance Hashable Offsets where - hashWithSalt s Offsets { offsetUpper = upper, offsetCol = col } = - s `hashWithSalt` upper `hashWithSalt` col +-- | Determine whether the first 'Render' is strictly better than the second. +subsumes :: Render -> Render -> Bool +-- Simple comparisons: if the upper bound is greater, the lines are +-- less, and the column is less, then the render is always better. +subsumes Render { renderUpper = upper1, renderLines = lines1, + renderCol = Fixed { fixedOffset = col1 } } + Render { renderUpper = upper2, renderLines = lines2, + renderCol = Fixed { fixedOffset = col2 } } = + upper1 >= upper2 && lines1 <= lines2 && col1 <= col2 +subsumes Render { renderUpper = upper1, renderLines = lines1, + renderCol = Relative { relOffset = col1 } } + Render { renderUpper = upper2, renderLines = lines2, + renderCol = Relative { relOffset = col2 } } = + upper1 >= upper2 && lines1 <= lines2 && col1 <= col2 +-- A fixed column offset can subsume a relative offset +subsumes Render { renderUpper = upper1, renderLines = lines1, + renderCol = Fixed { fixedOffset = col1 } } + Render { renderUpper = upper2, renderLines = lines2, + renderCol = Relative { relOffset = col2 } } = + upper1 >= upper2 && lines1 <= lines2 && col1 <= col2 +-- For two maximums, it's a straightaway comparison +subsumes Render { renderUpper = upper1, renderLines = lines1, + renderCol = Maximum { maxRelative = rel1, + maxFixed = fixed1 } } + Render { renderUpper = upper2, renderLines = lines2, + renderCol = Maximum { maxRelative = rel2, + maxFixed = fixed2 } } = + upper1 >= upper2 && lines1 <= lines2 && rel1 <= rel2 && fixed1 <= fixed2 +-- Fixed can subsume a maximum as above +subsumes Render { renderUpper = upper1, renderLines = lines1, + renderCol = Fixed { fixedOffset = col1 } } + Render { renderUpper = upper2, renderLines = lines2, + renderCol = Maximum { maxRelative = rel2, + maxFixed = fixed2 } } = + upper1 >= upper2 && lines1 <= lines2 && col1 <= rel2 && col1 <= fixed2 +subsumes _ _ = False -- | A result. This is split into 'Single' and 'Multi' in order to -- optimize for the common case of a single possible rendering. @@ -1123,12 +1253,7 @@ -- | A single possible rendering. Single { -- | The rendered document. - singleRender :: !Render, - -- | The first column at which this render causes an overrun. - -- Same as 'offsetUpper'. - singleUpper :: !Int, - -- | The current column at the end of rendering. - singleCol :: !Column + singleRender :: !Render } -- | Multiple possible renderings. | Multi { @@ -1136,44 +1261,37 @@ -- upper-bound (meaning the first column at which using any of -- the contents will cause an overrun). The second map is -- indexed by the ending column. - multiOptions :: !(HashMap Offsets Render) + multiOptions :: ![Render] } -- | Generate n spaces makespaces :: Int -> Builder makespaces n = fromLazyByteString (Lazy.Char8.replicate (fromIntegral n) ' ') --- | Pick the best rendering of two. -bestRender :: Render -> Render -> Render -bestRender r1 @ Render { renderLines = lines1, renderOverrun = overrun1 } - r2 @ Render { renderLines = lines2, renderOverrun = overrun2 } - -- If one overruns less than the other, pick that one. - | overrun1 < overrun2 = r1 - | overrun1 > overrun2 = r2 - -- Otherwise, pick the shortest one. - | otherwise = if lines1 < lines2 then r1 else r2 - --- Add a result into the HashMap -insertRender :: Int -> Column -> Render -> HashMap Offsets Render -> - HashMap Offsets Render -insertRender upper col render = - let - offsets = Offsets { offsetUpper = upper, offsetCol = col } - in - HashMap.insertWith bestRender offsets render +-- Add a 'Render' into a result set, ensuring that any subsumed +-- renders are dropped. +-- +-- TODO: The asymptotic runtime of this could likely be improved by some +-- kind of tree structure; however, the design of this structure is +-- nontrivial, due to the 3+-dimensional nature of subsumption, and +-- the wierd interactions between the various kinds of column offsets. +insertRender :: [Render] -> Render -> [Render] +insertRender renders ins + -- If the inserted element is subsumed by anything in the + -- list, then don't insert it at all. + | any (`subsumes` ins) renders = renders + -- Otherwise, add the element to the list, and drop everything it subsumes. + | otherwise = ins : filter (not . subsumes ins) renders -- If a result only has one possibility, convert it to a Single. -- Otherwise, leave it. -packResult :: HashMap Offsets Render -> Result -packResult opts = - case HashMap.toList opts of - [(Offsets { offsetUpper = upper, offsetCol = col }, render)] -> - Single { singleCol = col, singleUpper = upper, singleRender = render } - _ -> Multi { multiOptions = opts } +packResult :: [Render] -> Result +packResult [opt] = Single { singleRender = opt } +packResult opts = Multi { multiOptions = opts } -- Pick the best result out of a set of results. Used at the end to -- pick the final result. -bestRenderInOpts :: HashMap Offsets Render -> Render +bestRenderInOpts :: [Render] -> Render bestRenderInOpts = let -- | Compare two Renders. Less than means better. @@ -1184,21 +1302,18 @@ EQ -> compare lines1 lines2 out -> out in - minimumBy compareRenders . HashMap.elems + minimumBy compareRenders -- | Append operation on complete states. A complete state is the -- contents of an Offset and a Render (ie. the contents of Single, or -- the contents of an entry in a Multi combined with the corresponding -- key). -appendOne :: (Int, Column, Render) -> (Int, Column, Render) -> - (Int, Column, Render) -appendOne (upper1, col1, Render { renderBuilder = build1, - renderLines = lines1, - renderOverrun = overrun1 }) - (upper2, col2, Render { renderBuilder = build2, - renderLines = lines2, - renderOverrun = overrun2, - renderIndent = ind }) = +appendOne :: Render -> Render -> Render +appendOne Render { renderUpper = upper1, renderLines = lines1, renderCol = col1, + renderOverrun = overrun1, renderBuilder = build1 } + Render { renderUpper = upper2, renderLines = lines2, renderCol = col2, + renderOverrun = overrun2, renderBuilder = build2, + renderIndent = ind } = let -- The new build is completely determined by the first render's -- starting column. @@ -1243,13 +1358,13 @@ else Fixed { fixedOffset = 0 } in - -- For the new column, use advance - (newupper, col1 `advance` col2, - Render { renderBuilder = newbuild, renderIndent = ind, - -- For the new overrun, take the max of the existing - -- overruns and newoverrun - renderOverrun = max (max overrun1 overrun2) newoverrun, - renderLines = lines1 + lines2 }) + Render { renderBuilder = newbuild, renderIndent = ind, + renderLines = lines1 + lines2, renderUpper = newupper, + -- For the new overrun, take the max of the existing + -- overruns and newoverrun + renderOverrun = max (max overrun1 overrun2) newoverrun, + -- For the new column, use advance + renderCol = col1 `advance` col2 } -- | Combine two results into a Multi. This achieves the same result -- as HashMap.unionWith bestRender (meaning, union these maps, @@ -1257,46 +1372,19 @@ -- index), but handles Singles as well. mergeResults :: Result -> Result -> Result -- Single is equivalent to a single-entry HashMap -mergeResults s1 @ Single { singleRender = - r1 @ Render { renderOverrun = overrun1, - renderLines = lines1 }, - singleUpper = upper1, singleCol = col1 } - s2 @ Single { singleRender = - r2 @ Render { renderOverrun = overrun2, - renderLines = lines2 }, - singleUpper = upper2, singleCol = col2 } - -- If the keys would collide - | upper1 == upper2 && col1 == col2 = - -- Duplicate the functionality of bestRender - if overrun1 < overrun2 - then s1 - else if overrun1 > overrun2 - then s2 - else if lines1 < lines2 - then s1 - else s2 - -- Otherwise, create a Multi - | otherwise = - Multi { multiOptions = - HashMap.fromList [(Offsets { offsetUpper = upper1, - offsetCol = col1 }, - r1), - (Offsets { offsetUpper = upper2, - offsetCol = col2 }, - r2)] } -mergeResults Single { singleRender = render, singleUpper = upper, - singleCol = col } +mergeResults s1 @ Single { singleRender = r1 } + s2 @ Single { singleRender = r2 } + | subsumes r1 r2 = s1 + | subsumes r2 r1 = s2 + | otherwise = Multi { multiOptions = [r1, r2] } +mergeResults Single { singleRender = render } Multi { multiOptions = opts } = - -- Do an insertWith bestRender - let - offsets = Offsets { offsetUpper = upper, offsetCol = col } - in - Multi { multiOptions = HashMap.insertWith bestRender offsets render opts } + packResult (insertRender opts render) -- This operation is commutative mergeResults m @ Multi {} s @ Single {} = mergeResults s m -- Otherwise it's a straightaway HashMap union mergeResults Multi { multiOptions = opts1 } Multi { multiOptions = opts2 } = - Multi { multiOptions = HashMap.unionWith bestRender opts1 opts2 } + packResult (foldl insertRender opts1 opts2) -- Add indentation on to a builder. Note, this is used to create the -- builder functions used in Render. @@ -1349,25 +1437,22 @@ -- Single characters have a single possibility, a relative -- ending position one beyond the start, and an upper-bound -- one shorter than the maximum width. - Single { - singleRender = - Render { renderLines = 0, renderOverrun = overrun, - renderBuilder = builder, renderIndent = None }, - singleCol = Relative 1, singleUpper = maxcol - 1 - } - buildDynamic _ _ ind Builder { builderContent = txt, builderLength = len } = + Single { singleRender = + Render { renderOverrun = overrun, renderIndent = None, + renderBuilder = builder, renderCol = Relative 1, + renderLines = 0, renderUpper = maxcol - 1 } } + buildDynamic _ _ ind Content { contentString = txt, contentLength = len } = let -- Why would you have maxcol == 0? Who knows, but check for it. overrun = if maxcol >= len then Relative 0 else Relative (len - maxcol) - builder = contentBuilder ind txt + builder = contentBuilder ind (fromLazyByteString txt) in -- Text has a single possibility and a relative ending position -- equal to its length - Single { - singleRender = Render { renderLines = 0, renderOverrun = overrun, - renderBuilder = builder, renderIndent = None }, - singleCol = Relative len, singleUpper = maxcol - len - } + Single { singleRender = + Render { renderLines = 0, renderUpper = maxcol - len, + renderBuilder = builder, renderCol = Relative len, + renderIndent = None, renderOverrun = overrun } } buildDynamic _ nesting _ Line {} = -- A newline starts at the nesting level, has no overrun, and an -- upper-bound equal to the maximum column width. @@ -1377,100 +1462,71 @@ singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 }, renderIndent = Full, renderLines = 1, renderBuilder = const $! const $! - fromChar '\n' }, - singleCol = nesting, singleUpper = maxcol - } + fromChar '\n', + renderCol = nesting, renderUpper = maxcol } } -- This is for an empty cat, ie. the empty document buildDynamic _ _ ind Cat { catDocs = [] } = -- The empty document has no content, no overrun, a relative end -- position of 0, and an upper-bound of maxcol. Single { - singleRender = Render { renderOverrun = Fixed { fixedOffset = 0 }, - renderIndent = ind, renderLines = 0, - renderBuilder = const mempty }, - singleCol = Relative { relOffset = 0 }, singleUpper = maxcol - } + singleRender = Render { renderOverrun = Fixed 0, renderIndent = ind, + renderLines = 0, renderBuilder = const mempty, + renderCol = Relative 0, renderUpper = maxcol } } buildDynamic sgr nesting ind Cat { catDocs = first : rest } = let -- Glue two Results together. This gets used in a fold. appendResults :: Result -> Doc -> Result -- The accumulated result is a Single. appendResults Single { singleRender = - render1 @ Render { renderIndent = ind' }, - singleUpper = upper1, singleCol = col1 } doc' = + render1 @ Render { renderIndent = ind' } } + doc' = -- Render the document. case buildDynamic sgr nesting ind' doc' of -- If there's a single result, it's easy; just use appendOne. - Single { singleUpper = upper2, singleCol = col2, - singleRender = render2 } -> + Single { singleRender = render2 } -> let - (newupper, newcol, newrender) = - appendOne (upper1, col1, render1) (upper2, col2, render2) + newrender = appendOne render1 render2 in - Single { singleUpper = newupper, singleCol = newcol, - singleRender = newrender } + Single { singleRender = newrender } -- Otherwise, we have to fold over all the options and -- glue on the accumulated result. Multi { multiOptions = opts } -> let -- Level 2 fold function: glue the accumulated result -- on to an option. - foldfun :: HashMap Offsets Render -> Offsets -> Render -> - HashMap Offsets Render - foldfun accum Offsets { offsetUpper = upper2, - offsetCol = col2 } render2 = - let - (newupper, newcol, newrender) = - appendOne (upper1, col1, render1) (upper2, col2, render2) - in - insertRender newupper newcol newrender accum + foldfun :: [Render] -> Render -> [Render] + foldfun accum = insertRender accum . appendOne render1 in -- Fold it up, then use packResult. - packResult (HashMap.foldlWithKey' foldfun HashMap.empty opts) + packResult (foldl foldfun [] opts) -- If the accumulate result is a multi, then we'll need to -- glue the next render on to each option. appendResults Multi { multiOptions = opts } doc' = let -- Outer fold, over each option in the accumulated result, -- gluing on the next render. - outerfold :: HashMap Offsets Render -> Offsets -> Render -> - HashMap Offsets Render - outerfold accum Offsets { offsetUpper = upper1, - offsetCol = col1 } - render1 @ Render { renderIndent = ind' } = + outerfold :: [Render] -> Render -> [Render] + outerfold accum render1 @ Render { renderIndent = ind' } = case buildDynamic sgr nesting ind' doc' of -- If the render is a single result, then just glue it -- on to the current option. - Single { singleUpper = upper2, singleCol = col2, - singleRender = render2 } -> - let - (newupper, newcol, newrender) = - appendOne (upper1, col1, render1) (upper2, col2, render2) - in - insertRender newupper newcol newrender accum + Single { singleRender = render2 } -> + insertRender accum (appendOne render1 render2) -- If the render result is ALSO a Multi, then we need -- to do another level of fold to glue those options -- on to the current one. Multi { multiOptions = opts2 } -> let -- Innermost fold, glues two options together - innerfold :: HashMap Offsets Render -> Offsets -> Render -> - HashMap Offsets Render - innerfold accum' Offsets { offsetUpper = upper2, - offsetCol = col2 } render2 = - let - (newupper, newcol, newrender) = - appendOne (upper1, col1, render1) - (upper2, col2, render2) - in - insertRender newupper newcol newrender accum' + innerfold :: [Render] -> Render -> [Render] + innerfold accum' = insertRender accum' . appendOne render1 in -- Don't bother calling packResult here, we'll do -- it at the end anyway. - HashMap.foldlWithKey' innerfold accum opts2 + foldl innerfold accum opts2 in -- Fold it up, then use packResult. - packResult (HashMap.foldlWithKey' outerfold HashMap.empty opts) + packResult (foldl outerfold [] opts) -- Build the first item firstres = buildDynamic sgr nesting ind first @@ -1519,11 +1575,11 @@ s @ Single { singleRender = r } -> s { singleRender = updateRender r } -- Update all renders for a Multi. m @ Multi { multiOptions = opts } -> - m { multiOptions = HashMap.map updateRender opts } + m { multiOptions = map updateRender opts } buildDynamic sgr nesting ind Choose { chooseOptions = options } = let -- Build up all the components - results = map (buildDynamic sgr nesting ind) options + results = map (buildDynamic sgr nesting ind) (HashSet.toList options) in -- Now merge them into an minimal set of options foldl1 mergeResults results @@ -1542,7 +1598,7 @@ s @ Single { singleRender = render } -> s { singleRender = wrapBuilder render } m @ Multi { multiOptions = opts } -> - m { multiOptions = HashMap.map wrapBuilder opts } + m { multiOptions = map wrapBuilder opts } -- Otherwise, skip it entirely | otherwise = buildDynamic sgr2 nesting ind inner