diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,35 @@
+# Revision history for lipstick
+
+## [0.1.0.0] - 2026-11-09
+
+First version: a port of lipgloss v2.
+
+* Styles as optparse-applicative-style modifiers (`Mod`): text attributes,
+ padding and margins (with fill characters), borders (presets, per-side
+ colours, gradients), width and height, alignment, wrapping or truncation,
+ inline rendering, tab width, `transform`, unset modifiers and getters.
+ Text attributes work on every kind of thing, and `maxWidth`/`maxHeight`
+ on every kind but `Inline` text.
+* Blocks: rendering to a structured block of styled spans, joining, placing,
+ framing and measuring; ANSI only on output.
+* Inline text with nested styles, `fromAnsi` for text with escape sequences,
+ `breakAfter` for extra break characters, `styleRanges` and `styleIndices`.
+* Blocks are laid out in the width they are given: text wraps to fit,
+ `fillWidth` / `grow` share out spare columns, `stretchHeight` matches the
+ height of a row, and the `RenderEnv` carries the output's width.
+* Unicode 16.0.0 grapheme clusters (UAX #29) and East Asian Width, from
+ tables generated by `scripts/GenUnicodeTable.hs`.
+* Tables: cells are blocks; header, column and row rules, cell styles by
+ position, fitting a width, height with scrolling, truncation.
+* Text settings (alignment, wrapping, break characters, tab width,
+ transform, inline) are inherited by the text inside a framed block.
+* Lists and trees (`Outline`): enumerators, indenters, item, enumerator and
+ indenter styles, width, item offsets.
+* Layers: offsets, z-order, `transparent` layers, sublayers, hit testing.
+* `Lipstick.Grid`: the laid-out lines, cells and styled spans of a block,
+ for other outputs.
+* Colours: hex and palette literals, light/dark and per-profile colours,
+ downsampling, `blend`, `blend2D`, `darken`, `lighten`, `complementary`.
+* Output: colour profile detection (`NO_COLOR`, `CLICOLOR_FORCE`,
+ `COLORTERM`, `TERM`), ANSI processing on Windows, background detection
+ from `COLORFGBG` or by asking the terminal, hyperlinks.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2026 Andrea Bedini
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/LICENSE.Unicode b/LICENSE.Unicode
new file mode 100644
--- /dev/null
+++ b/LICENSE.Unicode
@@ -0,0 +1,49 @@
+The following files are derived from Unicode data and are covered by the
+licence below, not by the MIT licence in LICENSE:
+
+- internal/Lipstick/Internal/UnicodeTable.hs, generated from the Unicode
+ Character Database by scripts/GenUnicodeTable.hs;
+- test/data/GraphemeBreakTest.txt, from the Unicode Character Database
+ (auxiliary/GraphemeBreakTest.txt).
+
+--------------------------------------------------------------------------
+
+UNICODE LICENSE V3
+
+COPYRIGHT AND PERMISSION NOTICE
+
+Copyright © 1991-2026 Unicode, Inc.
+
+NOTICE TO USER: Carefully read the following legal agreement. BY
+DOWNLOADING, INSTALLING, COPYING OR OTHERWISE USING DATA FILES, AND/OR
+SOFTWARE, YOU UNEQUIVOCALLY ACCEPT, AND AGREE TO BE BOUND BY, ALL OF THE
+TERMS AND CONDITIONS OF THIS AGREEMENT. IF YOU DO NOT AGREE, DO NOT
+DOWNLOAD, INSTALL, COPY, DISTRIBUTE OR USE THE DATA FILES OR SOFTWARE.
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of data files and any associated documentation (the "Data Files") or
+software and any associated documentation (the "Software") to deal in the
+Data Files or Software without restriction, including without limitation
+the rights to use, copy, modify, merge, publish, distribute, and/or sell
+copies of the Data Files or Software, and to permit persons to whom the
+Data Files or Software are furnished to do so, provided that either (a)
+this copyright and permission notice appear with all copies of the Data
+Files or Software, or (b) this copyright and permission notice appear in
+associated Documentation.
+
+THE DATA FILES AND SOFTWARE ARE PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
+KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF
+THIRD PARTY RIGHTS.
+
+IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS NOTICE
+BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL DAMAGES,
+OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THE DATA
+FILES OR SOFTWARE.
+
+Except as contained in this notice, the name of a copyright holder shall
+not be used in advertising or otherwise to promote the sale, use or other
+dealings in these Data Files or Software without prior written
+authorization of the copyright holder.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,363 @@
+# lipstick
+
+Style definitions for nice terminal layouts, in Haskell. lipstick is a port
+of [lipgloss](https://github.com/charmbracelet/lipgloss) (v2) for
+command-line programs: colours, borders, padding, alignment, tables, lists,
+trees and layered compositions, rendered to text with ANSI escape sequences.
+
+```haskell
+{-# LANGUAGE OverloadedStrings #-}
+import Lipstick
+
+card :: Mod Style
+card =
+ bold
+ <> fg "#FAFAFA"
+ <> bg "#7D56F4"
+ <> padding 1 4
+ <> width 24
+ <> border roundedBorder
+ <> borderFg "#874BFD"
+
+main :: IO ()
+main = putBlock (render card "Hello, kitty")
+```
+
+
+
+lipstick is on Hackage and builds with GHC 9.10, 9.12 and 9.14. Add it to
+the `build-depends` of your package:
+
+```
+build-depends: lipstick ^>=0.1
+```
+
+For brick and vty applications, add
+[`lipstick-brick`](https://hackage.haskell.org/package/lipstick-brick) too.
+
+The examples import `Lipstick` whole and use `OverloadedStrings`; the table
+example also uses `LambdaCase` (part of GHC2024), the layers example
+`import Data.Text qualified as T`, and the output example
+`import System.IO (stdout)`. Some of lipstick's names (`bold`, `fg`,
+`border`, `center`, `text`, `render`, `width`, the colour names) are also
+exported by brick, vty, colour or prettyprinter; programs that use those
+too can `import Lipstick qualified as L`.
+
+## Styles are modifiers
+
+A `Mod Style` is a modifier, in the same sense as optparse-applicative's
+`Mod`: modifiers form a monoid and later settings win, so styles are built
+and extended with `<>`.
+
+```haskell
+warning :: Mod Style
+warning = card <> bg "#F25D94"
+```
+
+Text attributes (`fg`, `bg`, `bold`, `underline`, `link`, …) apply to
+every kind of thing lipstick draws, not just styles, so the same modifier
+works everywhere:
+
+```haskell
+base :: Mod f
+base = fg red <> bold
+
+render base "text" -- a styled box
+table base headers rows -- the base style of a table
+list base items -- the base style of a list
+```
+
+Other modifiers apply to the things that have the corresponding part:
+`padding` and `margin` to styles, `border` to styles and tables, `width` to
+styles, tables, lists, trees and placed blocks, `align` to styles and placed
+blocks, and the `maxWidth` / `maxHeight` crop to everything but `styled`
+text. A modifier on something that does not support it is a type error.
+
+The sizes mean the same for everything that has them. With `width n`, a
+thing is `n` columns wide when there is room, and with less it shrinks like
+any other. `height n` is the least number of lines. For a style, `width`
+and `height` include padding and border but not margins, as in lipgloss.
+`maxWidth` and `maxHeight` crop the whole result, a style's margins
+included, to at most that many columns or lines; with `maxHeight`, a table
+leaves out body rows instead. With a width, text is word-wrapped to fit, or
+cut with an ellipsis with `noWrap`.
+
+## Blocks and layout
+
+`render` returns a `Block`: a rectangle of styled text, which gets its width
+only when it is laid out.
+
+```haskell
+joinHorizontal center
+ [ render card "Hello, kitty"
+ , render (warning <> marginLeft 2) "Later settings win"
+ ]
+```
+
+
+
+```haskell
+place
+ (width 30 <> height 3 <> align center <> valign center <> whitespaceChars "·" <> fg "#383838")
+ (render (bold <> fg "#F25D94") "centred")
+```
+
+
+
+`frame` puts an existing block in a box: `render style text` is
+`frame style (fromInline text)`. A style's text settings (`align`,
+`noWrap`, `breakAfter`, `tabWidth`, `transform`, `inline`) apply, like its
+colours, to all the text inside what it frames, unless something nearer
+sets them again. `hcat` / `joinHorizontal` put blocks side by side and
+`vcat` / `joinVertical` stack them.
+
+Text in a block wraps to the width the block is laid out in. `fillWidth`
+(or `grow n`, for a weighted share) makes a block take the spare columns of
+its row, and `stretchHeight` makes it as tall as the tallest block next to
+it. The output functions lay blocks out in the `RenderEnv`'s width (with
+`Nothing`, at their natural width); `layout` does it explicitly.
+
+## Text
+
+Text with several styles is `Inline`, built with `styled` and `<>`. Styles
+nest: the attributes of the enclosing style show through wherever the inner
+ones do not set them.
+
+```haskell
+render
+ (width 30 <> border normalBorder <> borderFg "#874BFD" <> padding 0 1)
+ (styled (bold <> fg "#F25D94") "Error: " <> "the file " <> styled italic "notes.txt" <> " was not found")
+```
+
+
+
+Output from other programs that already contains escape sequences goes
+through `fromAnsi`, which keeps colours, attributes and hyperlinks and drops
+everything else:
+
+```haskell
+render (border roundedBorder) (fromAnsi "\ESC[1;32mok\ESC[0m 3 tests passed")
+```
+
+Also: `breakAfter` (wrap after extra characters such as `-`),
+`styleRanges` and `styleIndices` (highlight columns or characters of
+existing text, e.g. fuzzy-search matches), `transform`, `ansiWidth`.
+
+Widths follow the Unicode 16.0.0 grapheme cluster rules (the official
+conformance tests pass) and East Asian Width, so CJK text, emoji, flags and
+combining marks line up.
+
+## Tables
+
+```haskell
+table
+ ( borderFg "#874BFD"
+ <> headerStyle (bold <> fg "#F25D94" <> align center)
+ <> cellStyle (\case BodyCell r _ | odd r -> padding 0 1 <> faint; _ -> padding 0 1)
+ )
+ ["Language", "Formal", "Informal"]
+ [ ["Chinese", "您好", "你好"]
+ , ["Japanese", "こんにちは", "やあ"]
+ , ["Russian", "Здравствуйте", "Привет"]
+ ]
+```
+
+
+
+Cells are blocks, so they can hold lists, other tables or anything else.
+A table fits the width it is laid out in: columns shrink, wrapping their
+cells, widest first but without breaking a word while another column can
+still wrap (headers are cut short instead), and with `fillWidth` they grow
+to fill it. With a `width`, columns shrink or grow to fit that instead;
+`fitContent` makes the width a maximum. With a `maxHeight`, the body rows
+that do not fit are left out, with a row of `…` in their place where it
+fits, `yOffset` scrolls, and `visibleRows` tells which rows are shown; a
+`height` adds empty rows up to it. `headerRule`, `columnRules`, `rowRules`
+and the `border*` modifiers choose which lines are drawn.
+
+## Lists and trees
+
+Trees take a `Data.Tree`; items are blocks, so anything can go in them,
+tables included.
+
+```haskell
+tree
+ (enumerator roundedTreeEnumerator <> enumeratorStyle (fg "#874BFD") <> rootStyle (fg "#F25D94"))
+ (Node "." [Node "macOS" [], Node "Linux" [Node "NixOS" [], Node "Arch" []], Node "BSD" []])
+
+nestedList
+ (enumerator (byDepth (\depth -> if depth == 0 then roman else bullet)) <> enumeratorStyle (fg "#F25D94"))
+ [Node "Glossier" [Node "Cloud Paint" [], Node "Boy Brow" []], Node "Nyx" []]
+```
+
+
+
+The enumerators are `treeEnumerator`, `roundedTreeEnumerator`, `bullet`,
+`dash`, `asterisk`, `arabic`, `alphabet` and `roman`, or your own, made
+with `markers`. Items, enumerators and indentation are styled separately,
+by position if needed. Items wrap in the width left after their
+indentation.
+
+## Layers
+
+Blocks can be stacked at any position, for dialogs, overlays and the like.
+`layerAt` finds the named layer under a point, for mouse handling.
+
+```haskell
+compose
+ [ layer (fg "#383838") (text (T.intercalate "\n" (replicate 6 (T.replicate 34 "╱"))))
+ , layer (offset 7 2 <> zIndex 1) (render (bg "#0A0A0A" <> width 22 <> height 3) "")
+ , layer
+ (offset 5 1 <> zIndex 2 <> layerId "dialog")
+ (render (border roundedBorder <> borderFg "#F25D94" <> bg "#3C3C3C" <> padding 0 2 <> width 22 <> align center) "Really quit?")
+ ]
+```
+
+
+
+## Colours
+
+Colours are written as `"#7D56F4"`, `"#fa0"`, palette indices (`"201"`,
+`"5"`) or names (`red`, `brightBlue`, …). Adaptive colours are resolved only
+when printing:
+
+- `lightDark light dark` picks by the terminal background;
+- `complete trueColor color256 color16` picks by what the terminal supports.
+
+`blend` and `blend2D` make gradients, `darken`, `lighten` and `complementary`
+adjust colours; they work in the OkLab colour space. `borderFgBlend` draws a
+gradient around a border.
+
+```haskell
+vcat
+ [ hcat [render (bg c) " " | c <- blend 24 ["#7D56F4", "#F25D94", "#FAD45A"]]
+ , text ""
+ , render
+ (border roundedBorder <> borderFgBlend ["#7D56F4", "#F25D94", "#FAD45A"] <> padding 1 4)
+ ( styled (fg (darken 0.4 "#F25D94")) "darker "
+ <> styled (fg "#F25D94") "pink "
+ <> styled (fg (lighten 0.4 "#F25D94")) "lighter"
+ )
+ ]
+```
+
+
+
+## Output
+
+`putBlock` and `hPutBlock` print a block, reducing colours to what the
+output supports. Detection follows the usual conventions: no escape
+sequences when the output is not a terminal (unless `CLICOLOR_FORCE` is
+set to anything but `0`), no colours with `NO_COLOR`, and the colour depth
+from `COLORTERM` and `TERM`. On Windows the console's ANSI processing is
+switched on as needed. Blocks are laid out in `COLUMNS` if it is set to a
+positive number, even when the output is not a terminal, or else in the
+terminal's width; output that is not going to a terminal otherwise keeps
+its natural width.
+
+The background is taken from `COLORFGBG` when the terminal sets it and is
+assumed dark otherwise. To ask the terminal, which takes a round trip and
+reads from stdin, detect once and keep the result:
+
+```haskell
+main = do
+ env <- detectEnvQuery stdout
+ hPutBlockWith env stdout (render card "Hello")
+```
+
+`toAnsi env block` gives the text without printing it, and `renderPlain`
+gives it without any escape sequences.
+
+## brick and vty
+
+[`lipstick-brick`](https://hackage.haskell.org/package/lipstick-brick)
+shows blocks in brick and vty applications. It uses only the public API:
+`Lipstick.Grid` gives the laid-out lines, cells and styled spans of a
+block, so blocks can be shown in other outputs too.
+
+## How lipstick differs from lipgloss
+
+lipgloss renders to strings with escape sequences in them, and measures and
+joins them by parsing those sequences again. lipstick renders to blocks of
+styled spans and produces escape sequences only when printing. Layout never
+parses an escape sequence, and adaptive colours are resolved for the actual
+terminal when printing.
+
+lipgloss is where lipstick started, not a compatibility target: where a
+clearer rule exists, lipstick follows it. Notable differences:
+
+- Nested styles keep the outer style. In lipgloss the outer style wraps the
+ line once, so a reset at the end of nested styled text ends it for the
+ rest of the line.
+- The text attributes of any thing are the base for everything it draws:
+ for a table they are lipgloss's `BaseStyle`, and for `place` they apply to
+ the placed block as well as to the whitespace.
+- Lists and trees are both `Outline`s (`Mod Tree` would clash with
+ `Data.Tree`).
+- Blocks are laid out in the width they are given, so text and tables
+ reflow without explicit widths.
+- Table columns shrink as CSS tables do: not below their longest word while
+ another column can still wrap. lipgloss shrinks columns by their median
+ cell width and may break words that did not need breaking.
+- An emoji with a skin tone modifier is two columns wide even when the
+ emoji alone is one, as in `☝🏻` (UTS #51). lipgloss measures it by its
+ first character, one column.
+
+Not ported: `Alpha` (terminals cannot show transparency), the Windows
+build-number check (lipstick asks the console to switch on ANSI processing,
+and prints plain text where it cannot), and Go-specific API such as
+`SetString`, `Copy`, `WrapWriter` and the table data interfaces, which
+plain values and lists cover.
+
+## Compared with layoutz
+
+I did not know about [layoutz](https://hackage.haskell.org/package/layoutz)
+while writing lipstick, and came across it only when preparing the first
+release. It is another Haskell library for terminal output, and it does a
+lot that lipstick does not: charts (bars, sparklines, braille line and pie
+plots, heatmaps), spinners and progress bars, inline images for kitty,
+interactive prompts and a small Elm-style application runtime, all in one
+module with only boot-package dependencies. For a quick dashboard or an
+animated script, it is worth a look.
+
+The two are built differently. layoutz renders each element to a `String`
+with escape sequences in it and measures it again by stripping them;
+lipstick renders to blocks of styled cells and produces escape sequences
+only when printing. From the source of layoutz 0.4.0.0:
+
+| | layoutz | lipstick |
+| ---------------------- | ---------------------------------------------------------------- | ----------------------------------------------------------- |
+| Width of text | a list of wide ranges: CJK lines up, emoji sequences and flags do not | Unicode grapheme clusters and East Asian Width |
+| Colours | foreground only, in 16, 256 or 24-bit colour | foreground, background and underline; light/dark and per-profile colours; gradients |
+| Terminal support | always prints escape sequences | `NO_COLOR`, `CLICOLOR_FORCE`, `COLORTERM`, `TERM`; colours reduced to what the output shows |
+| Nested styles | an inner style ends the outer one | the outer style shows through |
+| Layout | as wide as the content; wrapping at a given width | laid out in the width available: text wraps, tables shrink their columns |
+| Tables | columns as wide as their widest cell | columns that shrink and grow, styles by cell, scrolling |
+| Placing and layers | no | `place`, `compose`, hit testing |
+| Existing ANSI text, hyperlinks | no | `fromAnsi`, `link` |
+| Charts, spinners, prompts, application loop | yes | no; for full-screen applications, brick through lipstick-brick |
+
+## Documentation
+
+The API documentation of the latest release is at
+.
+
+Each [release](https://github.com/andreabedini/lipstick/releases) also has the
+documentation of every package with a library, as
+`PACKAGE-VERSION-docs.tar.gz`, in the format Hackage takes.
+
+## Development
+
+See
+[CONTRIBUTING.md](https://github.com/andreabedini/lipstick/blob/main/CONTRIBUTING.md)
+for building, testing, commit messages and releases.
+
+## Licence
+
+MIT, see [LICENSE](https://github.com/andreabedini/lipstick/blob/main/LICENSE). lipstick is a port of
+[lipgloss](https://github.com/charmbracelet/lipgloss), © Charmbracelet,
+also MIT licensed. The Unicode tables in
+`internal/Lipstick/Internal/UnicodeTable.hs` are generated from the Unicode
+Character Database, and `test/data/GraphemeBreakTest.txt` comes from it;
+both are © Unicode, Inc., under the Unicode License v3, see
+[LICENSE.Unicode](https://github.com/andreabedini/lipstick/blob/main/LICENSE.Unicode).
diff --git a/examples/Main.hs b/examples/Main.hs
new file mode 100644
--- /dev/null
+++ b/examples/Main.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Data.Text qualified as T
+import Lipstick
+
+purple, pink, grey :: Color
+purple = lightDark "#874BFD" "#AD8CFF"
+pink = "#F25D94"
+grey = lightDark "#D9DCCF" "#383838"
+
+card :: Mod Style
+card =
+ bold
+ <> fg "#FAFAFA"
+ <> bg "#7D56F4"
+ <> padding 1 4
+ <> width 24
+ <> border roundedBorder
+ <> borderFg purple
+
+tab :: Mod Style
+tab = padding 0 1 <> border normalBorder <> borderFg purple
+
+borders :: Block
+borders =
+ hcat
+ [ render (tab <> border b <> marginRight 1) name
+ | (name, b) <-
+ [ ("normal", normalBorder)
+ , ("rounded", roundedBorder)
+ , ("thick", thickBorder)
+ , ("double", doubleBorder)
+ , ("ascii", asciiBorder)
+ , ("block", blockBorder)
+ ]
+ ]
+
+paragraph :: Block
+paragraph =
+ render
+ (width 40 <> padding 1 2 <> border doubleBorder <> borderFg pink <> align center)
+ ( "Lipstick renders to blocks, not strings. "
+ <> styled (italic <> fg pink) "Widths are exact"
+ <> ", even for 日本語 and emoji 🎨, and "
+ <> styled (underlineStyle CurlyUnderline <> underlineColor pink) "nested styles"
+ <> " keep the outer background."
+ )
+
+-- | A gradient made of blocks with blended backgrounds.
+swatches :: Block
+swatches =
+ hcat
+ [ render (bg c <> width 3) " "
+ | c <- blend 24 ["#7D56F4", "#F25D94", "#FAD45A"]
+ ]
+
+gradientCard :: Block
+gradientCard =
+ render
+ (padding 1 3 <> border roundedBorder <> borderFgBlend ["#7D56F4", "#F25D94", "#FAD45A"] <> align center)
+ ( "Gradient borders, "
+ <> styled (fg (darken 0.3 pink)) "darker"
+ <> " and "
+ <> styled (fg (lighten 0.4 pink)) "lighter"
+ <> " colours\n"
+ <> fromAnsi "and \ESC[1;32mANSI\ESC[0m from \ESC]8;;https://example.com\ESC\\other tools\ESC]8;;\ESC\\"
+ )
+
+languages :: Block
+languages =
+ table
+ ( borderFg purple
+ <> width 46
+ <> headerStyle (bold <> fg pink <> align center)
+ <> cellStyle (\case BodyCell r _ | odd r -> padding 0 1 <> fg grey; _ -> padding 0 1)
+ )
+ ["Language", "Formal", "Informal"]
+ [ ["Chinese", "您好", "你好"]
+ , ["Japanese", "こんにちは", "やあ"]
+ , ["Arabic", "أهلين", "أهلا"]
+ , ["Russian", "Здравствуйте", "Привет"]
+ , ["Spanish", "Hola", "¿Qué tal?"]
+ ]
+
+outlines :: Block
+outlines =
+ joinHorizontal
+ top
+ [ tree
+ (enumerator roundedTreeEnumerator <> enumeratorStyle (fg purple) <> rootStyle (bold <> fg pink))
+ (Node "." [Node "macOS" [], Node "Linux" [Node "NixOS" [], Node "Arch" [], Node "Debian" []], Node "BSD" []])
+ , render (paddingLeft 6) ""
+ , nestedList
+ ( enumerator (byDepth (\d -> if d == 0 then roman else bullet))
+ <> enumeratorStyleWith (\p -> fg (if itemDepth p == 0 then pink else purple))
+ )
+ [ Node "Glossier" [Node "Cloud Paint" [], Node "Boy Brow" []]
+ , Node "Nyx" []
+ , Node "Mac" [Node "Ruby Woo" []]
+ ]
+ ]
+
+-- | A dialog composited over a background, with a drop shadow.
+dialogScene :: Block
+dialogScene =
+ compose
+ [ layer mempty (render (fg grey) (plain (T.unlines (replicate 8 (T.replicate 60 "╱")))))
+ , layer (offset 13 2 <> zIndex 1) (render (bg "#222222" <> width 34 <> height 6) "")
+ , layer
+ (offset 11 1 <> zIndex 2 <> layerId "dialog")
+ ( render
+ (border roundedBorder <> borderFg pink <> bg "#3C3C3C" <> padding 1 2 <> width 34 <> align center)
+ "Are you sure you want to eat marmalade?"
+ )
+ ]
+
+main :: IO ()
+main = do
+ putBlock $
+ joinHorizontal
+ center
+ [ render card "Hello, kitty"
+ , render (card <> bg pink <> marginLeft 2) "Override by appending"
+ ]
+ putBlock borders
+ putBlock paragraph
+ putBlock $
+ place
+ (width 60 <> height 5 <> align center <> valign center <> fg grey <> whitespaceChars "·")
+ (render (bold <> fg pink) "placed in the middle")
+ putBlock languages
+ putBlock outlines
+ putBlock dialogScene
+ putBlock swatches
+ putBlock gradientCard
+ putBlock $ render (link "https://github.com/charmbracelet/lipgloss" <> underline) "A hyperlink to lipgloss"
diff --git a/examples/Screenshots.hs b/examples/Screenshots.hs
new file mode 100644
--- /dev/null
+++ b/examples/Screenshots.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The examples shown in the README, and their screenshots.
+--
+-- The README repeats each example's code by hand; CI checks only that
+-- docs/images matches this file.
+--
+-- > cabal run -v0 lipstick-screenshots -- docs/images # write the SVGs
+-- > cabal run -v0 lipstick-screenshots -- --ansi table # print one example
+module Main (main) where
+
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import Data.Text.IO.Utf8 qualified as Utf8
+import Lipstick
+import Svg (blockSvg)
+import System.Environment (getArgs)
+import System.Exit (die)
+import System.FilePath (())
+
+card :: Mod Style
+card =
+ bold
+ <> fg "#FAFAFA"
+ <> bg "#7D56F4"
+ <> padding 1 4
+ <> width 24
+ <> border roundedBorder
+ <> borderFg "#874BFD"
+
+warning :: Mod Style
+warning = card <> bg "#F25D94"
+
+quickstart :: Block
+quickstart = render card "Hello, kitty"
+
+joined :: Block
+joined =
+ joinHorizontal
+ center
+ [ render card "Hello, kitty"
+ , render (warning <> marginLeft 2) "Later settings win"
+ ]
+
+placed :: Block
+placed =
+ place
+ (width 30 <> height 3 <> align center <> valign center <> whitespaceChars "·" <> fg "#383838")
+ (render (bold <> fg "#F25D94") "centred")
+
+inlineText :: Block
+inlineText =
+ render
+ (width 30 <> border normalBorder <> borderFg "#874BFD" <> padding 0 1)
+ (styled (bold <> fg "#F25D94") "Error: " <> "the file " <> styled italic "notes.txt" <> " was not found")
+
+languages :: Block
+languages =
+ table
+ ( borderFg "#874BFD"
+ <> headerStyle (bold <> fg "#F25D94" <> align center)
+ <> cellStyle (\case BodyCell r _ | odd r -> padding 0 1 <> faint; _ -> padding 0 1)
+ )
+ ["Language", "Formal", "Informal"]
+ [ ["Chinese", "您好", "你好"]
+ , ["Japanese", "こんにちは", "やあ"]
+ , ["Russian", "Здравствуйте", "Привет"]
+ ]
+
+outlines :: Block
+outlines =
+ joinHorizontal
+ top
+ [ tree
+ (enumerator roundedTreeEnumerator <> enumeratorStyle (fg "#874BFD") <> rootStyle (fg "#F25D94"))
+ (Node "." [Node "macOS" [], Node "Linux" [Node "NixOS" [], Node "Arch" []], Node "BSD" []])
+ , text " "
+ , nestedList
+ ( enumerator (byDepth (\depth -> if depth == 0 then roman else bullet))
+ <> enumeratorStyle (fg "#F25D94")
+ )
+ [Node "Glossier" [Node "Cloud Paint" [], Node "Boy Brow" []], Node "Nyx" []]
+ ]
+
+layers :: Block
+layers =
+ compose
+ [ layer (fg "#383838") (text (T.intercalate "\n" (replicate 6 (T.replicate 34 "╱"))))
+ , layer (offset 7 2 <> zIndex 1) (render (bg "#0A0A0A" <> width 22 <> height 3) "")
+ , layer
+ (offset 5 1 <> zIndex 2 <> layerId "dialog")
+ (render (border roundedBorder <> borderFg "#F25D94" <> bg "#3C3C3C" <> padding 0 2 <> width 22 <> align center) "Really quit?")
+ ]
+
+colours :: Block
+colours =
+ vcat
+ [ hcat [render (bg c) " " | c <- blend 24 ["#7D56F4", "#F25D94", "#FAD45A"]]
+ , text ""
+ , render
+ (border roundedBorder <> borderFgBlend ["#7D56F4", "#F25D94", "#FAD45A"] <> padding 1 4)
+ ( styled (fg (darken 0.4 "#F25D94")) "darker "
+ <> styled (fg "#F25D94") "pink "
+ <> styled (fg (lighten 0.4 "#F25D94")) "lighter"
+ )
+ ]
+
+examples :: [(String, Block)]
+examples =
+ [ ("quickstart", quickstart)
+ , ("layout", joined)
+ , ("place", placed)
+ , ("text", inlineText)
+ , ("table", languages)
+ , ("outlines", outlines)
+ , ("layers", layers)
+ , ("colours", colours)
+ ]
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["--ansi", name] | Just b <- lookup name examples -> T.putStrLn (toAnsi defaultRenderEnv b)
+ [dir] -> mapM_ (\(name, b) -> Utf8.writeFile (dir name <> ".svg") (blockSvg b)) examples
+ _ -> die ("usage: lipstick-screenshots DIR | --ansi (" ++ unwords (map fst examples) ++ ")")
diff --git a/examples/Svg.hs b/examples/Svg.hs
new file mode 100644
--- /dev/null
+++ b/examples/Svg.hs
@@ -0,0 +1,288 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Render a block as an SVG "screenshot" of a terminal window.
+--
+-- Everything is placed on the terminal's cell grid: each cluster is drawn
+-- at its column and stretched to exactly its width with @textLength@, and
+-- box-drawing and block characters are drawn as lines and rectangles, as
+-- terminals do. The grid stays aligned whatever fonts the viewer has, and
+-- the result is a pure function of the block, so CI can compare it.
+module Svg (blockSvg) where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick (Block, ColorProfile (TrueColor), TermColor (..), layout, resolveColor, termColorRGB)
+import Lipstick (Attrs (..), Underline (..))
+import Lipstick.Grid (cellAttrs, cellText, cellWidth, gridHeight, gridLines, gridWidth, lineCells)
+import Numeric (showFFloat, showHex)
+
+-- Geometry ----------------------------------------------------------------------
+
+fontSize, cellW, cellH :: Double
+fontSize = 14
+cellW = 8.4
+cellH = 18
+
+-- | Space around the content inside the window, and the window's margin.
+padX, padTop, padBottom, margin, titleBar :: Double
+padX = 20
+padTop = 14
+padBottom = 20
+margin = 24
+titleBar = 36
+
+windowBg, defaultFg :: Text
+windowBg = "#171717"
+defaultFg = "#DDDDDD"
+
+num :: Double -> Text
+num x =
+ let s = T.pack (showFFloat (Just 2) x "")
+ in fromMaybe s (T.stripSuffix ".00" s)
+
+-- | The block, at its natural width, as an SVG document.
+blockSvg :: Block -> Text
+blockSvg block =
+ T.unlines $
+ [ ""]
+ where
+ b = layout Nothing block
+ rows = zip [0 :: Int ..] (map lineCells (gridLines b))
+ contentW = fromIntegral (gridWidth b) * cellW
+ contentH = fromIntegral (gridHeight b) * cellH
+ winW = padX * 2 + contentW
+ winH = titleBar + padTop + contentH + padBottom
+ totalW = winW + margin * 2
+ totalH = winH + margin * 2
+ originX = margin + padX
+ originY = margin + titleBar + padTop
+
+ circle :: Int -> Text -> Text
+ circle i colour =
+ " num (margin + 20 + 20 * fromIntegral i) <> "\" cy=\"" <> num (margin + 18) <> "\" r=\"6\" fill=\"" <> colour <> "\"/>"
+
+ cellsAt cells = zip (scanl (+) 0 (map cellWidth cells)) cells
+ cellX col = originX + fromIntegral col * cellW
+ cellY row = originY + fromIntegral row * cellH
+
+ -- Each rectangle reaches half a unit into the cells to its right and
+ -- below, so that anti-aliased edges at fractional coordinates leave no
+ -- seams between neighbours.
+ backgrounds row cells =
+ [ " num (cellX col) <> "\" y=\"" <> num (cellY row) <> "\" width=\"" <> num (fromIntegral (cellWidth c) * cellW + 0.5) <> "\" height=\"" <> num (cellH + 0.5) <> "\" fill=\"" <> colour <> "\"/>"
+ | (col, c) <- cellsAt cells
+ , Just colour <- [snd (colours (cellAttrs c))]
+ ]
+
+ foregrounds row cells = concatMap (glyph row) (cellsAt cells)
+
+ glyph row (col, c)
+ | cellWidth c == 0 = []
+ | otherwise =
+ let a = cellAttrs c
+ (fgc, _) = colours a
+ ink = fromMaybe defaultFg fgc
+ x = cellX col
+ y = cellY row
+ w = fromIntegral (cellWidth c) * cellW
+ opacity = if on attrFaint a then " opacity=\"0.55\"" else ""
+ decorations = underlineSvg a ink x y w ++ strikeSvg a ink x y w
+ ch = T.unpack (cellText c)
+ in case ch of
+ [one] | Just shape <- boxShape one -> [wrapG ink opacity (shape x y)] ++ decorations
+ _
+ | cellText c == " " -> decorations
+ | otherwise ->
+ [ " num x <> "\" y=\"" <> num (y + cellH * 0.76) <> "\" textLength=\"" <> num w <> "\" lengthAdjust=\"spacingAndGlyphs\" fill=\"" <> ink <> "\"" <> opacity <> weight a <> style a <> ">" <> escape (cellText c) <> ""
+ ]
+ ++ decorations
+
+ wrapG ink opacity inner = " ink <> "\" fill=\"" <> ink <> "\"" <> opacity <> ">" <> inner <> ""
+ weight a = if on attrBold a then " font-weight=\"bold\"" else ""
+ style a = if on attrItalic a then " font-style=\"italic\"" else ""
+
+on :: (Attrs -> Maybe Bool) -> Attrs -> Bool
+on f = fromMaybe False . f
+
+-- | Foreground and background, with reverse video applied. Adaptive
+-- colours are resolved for a true-colour terminal with a dark background.
+colours :: Attrs -> (Maybe Text, Maybe Text)
+colours a =
+ let fgc = hexOf <$> (attrFg a >>= resolveColor TrueColor True)
+ bgc = hexOf <$> (attrBg a >>= resolveColor TrueColor True)
+ in if on attrReverse a
+ then (Just (fromMaybe windowBg bgc), Just (fromMaybe defaultFg fgc))
+ else (fgc, bgc)
+
+hexOf :: TermColor -> Text
+hexOf c =
+ let (r, g, b) = termColorRGB c
+ two v = let s = showHex v "" in T.pack (if length s == 1 then '0' : s else s)
+ in "#" <> T.toUpper (two r <> two g <> two b)
+
+escape :: Text -> Text
+escape = T.concatMap $ \case
+ '<' -> "<"
+ '>' -> ">"
+ '&' -> "&"
+ '"' -> """
+ ch -> T.singleton ch
+
+underlineSvg :: Attrs -> Text -> Double -> Double -> Double -> [Text]
+underlineSvg a ink x y w = case fromMaybe NoUnderline (attrUnderline a) of
+ NoUnderline -> []
+ CurlyUnderline ->
+ let yy = y + cellH - 2.5
+ waves = [x + fromIntegral i * 4 | i <- [0 .. floor (w / 4) - 1 :: Int]]
+ path = T.concat ["q 1 -2 2 0 t 2 0" | _ <- waves]
+ in [" num x <> " " <> num yy <> " " <> path <> "\" stroke=\"" <> underlineInk <> "\" fill=\"none\" stroke-width=\"1\"/>"]
+ DoubleUnderline -> [hline (y + cellH - 3.5), hline (y + cellH - 1.5)]
+ _ -> [hline (y + cellH - 2.5)]
+ where
+ underlineInk = maybe ink hexOf (attrUnderlineColor a >>= resolveColor TrueColor True)
+ hline yy = " num x <> "\" y1=\"" <> num yy <> "\" x2=\"" <> num (x + w) <> "\" y2=\"" <> num yy <> "\" stroke=\"" <> underlineInk <> "\" stroke-width=\"1\"/>"
+
+strikeSvg :: Attrs -> Text -> Double -> Double -> Double -> [Text]
+strikeSvg a ink x y w
+ | on attrStrikethrough a =
+ [" num x <> "\" y1=\"" <> num (y + cellH / 2) <> "\" x2=\"" <> num (x + w) <> "\" y2=\"" <> num (y + cellH / 2) <> "\" stroke=\"" <> ink <> "\" stroke-width=\"1\"/>"]
+ | otherwise = []
+
+-- Box drawing ---------------------------------------------------------------------
+
+-- | How a line leaves the centre of a cell towards one edge.
+data Arm = None | Light | Heavy | Double
+ deriving (Eq)
+
+-- | Arms towards the top, right, bottom and left edges.
+arms :: Char -> Maybe (Arm, Arm, Arm, Arm)
+arms ch = lookup ch table
+ where
+ l = Light
+ h = Heavy
+ d = Double
+ n = None
+ table =
+ [ ('─', (n, l, n, l)), ('│', (l, n, l, n)), ('┌', (n, l, l, n)), ('┐', (n, n, l, l))
+ , ('└', (l, l, n, n)), ('┘', (l, n, n, l)), ('├', (l, l, l, n)), ('┤', (l, n, l, l))
+ , ('┬', (n, l, l, l)), ('┴', (l, l, n, l)), ('┼', (l, l, l, l))
+ , ('━', (n, h, n, h)), ('┃', (h, n, h, n)), ('┏', (n, h, h, n)), ('┓', (n, n, h, h))
+ , ('┗', (h, h, n, n)), ('┛', (h, n, n, h)), ('┣', (h, h, h, n)), ('┫', (h, n, h, h))
+ , ('┳', (n, h, h, h)), ('┻', (h, h, n, h)), ('╋', (h, h, h, h))
+ , ('═', (n, d, n, d)), ('║', (d, n, d, n)), ('╔', (n, d, d, n)), ('╗', (n, n, d, d))
+ , ('╚', (d, d, n, n)), ('╝', (d, n, n, d)), ('╠', (d, d, d, n)), ('╣', (d, n, d, d))
+ , ('╦', (n, d, d, d)), ('╩', (d, d, n, d)), ('╬', (d, d, d, d))
+ ]
+
+-- | Characters drawn as shapes, given the cell's top-left corner.
+boxShape :: Char -> Maybe (Double -> Double -> Text)
+boxShape ch
+ | Just a <- arms ch = Just (drawArms a)
+ | Just corner <- lookup ch rounded = Just (drawRounded corner)
+ | Just quads <- lookup ch blocks = Just (drawBlocks quads)
+ | ch == '╱' = Just (\x y -> line x (y + cellH) (x + cellW) y 1.2)
+ | ch == '╲' = Just (\x y -> line x y (x + cellW) (y + cellH) 1.2)
+ | otherwise = Nothing
+ where
+ rounded = [('╭', (1, 1)), ('╮', (-1, 1)), ('╰', (1, -1)), ('╯', (-1, -1))]
+ -- Quadrants: top-left, top-right, bottom-left, bottom-right.
+ blocks =
+ [ ('█', [True, True, True, True]), ('▀', [True, True, False, False]), ('▄', [False, False, True, True])
+ , ('▌', [True, False, True, False]), ('▐', [False, True, False, True]), ('▛', [True, True, True, False])
+ , ('▜', [True, True, False, True]), ('▙', [True, False, True, True]), ('▟', [False, True, True, True])
+ , ('▖', [False, False, True, False]), ('▗', [False, False, False, True]), ('▘', [True, False, False, False])
+ , ('▝', [False, True, False, False])
+ ]
+
+line :: Double -> Double -> Double -> Double -> Double -> Text
+line x1 y1 x2 y2 sw =
+ " num x1 <> "\" y1=\"" <> num y1 <> "\" x2=\"" <> num x2 <> "\" y2=\"" <> num y2 <> "\" stroke-width=\"" <> num sw <> "\" stroke-linecap=\"square\"/>"
+
+drawArms :: (Arm, Arm, Arm, Arm) -> Double -> Double -> Text
+drawArms (up, right, down, left) x y =
+ T.concat (single ++ doubles)
+ where
+ cx = x + cellW / 2
+ cy = y + cellH / 2
+ width = \case
+ Heavy -> 2.4
+ _ -> 1.2
+ single =
+ [line cx cy cx y (width up) | up `elem` [Light, Heavy]]
+ ++ [line cx cy (x + cellW) cy (width right) | right `elem` [Light, Heavy]]
+ ++ [line cx cy cx (y + cellH) (width down) | down `elem` [Light, Heavy]]
+ ++ [line cx cy x cy (width left) | left `elem` [Light, Heavy]]
+ -- Double lines: two strokes either side of the centre line. A stroke
+ -- facing an arm on its side is split around that arm; the other runs
+ -- through, stopping at the strokes it meets.
+ o = 2
+ du = up == Double
+ dr = right == Double
+ dd = down == Double
+ dl = left == Double
+ doubles =
+ (if du || dd then vertical (-1) ++ vertical 1 else [])
+ ++ (if dl || dr then horizontal (-1) ++ horizontal 1 else [])
+ vertical side =
+ let sx = cx + side * o
+ facing = if side < 0 then dl else dr
+ in if facing
+ then [line sx y sx (cy - o) 1 | du] ++ [line sx (cy + o) sx (y + cellH) 1 | dd]
+ else [line sx (if du then y else cy - o) sx (if dd then y + cellH else cy + o) 1]
+ horizontal side =
+ let sy = cy + side * o
+ facing = if side < 0 then du else dd
+ in if facing
+ then [line x sy (cx - o) sy 1 | dl] ++ [line (cx + o) sy (x + cellW) sy 1 | dr]
+ else [line (if dl then x else cx - o) sy (if dr then x + cellW else cx + o) sy 1]
+
+-- | A rounded corner: the directions (towards the right or left, towards
+-- the bottom or top) its two arms go.
+drawRounded :: (Double, Double) -> Double -> Double -> Text
+drawRounded (hx, vy) x y =
+ let cx = x + cellW / 2
+ cy = y + cellH / 2
+ r = cellW / 2
+ edgeX = if hx > 0 then x + cellW else x
+ edgeY = if vy > 0 then y + cellH else y
+ -- ╭ and ╯ turn anticlockwise on screen, ╮ and ╰ clockwise.
+ sweep = if hx * vy > 0 then "0" else "1" :: Text
+ in " num edgeX
+ <> " "
+ <> num cy
+ <> " H "
+ <> num (cx + hx * r)
+ <> " A "
+ <> num r
+ <> " "
+ <> num r
+ <> " 0 0 "
+ <> sweep
+ <> " "
+ <> num cx
+ <> " "
+ <> num (cy + vy * r)
+ <> " V "
+ <> num edgeY
+ <> "\" fill=\"none\" stroke-width=\"1.2\"/>"
+
+-- Quadrants overlap slightly, as backgrounds do, to leave no seams.
+drawBlocks :: [Bool] -> Double -> Double -> Text
+drawBlocks quads x y =
+ T.concat
+ [ " num qx <> "\" y=\"" <> num qy <> "\" width=\"" <> num (cellW / 2 + 0.3) <> "\" height=\"" <> num (cellH / 2 + 0.3) <> "\" stroke=\"none\"/>"
+ | (filled, (qx, qy)) <- zip quads [(x, y), (x + cellW / 2, y), (x, y + cellH / 2), (x + cellW / 2, y + cellH / 2)]
+ , filled
+ ]
diff --git a/internal/Lipstick/Internal/Border.hs b/internal/Lipstick/Internal/Border.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Border.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | The implementation of "Lipstick.Border", hidden from other packages: see
+-- that module.
+module Lipstick.Internal.Border
+ ( Border (..)
+ , normalBorder
+ , roundedBorder
+ , thickBorder
+ , doubleBorder
+ , blockBorder
+ , outerHalfBlockBorder
+ , innerHalfBlockBorder
+ , hiddenBorder
+ , asciiBorder
+ , markdownBorder
+ ) where
+
+import Data.Text (Text)
+
+-- | The characters used to draw a border. The @middle*@ pieces are used
+-- where table rules meet.
+data Border = Border
+ { topEdge :: !Text
+ , bottomEdge :: !Text
+ , leftEdge :: !Text
+ , rightEdge :: !Text
+ , topLeftCorner :: !Text
+ , topRightCorner :: !Text
+ , bottomLeftCorner :: !Text
+ , bottomRightCorner :: !Text
+ , middleLeft :: !Text
+ , middleRight :: !Text
+ , middle :: !Text
+ , middleTop :: !Text
+ , middleBottom :: !Text
+ }
+ deriving (Eq, Show)
+
+-- | Thin lines with square corners: ┌ ┐ └ ┘.
+normalBorder :: Border
+normalBorder = Border "─" "─" "│" "│" "┌" "┐" "└" "┘" "├" "┤" "┼" "┬" "┴"
+
+-- | Thin lines with rounded corners: ╭ ╮ ╰ ╯.
+roundedBorder :: Border
+roundedBorder = normalBorder {topLeftCorner = "╭", topRightCorner = "╮", bottomLeftCorner = "╰", bottomRightCorner = "╯"}
+
+-- | Thick lines: ┏ ┓ ┗ ┛.
+thickBorder :: Border
+thickBorder = Border "━" "━" "┃" "┃" "┏" "┓" "┗" "┛" "┣" "┫" "╋" "┳" "┻"
+
+-- | Double lines: ╔ ╗ ╚ ╝.
+doubleBorder :: Border
+doubleBorder = Border "═" "═" "║" "║" "╔" "╗" "╚" "╝" "╠" "╣" "╬" "╦" "╩"
+
+-- | Full blocks (█) all round.
+blockBorder :: Border
+blockBorder = Border "█" "█" "█" "█" "█" "█" "█" "█" "█" "█" "█" "█" "█"
+
+-- | Half blocks on the outer half of each border cell: ▛ ▜ ▙ ▟. It has
+-- no pieces for table rules.
+outerHalfBlockBorder :: Border
+outerHalfBlockBorder = Border "▀" "▄" "▌" "▐" "▛" "▜" "▙" "▟" "" "" "" "" ""
+
+-- | Half blocks on the inner half of each border cell: ▗ ▖ ▝ ▘. It has
+-- no pieces for table rules.
+innerHalfBlockBorder :: Border
+innerHalfBlockBorder = Border "▄" "▀" "▐" "▌" "▗" "▖" "▝" "▘" "" "" "" "" ""
+
+-- | Spaces: takes the room of a border without drawing one.
+hiddenBorder :: Border
+hiddenBorder = Border " " " " " " " " " " " " " " " " " " " " " " " " " "
+
+-- | ASCII only: @-@, @|@ and @+@ for the corners and joins.
+asciiBorder :: Border
+asciiBorder = Border "-" "-" "|" "|" "+" "+" "+" "+" "+" "+" "+" "+" "+"
+
+-- | Markdown table syntax: @-@ and @|@, with @|@ at the corners and
+-- joins. For a Markdown table, switch off its top and bottom sides.
+markdownBorder :: Border
+markdownBorder = Border "-" "-" "|" "|" "|" "|" "|" "|" "|" "|" "|" "|" "|"
diff --git a/internal/Lipstick/Internal/Color.hs b/internal/Lipstick/Internal/Color.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Color.hs
@@ -0,0 +1,448 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- | The implementation of "Lipstick.Color", hidden from other packages: see
+-- that module.
+module Lipstick.Internal.Color
+ ( -- * Colours
+ Color (..)
+ , rgb
+ , ansi
+ , ansi256
+ , hex
+ , lightDark
+ , complete
+
+ -- ** The 16 basic colours
+ , black, red, green, yellow, blue, magenta, cyan, white
+ , brightBlack, brightRed, brightGreen, brightYellow
+ , brightBlue, brightMagenta, brightCyan, brightWhite
+
+ -- * Manipulating colours
+ , mix
+ , blend
+ , blend2D
+ , darken
+ , lighten
+ , complementary
+
+ -- * Terminal colours
+ , TermColor (..)
+ , ColorProfile (..)
+ , resolveColor
+ , downsample
+ , termColorRGB
+ ) where
+
+import Data.Bits (shiftL, (.|.))
+import Data.Char (digitToInt, isDigit, isHexDigit)
+import Data.List (minimumBy)
+import Data.Maybe (fromMaybe)
+import Data.Ord (comparing)
+import Data.String (IsString (..))
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Word (Word8)
+
+-- | A colour as written in a style.
+data Color
+ = -- | A 24-bit colour.
+ RGB !Word8 !Word8 !Word8
+ | -- | A colour from the 256-colour palette.
+ Color256 !Word8
+ | -- | One of the 16 basic colours (0–15).
+ Color16 !Word8
+ | -- | Pick the first colour on light backgrounds, the second on dark ones.
+ LightDark Color Color
+ | -- | Explicit choices for true-colour, 256-colour and 16-colour terminals.
+ Complete Color Color Color
+ deriving (Eq, Ord)
+
+-- | Shown as the functions that make it, since the constructors are not
+-- exported: @rgb 125 86 244@, @ansi256 201@, @ansi 5@, @lightDark …@,
+-- @complete …@.
+instance Show Color where
+ showsPrec d c = showParen (d > 10) $ case c of
+ RGB r g b -> showString "rgb " . showsPrec 11 r . showChar ' ' . showsPrec 11 g . showChar ' ' . showsPrec 11 b
+ Color256 n -> showString "ansi256 " . showsPrec 11 n
+ Color16 n -> showString "ansi " . showsPrec 11 n
+ LightDark l k -> showString "lightDark " . showsPrec 11 l . showChar ' ' . showsPrec 11 k
+ Complete t x y -> showString "complete " . showsPrec 11 t . showChar ' ' . showsPrec 11 x . showChar ' ' . showsPrec 11 y
+
+-- | Parses @"#rgb"@, @"#rrggbb"@ or a palette index @"0"@–@"255"@.
+-- Calls 'error' on anything else; use 'hex' for a total parser of hex
+-- colours.
+instance IsString Color where
+ fromString s =
+ fromMaybe (error ("Lipstick.Color: invalid colour literal " ++ show s)) (parseColor s)
+
+-- | A 24-bit colour from its red, green and blue components. On a
+-- terminal with fewer colours, the nearest one it has is used.
+rgb :: Word8 -> Word8 -> Word8 -> Color
+rgb = RGB
+
+-- | One of the 16 basic colours; the index is taken modulo 16.
+ansi :: Int -> Color
+ansi n = Color16 (fromIntegral (n `mod` 16))
+
+-- | A colour from the 256-colour palette; the index is taken modulo 256.
+ansi256 :: Int -> Color
+ansi256 n = Color256 (fromIntegral (n `mod` 256))
+
+-- | Parses @"#rgb"@ or @"#rrggbb"@ (the @#@ is optional).
+hex :: Text -> Maybe Color
+hex t = parseHex (T.unpack (fromMaybe t (T.stripPrefix (T.singleton '#') t)))
+
+-- | @lightDark light dark@ is @light@ on a light background and @dark@ on
+-- a dark one. The choice is made when the block is printed, from
+-- 'Lipstick.Ansi.envDarkBackground'.
+lightDark :: Color -> Color -> Color
+lightDark = LightDark
+
+-- | @complete trueColor color256 color16@
+complete :: Color -> Color -> Color -> Color
+complete = Complete
+
+parseColor :: String -> Maybe Color
+parseColor = \case
+ '#' : ds -> parseHex ds
+ ds
+ | not (null ds), length ds <= 3, all isDigit ds
+ , n <- read ds :: Int
+ , n <= 255 ->
+ Just (if n < 16 then Color16 (fromIntegral n) else Color256 (fromIntegral n))
+ _ -> Nothing
+
+parseHex :: String -> Maybe Color
+parseHex ds
+ | not (all isHexDigit ds) = Nothing
+ | [r, g, b] <- ds = Just (RGB (byte [r, r]) (byte [g, g]) (byte [b, b]))
+ | [r1, r2, g1, g2, b1, b2] <- ds = Just (RGB (byte [r1, r2]) (byte [g1, g2]) (byte [b1, b2]))
+ | otherwise = Nothing
+ where
+ byte = foldl (\acc c -> acc `shiftL` 4 .|. fromIntegral (digitToInt c)) 0
+
+-- | Basic colour 0: @ansi 0@.
+black :: Color
+black = Color16 0
+
+-- | Basic colour 1: @ansi 1@.
+red :: Color
+red = Color16 1
+
+-- | Basic colour 2: @ansi 2@.
+green :: Color
+green = Color16 2
+
+-- | Basic colour 3: @ansi 3@.
+yellow :: Color
+yellow = Color16 3
+
+-- | Basic colour 4: @ansi 4@.
+blue :: Color
+blue = Color16 4
+
+-- | Basic colour 5: @ansi 5@.
+magenta :: Color
+magenta = Color16 5
+
+-- | Basic colour 6: @ansi 6@.
+cyan :: Color
+cyan = Color16 6
+
+-- | Basic colour 7: @ansi 7@.
+white :: Color
+white = Color16 7
+
+-- | Basic colour 8: @ansi 8@.
+brightBlack :: Color
+brightBlack = Color16 8
+
+-- | Basic colour 9: @ansi 9@.
+brightRed :: Color
+brightRed = Color16 9
+
+-- | Basic colour 10: @ansi 10@.
+brightGreen :: Color
+brightGreen = Color16 10
+
+-- | Basic colour 11: @ansi 11@.
+brightYellow :: Color
+brightYellow = Color16 11
+
+-- | Basic colour 12: @ansi 12@.
+brightBlue :: Color
+brightBlue = Color16 12
+
+-- | Basic colour 13: @ansi 13@.
+brightMagenta :: Color
+brightMagenta = Color16 13
+
+-- | Basic colour 14: @ansi 14@.
+brightCyan :: Color
+brightCyan = Color16 14
+
+-- | Basic colour 15: @ansi 15@.
+brightWhite :: Color
+brightWhite = Color16 15
+
+-- | A concrete colour a terminal understands.
+data TermColor
+ = TC16 !Word8
+ | TC256 !Word8
+ | TCRGB !Word8 !Word8 !Word8
+ deriving (Eq, Ord, Show)
+
+-- | What the output can display, from least to most capable.
+data ColorProfile
+ = -- | Not a terminal: no escape sequences at all.
+ NoTTY
+ | -- | Text attributes (bold, underline, …) but no colours.
+ Ascii
+ | ANSI16
+ | ANSI256
+ | TrueColor
+ deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | Resolve an adaptive colour for a profile and for whether the
+-- background is dark, then downsample. 'Nothing' means the profile cannot
+-- show colours.
+resolveColor :: ColorProfile -> Bool -> Color -> Maybe TermColor
+resolveColor p dark = go
+ where
+ go = \case
+ LightDark l d -> go (if dark then d else l)
+ Complete tc c256 c16 -> case p of
+ TrueColor -> go tc
+ ANSI256 -> go c256
+ _ -> go c16
+ RGB r g b -> downsample p (TCRGB r g b)
+ Color256 n -> downsample p (if n < 16 then TC16 n else TC256 n)
+ Color16 n -> downsample p (if n < 16 then TC16 n else TC256 n)
+
+-- | Convert a colour to the closest one the profile supports.
+downsample :: ColorProfile -> TermColor -> Maybe TermColor
+downsample p c = case p of
+ NoTTY -> Nothing
+ Ascii -> Nothing
+ TrueColor -> Just c
+ ANSI256 -> Just $ case c of
+ TCRGB r g b -> TC256 (rgbTo256 r g b)
+ _ -> c
+ ANSI16 -> Just $ case c of
+ TC16 _ -> c
+ _ -> TC16 (nearest16 (termColorRGB c))
+
+-- | The RGB value of a terminal colour, using xterm's default palette for
+-- the 16 basic colours.
+termColorRGB :: TermColor -> (Word8, Word8, Word8)
+termColorRGB = \case
+ TCRGB r g b -> (r, g, b)
+ TC16 n -> ansi16Palette !! fromIntegral (n `mod` 16)
+ TC256 n
+ | n < 16 -> ansi16Palette !! fromIntegral n
+ | n < 232 ->
+ let i = fromIntegral n - 16
+ in (cubeLevel (i `div` 36), cubeLevel ((i `div` 6) `mod` 6), cubeLevel (i `mod` 6))
+ | otherwise -> let v = fromIntegral (8 + 10 * (fromIntegral n - 232 :: Int)) in (v, v, v)
+
+ansi16Palette :: [(Word8, Word8, Word8)]
+ansi16Palette =
+ [ (0, 0, 0), (205, 0, 0), (0, 205, 0), (205, 205, 0)
+ , (0, 0, 238), (205, 0, 205), (0, 205, 205), (229, 229, 229)
+ , (127, 127, 127), (255, 0, 0), (0, 255, 0), (255, 255, 0)
+ , (92, 92, 255), (255, 0, 255), (0, 255, 255), (255, 255, 255)
+ ]
+
+cubeLevel :: Int -> Word8
+cubeLevel i = [0, 95, 135, 175, 215, 255] !! i
+
+-- | Nearest colour in the 6×6×6 cube or the grey ramp, as in tmux's
+-- colour_find_rgb (colour.c).
+rgbTo256 :: Word8 -> Word8 -> Word8 -> Word8
+rgbTo256 r8 g8 b8
+ | cube == target = cubeIx
+ | dist cube <= dist grey = cubeIx
+ | otherwise = fromIntegral (232 + greyIx)
+ where
+ target@(r, g, b) = (fromIntegral r8, fromIntegral g8, fromIntegral b8) :: (Int, Int, Int)
+ toCube v
+ | v < 48 = 0
+ | v < 115 = 1
+ | otherwise = (v - 35) `div` 40
+ (ri, gi, bi) = (toCube r, toCube g, toCube b)
+ lvl = fromIntegral . cubeLevel
+ cube = (lvl ri, lvl gi, lvl bi)
+ cubeIx = fromIntegral (16 + 36 * ri + 6 * gi + bi)
+ avg = (r + g + b) `div` 3
+ greyIx = if avg > 238 then 23 else max 0 ((avg - 3) `div` 10)
+ greyV = 8 + 10 * greyIx
+ grey = (greyV, greyV, greyV)
+ dist (x, y, z) = sq (x - r) + sq (y - g) + sq (z - b)
+ sq v = v * v
+
+nearest16 :: (Word8, Word8, Word8) -> Word8
+nearest16 (r, g, b) =
+ fst (minimumBy (comparing (dist . snd)) (zip [0 ..] ansi16Palette))
+ where
+ dist (x, y, z) = sq x r + sq y g + sq z b
+ sq :: Word8 -> Word8 -> Int
+ sq x y = let d = fromIntegral x - fromIntegral y in d * d
+
+-- Manipulating colours ----------------------------------------------------------
+
+-- | Björn Ottosson's OkLab, converted from and to sRGB as in
+-- .
+data OkLab = OkLab !Double !Double !Double
+
+-- | Apply a function to every concrete colour inside an adaptive one.
+mapConcrete :: (Color -> Color) -> Color -> Color
+mapConcrete f = \case
+ LightDark l d -> LightDark (mapConcrete f l) (mapConcrete f d)
+ Complete tc c256 c16 -> Complete (mapConcrete f tc) (mapConcrete f c256) (mapConcrete f c16)
+ c -> f c
+
+mapOkLab :: (OkLab -> OkLab) -> Color -> Color
+mapOkLab f = mapConcrete (fromOkLab . f . toOkLab)
+
+-- | Move a colour a fraction (0–1) of the way to black.
+darken :: Double -> Color -> Color
+darken k = mapOkLab (lerpOkLab (clamp01 k) (OkLab 0 0 0))
+
+-- | Move a colour a fraction (0–1) of the way to white.
+lighten :: Double -> Color -> Color
+lighten k = mapOkLab (lerpOkLab (clamp01 k) (OkLab 1 0 0))
+
+-- | @lerpOkLab k to from@ moves @from@ a fraction @k@ of the way to @to@.
+lerpOkLab :: Double -> OkLab -> OkLab -> OkLab
+lerpOkLab k (OkLab l2 a2 b2) (OkLab l1 a1 b1) =
+ OkLab (l1 + (l2 - l1) * k) (a1 + (a2 - a1) * k) (b1 + (b2 - b1) * k)
+
+-- | The colour on the opposite side of the colour wheel, with the same
+-- lightness.
+complementary :: Color -> Color
+complementary = mapOkLab (\(OkLab l a b) -> OkLab l (negate a) (negate b))
+
+-- | @mix t c1 c2@ is @c1@ at 0, @c2@ at 1, and in between otherwise;
+-- @t@ is clamped to [0, 1].
+-- Adaptive colours are mixed variant by variant: for each background and
+-- each profile, with the matching variant of the other colour.
+mix :: Double -> Color -> Color -> Color
+mix t c1 c2
+ | adaptive = LightDark (forBackground False) (forBackground True)
+ | otherwise = forBackground True
+ where
+ adaptive = hasLightDark c1 || hasLightDark c2
+ forBackground dark
+ | hasComplete c1 || hasComplete c2 =
+ Complete (at dark TrueColor) (at dark ANSI256) (at dark ANSI16)
+ | otherwise = at dark TrueColor
+ at dark p = fromOkLab (lerpOkLab (clamp01 t) (toOkLab (variant dark p c2)) (toOkLab (variant dark p c1)))
+
+-- | The concrete colour an adaptive one stands for on a background and
+-- profile.
+variant :: Bool -> ColorProfile -> Color -> Color
+variant dark p = \case
+ LightDark l d -> variant dark p (if dark then d else l)
+ Complete tc c256 c16 -> variant dark p $ case p of
+ TrueColor -> tc
+ ANSI256 -> c256
+ _ -> c16
+ c -> c
+
+hasLightDark, hasComplete :: Color -> Bool
+hasLightDark = \case
+ LightDark _ _ -> True
+ Complete a b c -> any hasLightDark [a, b, c]
+ _ -> False
+hasComplete = \case
+ Complete _ _ _ -> True
+ LightDark a b -> any hasComplete [a, b]
+ _ -> False
+
+-- | @blend n stops@ is a gradient of @n@ colours going evenly through the
+-- stops, starting at the first and ending at the last.
+blend :: Int -> [Color] -> [Color]
+blend n stops = case stops of
+ [] -> []
+ [c] -> replicate n c
+ _ | n <= 0 -> []
+ _ | n == 1 -> take 1 stops
+ _ -> [at (fromIntegral i / fromIntegral (n - 1)) | i <- [0 .. n - 1]]
+ where
+ segments = fromIntegral (length stops - 1) :: Double
+ at t =
+ let x = t * segments
+ i = min (length stops - 2) (floor x)
+ in mix (x - fromIntegral i) (stops !! i) (stops !! (i + 1))
+
+clamp01 :: Double -> Double
+clamp01 = max 0 . min 1
+
+-- | A concrete colour in OkLab. Callers pick the concrete colours out of an
+-- adaptive one first, with 'mapConcrete' or 'variant'.
+toOkLab :: Color -> OkLab
+toOkLab c = case c of
+ RGB r g b -> fromRGB r g b
+ Color256 n -> let (r, g, b) = termColorRGB (TC256 n) in fromRGB r g b
+ Color16 n -> let (r, g, b) = termColorRGB (TC16 n) in fromRGB r g b
+ _ -> error "Lipstick.Internal.Color.toOkLab: an adaptive colour"
+ where
+ fromRGB r g b =
+ let lr = linear r
+ lg = linear g
+ lb = linear b
+ l = cbrt (0.4122214708 * lr + 0.5363325363 * lg + 0.0514459929 * lb)
+ m = cbrt (0.2119034982 * lr + 0.6806995451 * lg + 0.1073969566 * lb)
+ s = cbrt (0.0883024619 * lr + 0.2817188376 * lg + 0.6299787005 * lb)
+ in OkLab
+ (0.2104542553 * l + 0.7936177850 * m - 0.0040720468 * s)
+ (1.9779984951 * l - 2.4285922050 * m + 0.4505937099 * s)
+ (0.0259040371 * l + 0.7827717662 * m - 0.8086757660 * s)
+ linear v =
+ let x = fromIntegral v / 255 :: Double
+ in if x <= 0.04045 then x / 12.92 else ((x + 0.055) / 1.055) ** 2.4
+ cbrt x = signum x * abs x ** (1 / 3)
+
+fromOkLab :: OkLab -> Color
+fromOkLab (OkLab ll a b) =
+ let l = cube (ll + 0.3963377774 * a + 0.2158037573 * b)
+ m = cube (ll - 0.1055613458 * a - 0.0638541728 * b)
+ s = cube (ll - 0.0894841775 * a - 1.2914855480 * b)
+ in RGB
+ (gamma (4.0767416621 * l - 3.3077115913 * m + 0.2309699292 * s))
+ (gamma (-1.2684380046 * l + 2.6097574011 * m - 0.3413193965 * s))
+ (gamma (-0.0041960863 * l - 0.7034186147 * m + 1.7076147010 * s))
+ where
+ cube x = x * x * x
+ gamma x =
+ let v = if x <= 0.0031308 then 12.92 * x else 1.055 * x ** (1 / 2.4) - 0.055
+ in round (255 * clamp01 v)
+
+-- | @blend2D width height angle stops@ is a two-dimensional gradient, as
+-- @height@ rows of @width@ colours, at least one each way (no rows
+-- without stops). The gradient runs through the stops along the
+-- direction given by the angle in degrees, anticlockwise as in lipgloss
+-- (0 is left to right, 90 bottom to top).
+blend2D :: Int -> Int -> Double -> [Color] -> [[Color]]
+blend2D w0 h0 angle stops = case stops of
+ [] -> []
+ [c] -> replicate h (replicate w c)
+ _ -> [[at x y | x <- [0 .. w - 1]] | y <- [0 .. h - 1]]
+ where
+ w = max 1 w0
+ h = max 1 h0
+ gradient = blend (max w h) stops
+ -- Without this, right angles pick up rounding noise (cos 270° is about
+ -- -1.8e-16) that can tip cells on a boundary into the wrong colour.
+ snap v = if abs v < 1e-9 then 0 else v
+ gradientLen = fromIntegral (length gradient - 1) :: Double
+ rad = angle * pi / 180
+ centreX = fromIntegral (w - 1) / 2
+ centreY = fromIntegral (h - 1) / 2
+ diagonal = sqrt (fromIntegral (w * w + h * h))
+ at x y =
+ let dx = fromIntegral x - centreX
+ dy = fromIntegral y - centreY
+ along = dx * snap (cos rad) - dy * snap (sin rad)
+ pos = clamp01 ((along + diagonal / 2) / diagonal)
+ in gradient !! min (length gradient - 1) (floor (pos * gradientLen))
diff --git a/internal/Lipstick/Internal/Grid.hs b/internal/Lipstick/Internal/Grid.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Grid.hs
@@ -0,0 +1,329 @@
+-- | The representation of rendered output, hidden from other packages: the
+-- public parts are re-exported by "Lipstick.Grid" and "Lipstick.Block".
+--
+-- A 'Grid' is a rectangle: every line is exactly 'gridWidth' columns
+-- wide and there are exactly 'gridHeight' lines. A line is a list of
+-- 'Cell's, one grapheme cluster each, so layout never segments text
+-- twice; output groups them into 'Span's with 'lineSpans'.
+module Lipstick.Internal.Grid
+ ( -- * Grids
+ Grid (..)
+ , Line (..)
+ , lineSpans
+ , Span (..)
+ , emptyGrid
+ , fromCellLines
+ , gridCells
+ , fitWidth
+ , joinGridsH
+ , joinGridsV
+
+ -- * Cells
+ , Cell (..)
+ , cellsWidth
+ , cellsLine
+ , blankCells
+ , fillCells
+ , alignCells
+ , cropCells
+ , wrapCells
+ , wrapCellsWith
+ , wordWidths
+ , truncateCells
+ , overCellAttrs
+ , underlay
+ , alignText
+
+ -- * Inline text
+ , Inline (..)
+ , plain
+ , inlineLines
+ , styledClusters
+ ) where
+
+import Data.Function (on)
+import Data.List (groupBy, transpose)
+import Data.String (IsString (..))
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick.Internal.Types
+import Lipstick.Internal.Width (clusters)
+
+-- | A laid-out block: a rectangle of lines, all of the same width.
+data Grid = Grid
+ { gridWidth :: !Int
+ , gridHeight :: !Int
+ , gridLines :: ![Line]
+ }
+ deriving (Eq, Show)
+
+-- | A line of a grid: a row of cells, one grapheme cluster each.
+data Line = Line
+ { lineWidth :: !Int
+ , lineCells :: ![Cell]
+ }
+ deriving (Eq, Show)
+
+-- | A run of clusters with the same attributes, for output. The text
+-- contains no newlines or control characters.
+data Span = Span
+ { spanAttrs :: !Attrs
+ -- ^ the attributes of every cluster in the run
+ , spanText :: !Text
+ -- ^ the clusters, one after another
+ , spanWidth :: !Int
+ -- ^ the width of the text, in columns
+ }
+ deriving (Eq, Show)
+
+-- | The runs of cells with the same attributes in a line.
+lineSpans :: Line -> [Span]
+lineSpans = map toSpan . groupBy ((==) `on` cellAttrs) . lineCells
+ where
+ toSpan grp = case grp of
+ c : _ -> Span (cellAttrs c) (T.concat (map cellText grp)) (cellsWidth grp)
+ [] -> Span mempty T.empty 0
+
+-- | One cluster occupying 'Lipstick.Grid.cellWidth' columns.
+data Cell = Cell
+ { cellAttrs :: !Attrs
+ , cellText :: !Text
+ , cellWidth :: !Int
+ , cellFill :: !Bool
+ -- ^ whitespace that aligns text: an enclosing style gives it only its
+ -- background (and reverse video), as it does for padding
+ }
+ deriving (Eq, Show)
+
+-- | The block with no lines.
+emptyGrid :: Grid
+emptyGrid = Grid 0 0 []
+
+-- | Build a block, padding lines on the right to the widest one.
+fromCellLines :: [[Cell]] -> Grid
+fromCellLines ls =
+ let w = maximum (0 : map cellsWidth ls)
+ in Grid w (length ls) [cellsLine (alignCells mempty left w l) | l <- ls]
+
+gridCells :: Grid -> [[Cell]]
+gridCells = map lineCells . gridLines
+
+-- | Exactly @w@ columns wide: lines are cropped, or padded on the right
+-- with unstyled blanks.
+fitWidth :: Int -> Grid -> Grid
+fitWidth w g
+ | gridWidth g == w = g
+ | otherwise = Grid w (gridHeight g) [cellsLine (alignCells mempty left w (cropCells w l)) | l <- gridCells g]
+
+-- | Grids side by side; the position aligns shorter ones vertically.
+joinGridsH :: Position -> [Grid] -> Grid
+joinGridsH p gs =
+ Grid (sum (map gridWidth gs)) h (map (cellsLine . concat) (transpose (map columnOf gs)))
+ where
+ h = maximum (0 : map gridHeight gs)
+ columnOf g =
+ let (before, after) = splitExtra p (h - gridHeight g)
+ blank = blankCells mempty (gridWidth g)
+ in replicate before blank ++ gridCells g ++ replicate after blank
+
+-- | Grids stacked in a column @w@ wide; the position aligns narrower ones
+-- horizontally. No grid may be wider than @w@.
+joinGridsV :: Position -> Int -> [Grid] -> Grid
+joinGridsV p w gs =
+ Grid w (sum (map gridHeight gs)) [cellsLine (alignCells mempty p w l) | g <- gs, l <- gridCells g]
+
+cellsWidth :: [Cell] -> Int
+cellsWidth = sum . map cellWidth
+
+cellsLine :: [Cell] -> Line
+cellsLine cs = Line (cellsWidth cs) cs
+
+blankCells :: Attrs -> Int -> [Cell]
+blankCells a n = replicate n (Cell a (T.singleton ' ') 1 False)
+
+-- | Exactly @n@ columns made by repeating the clusters of a text. Clusters
+-- that would overflow, and an empty text, give spaces instead. Zero-width
+-- clusters, control characters among them, are dropped.
+fillCells :: Attrs -> Text -> Int -> [Cell]
+fillCells a t n = case filter ((> 0) . snd) (clusters t) of
+ [] -> blankCells a n
+ cs -> go n (cycle cs)
+ where
+ go k ((c, w) : rest)
+ | k <= 0 = []
+ | w <= k = Cell a c w False : go (k - w) rest
+ go k _ = blankCells a k
+
+-- | Pad a line with blanks to @n@ columns, placing the content at a
+-- position. Lines already at least @n@ wide are unchanged.
+alignCells :: Attrs -> Position -> Int -> [Cell] -> [Cell]
+alignCells a p n cs =
+ let (before, after) = splitExtra p (n - cellsWidth cs)
+ in blankCells a before ++ cs ++ blankCells a after
+
+-- | Keep at most @n@ columns. A wide cluster cut by the edge is replaced by
+-- spaces, so the result is exactly @min n (cellsWidth cs)@ wide.
+cropCells :: Int -> [Cell] -> [Cell]
+cropCells n cs
+ | n <= 0 = []
+ | otherwise = case cs of
+ [] -> []
+ c : rest
+ | cellWidth c <= n -> c : cropCells (n - cellWidth c) rest
+ | otherwise -> blankCells (cellAttrs c) n
+
+-- | Greedy word wrap to @w@ columns. Spaces at a break are dropped; words
+-- longer than a line are broken. Leading spaces are kept as indentation
+-- when the first word fits after them.
+wrapCells :: Int -> [Cell] -> [[Cell]]
+wrapCells = wrapCellsWith []
+
+-- | Like 'wrapCells', also allowing a break after any of the given
+-- characters (such as @-@).
+wrapCellsWith :: [Char] -> Int -> [Cell] -> [[Cell]]
+wrapCellsWith breakpoints w0 cells
+ | cellsWidth cells <= w = [cells]
+ | otherwise = go [] 0 (wrapTokens breakpoints cells)
+ where
+ w = max 1 w0
+ isSpaceTok = all isSpaceCell
+
+ -- acc holds the current line's tokens in reverse.
+ go acc _ [] = [concat (reverse acc)]
+ go acc accW (t : ts)
+ | isSpaceTok t = case ts of
+ [] -> [concat (reverse acc)]
+ wd : ts' -> place acc accW t wd ts'
+ | otherwise = place acc accW [] t ts
+
+ place acc accW sp wd ts
+ | accW + cellsWidth sp + cellsWidth wd <= w = go (wd : sp : acc) (accW + cellsWidth sp + cellsWidth wd) ts
+ -- Indentation that does not fit with the first word is dropped, like
+ -- spaces at a break, unless the word is broken anyway.
+ | null acc = hard (if cellsWidth wd <= w then wd else sp ++ wd) ts
+ | otherwise = concat (reverse acc) : hard wd ts
+
+ -- Start a new line with a word, breaking it if it is too long.
+ hard wd ts =
+ let (full, lastPart) = chunks wd
+ in full ++ go [lastPart] (cellsWidth lastPart) ts
+
+ chunks cs =
+ let (line, rest) = takeWidth w cs
+ in if null rest then ([], line) else let (more, l) = chunks rest in (line : more, l)
+
+ takeWidth n cs = case cs of
+ c : rest
+ | cellWidth c <= n -> let (a, b) = takeWidth (n - cellWidth c) rest in (c : a, b)
+ | n == w -> ([c], rest) -- a cluster wider than the line: take it anyway
+ _ -> ([], cs)
+
+-- | The widths of the words of a line as 'wrapCellsWith' sees them; their
+-- maximum is the narrowest width that breaks no word.
+wordWidths :: [Char] -> [Cell] -> [Int]
+wordWidths breakpoints cs = [cellsWidth t | t <- wrapTokens breakpoints cs, not (all isSpaceCell t)]
+
+-- | A line cut into runs of spaces and words, words also ending after any
+-- of the break characters.
+wrapTokens :: [Char] -> [Cell] -> [[Cell]]
+wrapTokens breakpoints = concatMap splitAfterBreaks . groupBy ((==) `on` isSpaceCell)
+ where
+ isBreak c = T.length (cellText c) == 1 && T.head (cellText c) `elem` breakpoints
+ splitAfterBreaks tok
+ | all isSpaceCell tok = [tok]
+ | otherwise = case break isBreak tok of
+ (a, b : rest) | not (null rest) -> (a ++ [b]) : splitAfterBreaks rest
+ _ -> [tok]
+
+isSpaceCell :: Cell -> Bool
+isSpaceCell c = cellText c == T.singleton ' '
+
+-- | Cut a line to at most @w@ columns, ending with an ellipsis when
+-- something was cut.
+truncateCells :: Int -> [Cell] -> [Cell]
+truncateCells w cs
+ | cellsWidth cs <= w = cs
+ | w <= 0 = []
+ | otherwise =
+ let kept = cropCells (w - 1) cs
+ a = case reverse kept of
+ c : _ -> cellAttrs c
+ [] -> maybe mempty cellAttrs (safeHead cs)
+ in kept ++ [Cell a (T.singleton '…') 1 False]
+ where
+ safeHead xs = case xs of
+ x : _ -> Just x
+ [] -> Nothing
+
+overCellAttrs :: (Attrs -> Attrs) -> [[Cell]] -> [[Cell]]
+overCellAttrs f = map (map (\c -> c {cellAttrs = f (cellAttrs c)}))
+
+-- | Lay attributes under lines: the given ones under content, and the
+-- fill ones under the whitespace that aligns text.
+underlay :: Attrs -> Attrs -> [[Cell]] -> [[Cell]]
+underlay base fill = map (map under)
+ where
+ under c
+ | cellFill c = c {cellAttrs = fill <> cellAttrs c}
+ | otherwise = c {cellAttrs = base <> cellAttrs c}
+
+-- | Pad a line of text to @n@ columns at a position, with whitespace that
+-- enclosing styles treat as fill.
+alignText :: Position -> Int -> [Cell] -> [Cell]
+alignText p n cs =
+ let (before, after) = splitExtra p (n - cellsWidth cs)
+ gap k = replicate k (Cell mempty (T.singleton ' ') 1 True)
+ in gap before ++ cs ++ gap after
+
+-- | Text with inline styling, possibly spanning several lines.
+newtype Inline = Inline [(Attrs, Text)]
+ deriving (Eq, Show)
+ deriving newtype (Semigroup, Monoid)
+
+instance IsString Inline where
+ fromString = plain . T.pack
+
+-- | Text with no attributes of its own. String literals are 'plain'
+-- text.
+plain :: Text -> Inline
+plain t = Inline [(mempty, t)]
+
+-- | Split inline text into lines of cells. Tabs become @tabWidth@ spaces;
+-- other control characters, including escape sequences' ESC, and bidi
+-- embeddings, overrides and isolates are dropped.
+-- Use 'Lipstick.Ansi.fromAnsi' for text that contains escape sequences.
+inlineLines :: Int -> Inline -> [[Cell]]
+inlineLines tabWidth (Inline segs) = splitLines (styledClusters [(a, sanitise t) | (a, t) <- segs])
+ where
+ sanitise = T.filter isKept . T.replace (T.singleton '\t') (T.replicate tabWidth (T.singleton ' '))
+ -- Drop C0 and C1 controls (and DEL): they could start escape
+ -- sequences. Drop the bidi embeddings, overrides and isolates too: they
+ -- last to the end of the line, so in a terminal that reorders text one
+ -- left open would reverse what follows it, borders and blocks beside
+ -- included. The marks (LRM, RLM, ALM) affect only their neighbours and
+ -- stay.
+ isKept c = c == '\n' || (c >= ' ' && (c < '\DEL' || c > '\x9F') && not (isBidiControl c))
+ isBidiControl c = (c >= '\x202A' && c <= '\x202E') || (c >= '\x2066' && c <= '\x2069')
+ isNewline (_, c, _) = c == T.singleton '\n'
+ cells cs = [Cell a c w False | (a, c, w) <- cs]
+ splitLines xs = case break isNewline xs of
+ (cs, []) -> [cells cs]
+ (cs, _ : rest) -> cells cs : splitLines rest
+
+-- | The grapheme clusters of styled pieces of text, each with its width
+-- and the attributes of the piece its first character is in. Clusters are
+-- found in the text as a whole, as the terminal sees it, so one can span
+-- pieces: an emoji and its variation selector, say, styled separately.
+styledClusters :: [(Attrs, Text)] -> [(Attrs, Text, Int)]
+styledClusters segs =
+ go [(a, T.length t) | (a, t) <- segs, not (T.null t)] (clusters (T.concat (map snd segs)))
+ where
+ -- The pieces still to cover, with how many characters are left of the
+ -- first.
+ go pieces@((a, _) : _) ((c, w) : cs) = (a, c, w) : go (consume (T.length c) pieces) cs
+ go _ _ = []
+ consume k pieces = case pieces of
+ (a, n) : rest
+ | k < n -> (a, n - k) : rest
+ | otherwise -> consume (k - n) rest
+ [] -> []
diff --git a/internal/Lipstick/Internal/Layout.hs b/internal/Lipstick/Internal/Layout.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Layout.hs
@@ -0,0 +1,298 @@
+-- | Laying out blocks at a width, hidden from other packages: the public
+-- parts are re-exported by "Lipstick.Block".
+--
+-- A 'Block' is first given the text settings it inherits ('TextStyle'),
+-- which can change what it measures, and becomes a 'Measured'. A tree of
+-- nodes is laid out in one pass that goes down the tree and back up.
+-- Going up, every node reports a 'Request': its smallest and natural
+-- width, which depend only on its content, and, from 'blockLayout', its
+-- natural height at the width it was given. Going down, a parent shares
+-- its width among its children with 'allocateWithin' and tells children
+-- that stretch the height of their row, which it knows only once the
+-- same calls have reported their natural heights. Laziness resolves the
+-- apparent circle (see jaspervdj's
+-- [Lazy Layout](https://jaspervdj.be/posts/2023-07-22-lazy-layout.html)),
+-- as long as
+--
+-- * a 'Request' never depends on the 'Assign'ment, and
+-- * the natural height never depends on 'assignHeight'.
+--
+-- So the fields of 'Request' and 'Assign', and the result pair, must stay
+-- lazy.
+module Lipstick.Internal.Layout
+ ( -- * Blocks
+ Block (..)
+ , Measured (..)
+ , measureIn
+ , measure
+ , TextStyle (..)
+ , defTextStyle
+ , Request (..)
+ , Assign (..)
+ , layout
+ , layoutIn
+ , fromGrid
+ , emptyBlock
+ , textBlock
+ , cropLayoutWidth
+ , takenWidth
+ , addLimits
+ , maxLimit
+ , usableWidth
+
+ -- * Sharing out width
+ , allocate
+ , allocateWithin
+ ) where
+
+import Data.String (IsString (..))
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Types (Position, left)
+
+-- | Styled content that can be laid out at any width, once it knows the
+-- text settings it inherits.
+newtype Block = Block (TextStyle -> Measured)
+
+-- | A block with its inherited text settings applied.
+data Measured = Measured
+ { blockRequest :: Request
+ , blockLayout :: Assign -> (Grid, Int)
+ -- ^ the grid, exactly 'assignWidth' wide, and the natural height at
+ -- that width (the grid is taller only when the block stretches)
+ }
+
+-- | Text settings that nested text inherits, as in CSS: set on a style,
+-- they apply to all the text inside what it frames, unless something
+-- nearer sets them again. They are known before anything is measured,
+-- since some of them change widths.
+data TextStyle = TextStyle
+ { textAlign :: !Position
+ , textWrap :: !Bool
+ -- ^ wrap lines, or cut them short with an ellipsis
+ , textBreaks :: ![Char]
+ -- ^ characters to also break lines after
+ , textTabWidth :: !Int
+ , textTransform :: !(Maybe (Text -> Text))
+ , textInline :: !Bool
+ -- ^ newlines removed, never wrapped
+ }
+
+-- | Left-aligned, wrapping text, with each tab replaced by four spaces.
+defTextStyle :: TextStyle
+defTextStyle = TextStyle left True [] 4 Nothing False
+
+-- | A block in inherited text settings.
+measureIn :: TextStyle -> Block -> Measured
+measureIn ctx (Block f) = f ctx
+
+-- | A block in the default text settings.
+measure :: Block -> Measured
+measure = measureIn defTextStyle
+
+-- | What a block asks of its parent. Lazy, and independent of the
+-- assignment.
+data Request = Request
+ { reqMin :: Int
+ -- ^ the narrowest width that breaks no words
+ , reqMax :: Int
+ -- ^ the natural width: nothing wrapped
+ , reqGrow :: Int
+ -- ^ the weight for spare width; 0 for none
+ , reqLimit :: Maybe Int
+ -- ^ the most it can use when it grows; 'Nothing' for no limit
+ , reqStretch :: Bool
+ -- ^ whether the block grows to the height of its row
+ , reqFill :: Bool
+ -- ^ whether a box framing it gives it the whole inner width, so it
+ -- aligns its own lines (text), rather than only the width it takes, the
+ -- box aligning it as a whole (boxes, rows)
+ }
+
+-- | What a parent gives a block. Lazy: 'assignHeight' can depend on the
+-- natural heights the same layout reports.
+data Assign = Assign
+ { assignWidth :: Int
+ , assignHeight :: Int
+ -- ^ the height of the row, for blocks that stretch
+ }
+
+-- | Unstyled text, word-wrapped to the width it is given.
+instance IsString Block where
+ fromString = textBlock . plain . T.pack
+
+-- | Lay a block out in an available width: at its natural width, or, if
+-- it grows, at as much of the width as it can use (up to its
+-- 'Lipstick.Mod.maxWidth', say), but never wider than is available.
+-- With 'Nothing', at its natural width.
+layout :: Maybe Int -> Block -> Grid
+layout = layoutIn defTextStyle
+
+-- | Like 'layout', in inherited text settings.
+layoutIn :: TextStyle -> Maybe Int -> Block -> Grid
+layoutIn ctx avail b = fst (blockLayout n (Assign w 0))
+ where
+ n = measureIn ctx b
+ r = blockRequest n
+ w = maybe (reqMax r) (takenWidth r) avail
+
+-- | The width a block takes on its own in an available width: its natural
+-- width, or, if it grows, as much as its limit allows (but at least its
+-- natural width); never more than is available.
+takenWidth :: Request -> Int -> Int
+takenWidth r avail
+ | reqGrow r > 0 = maybe a (min a . max (reqMax r)) (reqLimit r)
+ | otherwise = min a (reqMax r)
+ where
+ a = max 0 avail
+
+-- | The most a row of blocks can use: the sum of what each can.
+addLimits :: [Request] -> Maybe Int
+addLimits rs = sum <$> traverse usableWidth rs
+
+-- | The most a column of blocks can use: what the widest can.
+maxLimit :: [Request] -> Maybe Int
+maxLimit rs = maximum . (0 :) <$> traverse usableWidth rs
+
+-- | The most a block can use: its natural width if it does not grow,
+-- otherwise its limit but at least its natural width; 'Nothing' for no
+-- limit.
+usableWidth :: Request -> Maybe Int
+usableWidth r
+ | reqGrow r > 0 = max (reqMax r) <$> reqLimit r
+ | otherwise = Just (reqMax r)
+
+-- | A grid as a block: cropped or padded to the width it is given. It
+-- inherits nothing.
+fromGrid :: Grid -> Block
+fromGrid g =
+ Block . const $
+ Measured
+ (Request (gridWidth g) (gridWidth g) 0 Nothing False False)
+ (\(Assign w _) -> (fitWidth w g, gridHeight g))
+
+-- | The block with no lines.
+emptyBlock :: Block
+emptyBlock = fromGrid emptyGrid
+
+-- | Inline text, laid out in the text settings it inherits: word-wrapped
+-- to the width it is given (or cut short with an ellipsis), each line
+-- aligned in it.
+textBlock :: Inline -> Block
+textBlock inl = Block $ \ctx ->
+ let ls0 = case textTransform ctx of
+ -- Shared by every layout in the common case, so text is segmented
+ -- once however often the block is laid out.
+ Nothing | textTabWidth ctx == textTabWidth defTextStyle -> defaultLines
+ Nothing -> inlineLines (textTabWidth ctx) inl
+ Just f -> let Inline segs = inl in inlineLines (textTabWidth ctx) (Inline [(a, f t) | (a, t) <- segs])
+ ls = if textInline ctx then [concat ls0] else ls0
+ hi = maximum (0 : map cellsWidth ls)
+ lo
+ | textWrap ctx && not (textInline ctx) = maximum (0 : concatMap (wordWidths (textBreaks ctx)) ls)
+ | otherwise = hi
+ run (Assign w _) =
+ let fitted
+ | textInline ctx = map (cropCells w) ls
+ -- With no room at all, text is cut rather than wrapped one
+ -- cluster a line, so that it does not grow tall for nothing.
+ | textWrap ctx && w > 0 = concatMap (wrapCellsWith (textBreaks ctx) w) ls
+ | otherwise = map (truncateCells w) ls
+ in (Grid w (length fitted) [cellsLine (cropCells w (alignText (textAlign ctx) w l)) | l <- fitted], length fitted)
+ in Measured (Request lo hi 0 Nothing False True) run
+ where
+ defaultLines = inlineLines (textTabWidth defTextStyle) inl
+
+-- | The width to lay out something with a 'Lipstick.Mod.maxWidth' crop
+-- at, before cropping, given the crop, its weight for spare width, its
+-- natural width and the width @w@ it is given. When the crop, not @w@, is
+-- the binding limit, something that grows is laid out at the crop width,
+-- so it fills up to it, and anything else at least at its natural width,
+-- so the crop cuts lines instead of making text wrap. Otherwise it is
+-- laid out at @w@.
+cropLayoutWidth :: Maybe Int -> Int -> Int -> Int -> Int
+cropLayoutWidth crop weight natural w = case crop of
+ Just c
+ | w >= max 0 c -> if weight > 0 then max 0 c else max w natural
+ _ -> w
+
+-- | Share out the columns of a row among its children, given each child's
+-- smallest and natural width and its weight for spare space.
+--
+-- * When every child fits at its natural width, each gets it, and the
+-- rest goes to the children with a weight, in proportion (left ones
+-- first for what does not divide evenly). Without weights the row is
+-- narrower than the space.
+--
+-- * Otherwise the widest children shrink first, towards their smallest
+-- width: every child ends up at its natural width or at a common level,
+-- whichever is less.
+--
+-- * When even the smallest widths do not fit, the widest children shrink
+-- further, down to one column (zero for children whose smallest width
+-- is zero), and the result is wider than the space only if that is
+-- still too much.
+--
+-- The widths add up to the space whenever the bounds allow it.
+allocate :: Int -> [(Int, Int, Int)] -> [Int]
+allocate space children = allocateWithin space [(lo, hi, k, Nothing) | (lo, hi, k) <- children]
+
+-- | Like 'allocate', with the most each child can use when it grows
+-- ('Nothing' for no limit): what a child cannot use goes to the others.
+allocateWithin :: Int -> [(Int, Int, Int, Maybe Int)] -> [Int]
+allocateWithin space children
+ | sum his <= w = growWithin (w - sum his) [(hi, max 0 k, l) | (hi, (_, _, k, l)) <- zip his children]
+ | sum los <= w = level los his
+ | otherwise = level floors los
+ where
+ w = max 0 space
+ los = [max 0 lo | (lo, _, _, _) <- children]
+ his = [max lo hi | (lo, (_, hi, _, _)) <- zip los children]
+ floors = map (min 1) los
+
+ -- Share out spare columns by weight. Children that reach their limit
+ -- keep it and drop out, and the rest is shared again.
+ growWithin extra cs
+ | extra <= 0 || total == 0 = [x | (x, _, _) <- cs]
+ | or full = growWithin (extra - sum used) [if f then (x + u, 0, l) else c | (c@(x, _, l), f, u) <- zip3 cs full used]
+ | otherwise = zipWith3 (\(x, _, _) sh b -> x + sh + b) cs shares (ones (extra - sum shares) (map open cs))
+ where
+ open (x, k, l) = k > 0 && maybe True (> x) l
+ total = sum [k | c@(_, k, _) <- cs, open c]
+ shares = [if open c then extra * k `div` total else 0 | c@(_, k, _) <- cs]
+ room (x, _, l) = maybe maxBound (subtract x) l
+ full = [open c && sh >= room c | (c, sh) <- zip cs shares]
+ used = [if f then room c else 0 | (c, f) <- zip cs full]
+
+ -- Every child at @clamp lo hi t@ for the highest level @t@ that fits;
+ -- the columns left over go to the children cut at the level, right
+ -- ones first: that is where shrinking the widest child one column at
+ -- a time, leftmost on ties, would leave them, and the tests check
+ -- that the two agree.
+ level lows highs
+ | sum lows >= w = lows
+ | otherwise =
+ let t = search 0 (maximum (0 : highs))
+ ws = [clamp lo hi t | (lo, hi) <- zip lows highs]
+ spare = w - sum ws
+ cut = [hi > t && lo <= t | (lo, hi) <- zip lows highs]
+ in zipWith (+) ws (reverse (ones spare (reverse cut)))
+ where
+ total t = sum [clamp lo hi t | (lo, hi) <- zip lows highs]
+ -- The highest t in [lo, hi] with total t <= w; total lo <= w.
+ search lo hi
+ | lo >= hi = lo
+ | otherwise =
+ let mid = (lo + hi + 1) `div` 2
+ in if total mid <= w then search mid hi else search lo (mid - 1)
+
+ clamp lo hi = max lo . min hi
+
+ -- 1 at the first n positions that are True, 0 elsewhere.
+ ones :: Int -> [Bool] -> [Int]
+ ones n bs = case bs of
+ b : rest
+ | b && n > 0 -> 1 : ones (n - 1) rest
+ | otherwise -> 0 : ones n rest
+ [] -> []
diff --git a/internal/Lipstick/Internal/Mod.hs b/internal/Lipstick/Internal/Mod.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Mod.hs
@@ -0,0 +1,673 @@
+-- | The representation of modifiers and the records they change, and the
+-- modifiers themselves. Hidden: the public API is "Lipstick.Mod".
+--
+-- A @'Mod' f@ is two changes: one to the fields of the thing @f@, and one
+-- to the 'Props' every thing has. "Lipstick.Mod" explains how they are used.
+module Lipstick.Internal.Mod
+ ( Mod (..)
+ , fieldMod
+ , propMod
+ , runMod
+ , appMod
+
+ -- * Properties of every thing
+ , Props (..)
+ , defProps
+ , propsOf
+ , withProps
+ , cropToProps
+
+ -- * Components
+ , HasBox (..)
+ , HasBorder (..)
+ , HasSize (..)
+ , HasAlign (..)
+ , HasWrap (..)
+ , HasCrop
+ , Sides (..)
+ , uniformSides
+ , Box (..)
+ , defBox
+ , BorderProps (..)
+ , defBorderProps
+ , Edges (..)
+ , borderEdges
+ , blendBorder
+ , Size (..)
+ , defSize
+ , Align (..)
+ , defAlign
+
+ -- * Text attributes
+ , bold
+ , faint
+ , italic
+ , blink
+ , reverseVideo
+ , strikethrough
+ , flag
+ , unsetFlag
+ , underline
+ , underlineStyle
+ , underlineColor
+ , fg
+ , bg
+ , unsetFg
+ , unsetBg
+ , unsetUnderline
+ , unsetUnderlineColor
+ , link
+ , unsetLink
+
+ -- * Padding and margins
+ , padding
+ , paddingAll
+ , paddingTop
+ , paddingRight
+ , paddingBottom
+ , paddingLeft
+ , margin
+ , marginAll
+ , marginTop
+ , marginRight
+ , marginBottom
+ , marginLeft
+ , marginBg
+ , paddingChar
+ , marginChar
+ , unsetPadding
+ , unsetMargins
+ , unsetMarginBg
+
+ -- * Borders
+ , border
+ , borderFg
+ , borderBg
+ , borderFgBlend
+ , borderFgBlendOffset
+ , borderTopFg
+ , borderRightFg
+ , borderBottomFg
+ , borderLeftFg
+ , borderTopBg
+ , borderRightBg
+ , borderBottomBg
+ , borderLeftBg
+ , unsetBorder
+ , borderTop
+ , borderRight
+ , borderBottom
+ , borderLeft
+
+ -- * Size
+ , width
+ , height
+ , maxWidth
+ , maxHeight
+ , grow
+ , fillWidth
+ , stretchHeight
+ , unsetWidth
+ , unsetHeight
+ , unsetMaxWidth
+ , unsetMaxHeight
+
+ -- * Alignment
+ , align
+ , valign
+ , unsetAlign
+
+ -- * Wrapping
+ , noWrap
+ , unsetNoWrap
+ ) where
+
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+import Lipstick.Internal.Border (Border, normalBorder)
+import Lipstick.Internal.Color (Color, blend)
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Types
+
+-- | A modification of a thing @f@: of its own fields, and of the
+-- properties every thing has. '<>' applies the left modifier first, so
+-- settings on the right win.
+data Mod f = Mod (f -> f) (Props -> Props)
+
+instance Semigroup (Mod f) where
+ Mod f1 g1 <> Mod f2 g2 = Mod (f2 . f1) (g2 . g1)
+
+instance Monoid (Mod f) where
+ mempty = Mod id id
+
+-- | A modifier of the thing's own fields.
+fieldMod :: (f -> f) -> Mod f
+fieldMod f = Mod f id
+
+-- | A modifier of the properties every thing has.
+propMod :: (Props -> Props) -> Mod f
+propMod = Mod id
+
+-- | Apply a modifier to a thing's defaults.
+runMod :: Mod f -> f -> (f, Props)
+runMod (Mod f g) x = (f x, g defProps)
+
+-- | Apply only the field part of a modifier.
+appMod :: Mod f -> f -> f
+appMod (Mod f _) = f
+
+-- | Properties every thing has.
+data Props = Props
+ { propAttrs :: !Attrs
+ -- ^ base text attributes for everything the thing draws
+ , propMaxWidth :: !(Maybe Int)
+ , propMaxHeight :: !(Maybe Int)
+ }
+ deriving (Eq, Show)
+
+defProps :: Props
+defProps = Props mempty Nothing Nothing
+
+-- | The common properties a modifier sets, starting from the defaults.
+propsOf :: Mod f -> Props
+propsOf (Mod _ g) = g defProps
+
+-- | What most builders do with the properties: lay the attributes under
+-- everything, then crop.
+withProps :: Props -> [[Cell]] -> Grid
+withProps p = cropToProps p . underlay (propAttrs p) (fillAttrs (propAttrs p))
+
+-- | Crop lines to 'maxWidth' and 'maxHeight'.
+cropToProps :: Props -> [[Cell]] -> Grid
+cropToProps p ls =
+ let croppedW = maybe ls (\n -> map (cropCells n) ls) (propMaxWidth p)
+ in fromCellLines (maybe croppedW (`take` croppedW) (propMaxHeight p))
+
+-- | Things with padding and margins: 'Lipstick.Style.Style'. The
+-- modifiers 'padding', 'margin', 'marginBg', 'paddingChar', 'marginChar'
+-- and their variants apply to them.
+class HasBox f where
+ overBox :: (Box -> Box) -> f -> f
+
+-- | Things with a border: 'Lipstick.Style.Style' and
+-- 'Lipstick.Table.Table'. The modifiers 'border', 'borderFg', 'borderTop'
+-- and the other border modifiers apply to them.
+class HasBorder f where
+ overBorder :: (BorderProps -> BorderProps) -> f -> f
+
+-- | Things with a size: 'Lipstick.Style.Style', 'Lipstick.Table.Table',
+-- 'Lipstick.Outline.Outline' and 'Lipstick.Place.Place'. The modifiers
+-- 'width', 'height', 'grow', 'fillWidth', 'stretchHeight', 'unsetWidth' and
+-- 'unsetHeight' apply to them. ('maxWidth' and 'maxHeight' work on
+-- anything.)
+class HasSize f where
+ overSize :: (Size -> Size) -> f -> f
+
+-- | Things whose content can be aligned: 'Lipstick.Style.Style' and
+-- 'Lipstick.Place.Place'. The modifiers 'align', 'valign' and 'unsetAlign'
+-- apply to them.
+class HasAlign f where
+ overAlign :: (Align -> Align) -> f -> f
+
+-- | Things whose text can be wrapped: 'Lipstick.Style.Style' and
+-- 'Lipstick.Table.Table'. The modifiers 'noWrap' and 'unsetNoWrap' apply
+-- to them.
+class HasWrap f where
+ overWrap :: (Bool -> Bool) -> f -> f
+
+-- | Things whose result can be cropped: every thing but
+-- 'Lipstick.Block.Inline', whose text is laid out with the text around it.
+-- The modifiers 'maxWidth', 'maxHeight', 'unsetMaxWidth' and
+-- 'unsetMaxHeight' apply to them.
+class HasCrop f
+
+-- | One value for each side: top, right, bottom and left, as in CSS.
+data Sides a = Sides {sideTop, sideRight, sideBottom, sideLeft :: !a}
+ deriving (Eq, Show, Functor)
+
+uniformSides :: a -> Sides a
+uniformSides a = Sides a a a a
+
+data Box = Box
+ { boxPadding :: !(Sides Int)
+ , boxMargin :: !(Sides Int)
+ , boxMarginBg :: !(Maybe Color)
+ , boxPaddingChar :: !Char
+ , boxMarginChar :: !Char
+ }
+ deriving (Eq, Show)
+
+defBox :: Box
+defBox = Box (uniformSides 0) (uniformSides 0) Nothing ' ' ' '
+
+data BorderProps = BorderProps
+ { borderChars :: !(Maybe Border)
+ , borderSides :: !(Sides (Maybe Bool))
+ , borderFgColors :: !(Sides (Maybe Color))
+ , borderBgColors :: !(Sides (Maybe Color))
+ , borderFgStops :: ![Color]
+ -- ^ when not empty, a gradient that replaces 'borderFgColors'
+ , borderFgOffset :: !Int
+ -- ^ how many cells the gradient is rotated clockwise
+ }
+ deriving (Eq, Show)
+
+defBorderProps :: BorderProps
+defBorderProps = BorderProps Nothing (uniformSides Nothing) (uniformSides Nothing) (uniformSides Nothing) [] 0
+
+-- | Which sides of a border are drawn.
+data Edges = Edges {edgeTop, edgeRight, edgeBottom, edgeLeft :: !Bool}
+ deriving (Eq, Show)
+
+-- | The characters to draw a border with, and the sides to draw. A side
+-- left as 'Nothing' is drawn only when the characters are set; without
+-- characters, sides switched on explicitly use 'normalBorder'.
+borderEdges :: BorderProps -> (Border, Edges)
+borderEdges p =
+ let on side = fromMaybe (isJust (borderChars p)) (side (borderSides p))
+ in ( fromMaybe normalBorder (borderChars p)
+ , Edges (on sideTop) (on sideRight) (on sideBottom) (on sideLeft)
+ )
+
+-- | Recolour the border cells with a gradient, clockwise from the top-left
+-- and rotated clockwise by an offset. The rows are the bordered box; @nl@
+-- and @nr@ are the number of cells in the left and right border columns.
+blendBorder :: [Color] -> Int -> Edges -> Int -> Int -> [[Cell]] -> [[Cell]]
+blendBorder [] _ _ _ _ rows = rows
+blendBorder stops offset edges nl nr rows =
+ let (topRows, rest) = splitAt (if edgeTop edges then 1 else 0) rows
+ (middleRows, bottomRows) = splitAt (length rest - (if edgeBottom edges then 1 else 0)) rest
+ n = sum (map length topRows) + length middleRows * (nr + nl) + sum (map length bottomRows)
+ colors = rotate offset (blend n stops)
+ (cTop, c1) = splitAt (sum (map length topRows)) colors
+ (cRight, c2) = splitAt (length middleRows * nr) c1
+ (cBottom, cLeft) = splitAt (sum (map length bottomRows)) c2
+ paint cs cells = zipWith (\c cell -> cell {cellAttrs = (cellAttrs cell) {attrFg = Just c}}) cs cells
+ rightCols = chunks nr cRight
+ leftCols = reverse (chunks nl cLeft)
+ middle' =
+ [ let (l, rest') = splitAt nl row
+ (inner, r) = splitAt (length rest' - nr) rest'
+ in paint (reverse lc) l ++ inner ++ paint rc r
+ | (row, lc, rc) <- zip3 middleRows (leftCols ++ repeat []) (rightCols ++ repeat [])
+ ]
+ in [paint cTop row | row <- topRows]
+ ++ middle'
+ ++ [reverse (paint cBottom (reverse row)) | row <- bottomRows]
+ where
+ rotate k xs
+ | null xs = xs
+ | otherwise = let r = length xs - k `mod` length xs in drop r xs ++ take r xs
+ chunks k xs
+ | k <= 0 = []
+ | null xs = []
+ | otherwise = let (a, b) = splitAt k xs in a : chunks k b
+
+-- | Width and height include padding and border, but not margins.
+data Size = Size
+ { sizeWidth :: !(Maybe Int)
+ , sizeHeight :: !(Maybe Int)
+ , sizeGrow :: !Int
+ -- ^ weight for spare width; 0 for none
+ , sizeStretch :: !Bool
+ -- ^ grow to the height of the row
+ }
+ deriving (Eq, Show)
+
+defSize :: Size
+defSize = Size Nothing Nothing 0 False
+
+data Align = Align
+ { alignH :: !Position
+ , alignV :: !Position
+ }
+ deriving (Eq, Show)
+
+defAlign :: Align
+defAlign = Align left top
+
+-- Text attributes -------------------------------------------------------------
+
+attrsMod :: (Attrs -> Attrs) -> Mod f
+attrsMod g = propMod (\p -> p {propAttrs = g (propAttrs p)})
+
+-- | Bold text.
+bold :: Mod f
+bold = flag Bold True
+
+-- | Faint (dim) text.
+faint :: Mod f
+faint = flag Faint True
+
+-- | Italic text.
+italic :: Mod f
+italic = flag Italic True
+
+-- | Blinking text.
+blink :: Mod f
+blink = flag Blink True
+
+-- | Swap the foreground and background colours.
+reverseVideo :: Mod f
+reverseVideo = flag Reverse True
+
+-- | Text with a line through it.
+strikethrough :: Mod f
+strikethrough = flag Strikethrough True
+
+-- | Set a flag explicitly; @flag Bold False@ turns off bold inherited from
+-- an enclosing style.
+flag :: Flag -> Bool -> Mod f
+flag f v = attrsMod (setFlag f (Just v))
+
+-- | Forget a flag, so an enclosing style's setting shows through.
+unsetFlag :: Flag -> Mod f
+unsetFlag f = attrsMod (setFlag f Nothing)
+
+-- | A single underline: @underlineStyle SingleUnderline@.
+underline :: Mod f
+underline = underlineStyle SingleUnderline
+
+-- | The kind of underline. Double, curly, dotted and dashed underlines are
+-- sent only to true-colour terminals; on other profiles they are shown as
+-- a single underline.
+underlineStyle :: Underline -> Mod f
+underlineStyle u = attrsMod (\a -> a {attrUnderline = Just u})
+
+-- | The colour of the underline, when there is one. It is printed only
+-- for the 256-colour and true-colour profiles.
+underlineColor :: Color -> Mod f
+underlineColor c = attrsMod (\a -> a {attrUnderlineColor = Just c})
+
+-- | The foreground (text) colour.
+fg :: Color -> Mod f
+fg c = attrsMod (\a -> a {attrFg = Just c})
+
+-- | The background colour.
+bg :: Color -> Mod f
+bg c = attrsMod (\a -> a {attrBg = Just c})
+
+-- | Forget the foreground colour, so an enclosing style's shows through.
+unsetFg :: Mod f
+unsetFg = attrsMod (\a -> a {attrFg = Nothing})
+
+-- | Forget the background colour, so an enclosing style's shows through.
+unsetBg :: Mod f
+unsetBg = attrsMod (\a -> a {attrBg = Nothing})
+
+-- | Forget the underline, so an enclosing style's shows through.
+unsetUnderline :: Mod f
+unsetUnderline = attrsMod (\a -> a {attrUnderline = Nothing})
+
+-- | Forget the underline colour, so an enclosing style's shows through.
+unsetUnderlineColor :: Mod f
+unsetUnderlineColor = attrsMod (\a -> a {attrUnderlineColor = Nothing})
+
+-- | Make the text a hyperlink (OSC 8).
+link :: Text -> Mod f
+link url = attrsMod (\a -> a {attrLink = Just url})
+
+-- | Forget the hyperlink, so an enclosing style's shows through.
+unsetLink :: Mod f
+unsetLink = attrsMod (\a -> a {attrLink = Nothing})
+
+-- Padding and margins ---------------------------------------------------------
+
+paddingMod :: HasBox f => (Sides Int -> Sides Int) -> Mod f
+paddingMod g = fieldMod (overBox (\b -> b {boxPadding = fmap (max 0) (g (boxPadding b))}))
+
+marginMod :: HasBox f => (Sides Int -> Sides Int) -> Mod f
+marginMod g = fieldMod (overBox (\b -> b {boxMargin = fmap (max 0) (g (boxMargin b))}))
+
+-- | @padding vertical horizontal@. Negative amounts count as 0, as for
+-- all padding and margins.
+padding :: HasBox f => Int -> Int -> Mod f
+padding v h = paddingMod (const (Sides v h v h))
+
+-- | The same padding on all four sides.
+paddingAll :: HasBox f => Int -> Mod f
+paddingAll n = paddingMod (const (uniformSides n))
+
+-- | Padding above the content, in lines.
+paddingTop :: HasBox f => Int -> Mod f
+paddingTop n = paddingMod (\s -> s {sideTop = n})
+
+-- | Padding to the right of the content, in columns.
+paddingRight :: HasBox f => Int -> Mod f
+paddingRight n = paddingMod (\s -> s {sideRight = n})
+
+-- | Padding below the content, in lines.
+paddingBottom :: HasBox f => Int -> Mod f
+paddingBottom n = paddingMod (\s -> s {sideBottom = n})
+
+-- | Padding to the left of the content, in columns.
+paddingLeft :: HasBox f => Int -> Mod f
+paddingLeft n = paddingMod (\s -> s {sideLeft = n})
+
+-- | @margin vertical horizontal@
+margin :: HasBox f => Int -> Int -> Mod f
+margin v h = marginMod (const (Sides v h v h))
+
+-- | The same margin on all four sides.
+marginAll :: HasBox f => Int -> Mod f
+marginAll n = marginMod (const (uniformSides n))
+
+-- | The margin above the box, in lines.
+marginTop :: HasBox f => Int -> Mod f
+marginTop n = marginMod (\s -> s {sideTop = n})
+
+-- | The margin to the right of the box, in columns.
+marginRight :: HasBox f => Int -> Mod f
+marginRight n = marginMod (\s -> s {sideRight = n})
+
+-- | The margin below the box, in lines.
+marginBottom :: HasBox f => Int -> Mod f
+marginBottom n = marginMod (\s -> s {sideBottom = n})
+
+-- | The margin to the left of the box, in columns.
+marginLeft :: HasBox f => Int -> Mod f
+marginLeft n = marginMod (\s -> s {sideLeft = n})
+
+-- | Background colour of the margins.
+marginBg :: HasBox f => Color -> Mod f
+marginBg c = fieldMod (overBox (\b -> b {boxMarginBg = Just c}))
+
+-- | No padding on any side.
+unsetPadding :: HasBox f => Mod f
+unsetPadding = paddingMod (const (uniformSides 0))
+
+-- | No margins on any side.
+unsetMargins :: HasBox f => Mod f
+unsetMargins = marginMod (const (uniformSides 0))
+
+-- | Forget the 'marginBg': the margins have no background colour of
+-- their own.
+unsetMarginBg :: HasBox f => Mod f
+unsetMarginBg = fieldMod (overBox (\b -> b {boxMarginBg = Nothing}))
+
+-- | The character padding is filled with (default a space).
+paddingChar :: HasBox f => Char -> Mod f
+paddingChar c = fieldMod (overBox (\b -> b {boxPaddingChar = c}))
+
+-- | The character margins are filled with (default a space).
+marginChar :: HasBox f => Char -> Mod f
+marginChar c = fieldMod (overBox (\b -> b {boxMarginChar = c}))
+
+-- Borders ---------------------------------------------------------------------
+
+borderMod :: HasBorder f => (BorderProps -> BorderProps) -> Mod f
+borderMod = fieldMod . overBorder
+
+-- | Draw a border with these characters, on all sides not switched off.
+border :: HasBorder f => Border -> Mod f
+border b = borderMod (\p -> p {borderChars = Just b})
+
+-- | The colour of the whole border. It replaces a 'borderFgBlend'
+-- gradient.
+borderFg :: HasBorder f => Color -> Mod f
+borderFg c = borderMod (\p -> p {borderFgColors = uniformSides (Just c), borderFgStops = []})
+
+-- | The background colour of the whole border.
+borderBg :: HasBorder f => Color -> Mod f
+borderBg c = borderMod (\p -> p {borderBgColors = uniformSides (Just c)})
+
+-- | The colour of the top side of the border, corners included. Like
+-- every side colour, it replaces a 'borderFgBlend' gradient.
+borderTopFg :: HasBorder f => Color -> Mod f
+borderTopFg c = borderFgSide (\s -> s {sideTop = Just c})
+
+-- | The colour of the right side of the border, without the corners.
+borderRightFg :: HasBorder f => Color -> Mod f
+borderRightFg c = borderFgSide (\s -> s {sideRight = Just c})
+
+-- | The colour of the bottom side of the border, corners included.
+borderBottomFg :: HasBorder f => Color -> Mod f
+borderBottomFg c = borderFgSide (\s -> s {sideBottom = Just c})
+
+-- | The colour of the left side of the border, without the corners.
+borderLeftFg :: HasBorder f => Color -> Mod f
+borderLeftFg c = borderFgSide (\s -> s {sideLeft = Just c})
+
+-- | The background colour of the top side of the border, corners
+-- included.
+borderTopBg :: HasBorder f => Color -> Mod f
+borderTopBg c = borderBgSide (\s -> s {sideTop = Just c})
+
+-- | The background colour of the right side of the border, without the
+-- corners.
+borderRightBg :: HasBorder f => Color -> Mod f
+borderRightBg c = borderBgSide (\s -> s {sideRight = Just c})
+
+-- | The background colour of the bottom side of the border, corners
+-- included.
+borderBottomBg :: HasBorder f => Color -> Mod f
+borderBottomBg c = borderBgSide (\s -> s {sideBottom = Just c})
+
+-- | The background colour of the left side of the border, without the
+-- corners.
+borderLeftBg :: HasBorder f => Color -> Mod f
+borderLeftBg c = borderBgSide (\s -> s {sideLeft = Just c})
+
+borderFgSide, borderBgSide :: HasBorder f => (Sides (Maybe Color) -> Sides (Maybe Color)) -> Mod f
+borderFgSide g = borderMod (\p -> p {borderFgColors = g (borderFgColors p), borderFgStops = []})
+borderBgSide g = borderMod (\p -> p {borderBgColors = g (borderBgColors p)})
+
+-- | Rotate a 'borderFgBlend' gradient clockwise by this many cells
+-- (anticlockwise if negative).
+borderFgBlendOffset :: HasBorder f => Int -> Mod f
+borderFgBlendOffset n = borderMod (\p -> p {borderFgOffset = n})
+
+-- | No border, and no border colours.
+unsetBorder :: HasBorder f => Mod f
+unsetBorder = borderMod (const defBorderProps)
+
+-- | Colour the border with a gradient through these colours, going
+-- clockwise from the top-left corner.
+borderFgBlend :: HasBorder f => [Color] -> Mod f
+borderFgBlend cs = borderMod (\p -> p {borderFgStops = cs})
+
+-- | Whether the top side of the border is drawn. By default a side is
+-- drawn when a 'border' is set; switched on without one, it is drawn with
+-- 'normalBorder'.
+borderTop :: HasBorder f => Bool -> Mod f
+borderTop v = borderSide (\s -> s {sideTop = Just v})
+
+-- | Whether the right side of the border is drawn, as for 'borderTop'.
+borderRight :: HasBorder f => Bool -> Mod f
+borderRight v = borderSide (\s -> s {sideRight = Just v})
+
+-- | Whether the bottom side of the border is drawn, as for 'borderTop'.
+borderBottom :: HasBorder f => Bool -> Mod f
+borderBottom v = borderSide (\s -> s {sideBottom = Just v})
+
+-- | Whether the left side of the border is drawn, as for 'borderTop'.
+borderLeft :: HasBorder f => Bool -> Mod f
+borderLeft v = borderSide (\s -> s {sideLeft = Just v})
+
+borderSide :: HasBorder f => (Sides (Maybe Bool) -> Sides (Maybe Bool)) -> Mod f
+borderSide g = borderMod (\p -> p {borderSides = g (borderSides p)})
+
+-- Size ------------------------------------------------------------------------
+
+sizeMod :: HasSize f => (Size -> Size) -> Mod f
+sizeMod = fieldMod . overSize
+
+-- | @width n@: a total width of @n@ columns when there is room for it.
+-- Laid out in less space (a narrow terminal, a full row), the thing
+-- shrinks like any other rather than overflowing. For a style, the width
+-- includes padding and border, but not margins. A negative width counts
+-- as 0, as do negative heights and crops.
+width :: HasSize f => Int -> Mod f
+width n = sizeMod (\s -> s {sizeWidth = Just (max 0 n)})
+
+-- | @height n@: the thing is at least @n@ lines tall. For a style, the
+-- height includes padding and border, but not margins.
+height :: HasSize f => Int -> Mod f
+height n = sizeMod (\s -> s {sizeHeight = Just (max 0 n)})
+
+-- | Take a share of the spare width, in proportion to the weight, when the
+-- thing is laid out next to others or on its own in the output's width.
+-- With a 'width', that width is the least it takes.
+grow :: HasSize f => Int -> Mod f
+grow k = sizeMod (\s -> s {sizeGrow = max 0 k})
+
+-- | Fill the width available: @grow 1@.
+fillWidth :: HasSize f => Mod f
+fillWidth = grow 1
+
+-- | Grow to the height of the row the thing is in (as the tallest thing
+-- next to it).
+stretchHeight :: HasSize f => Mod f
+stretchHeight = sizeMod (\s -> s {sizeStretch = True})
+
+-- | Crop the final result (for a style, margins included) to at most this
+-- many columns.
+maxWidth :: HasCrop f => Int -> Mod f
+maxWidth n = propMod (\p -> p {propMaxWidth = Just (max 0 n)})
+
+-- | Crop the final result (for a style, margins included) to at most this
+-- many lines. A table leaves out the body rows that do not fit instead,
+-- with a row of ellipses in their place where there is room for it (see
+-- 'Lipstick.Table.yOffset').
+maxHeight :: HasCrop f => Int -> Mod f
+maxHeight n = propMod (\p -> p {propMaxHeight = Just (max 0 n)})
+
+-- | Forget the 'width'.
+unsetWidth :: HasSize f => Mod f
+unsetWidth = sizeMod (\s -> s {sizeWidth = Nothing})
+
+-- | Forget the 'height'.
+unsetHeight :: HasSize f => Mod f
+unsetHeight = sizeMod (\s -> s {sizeHeight = Nothing})
+
+-- | Forget the 'maxWidth': no crop to a width.
+unsetMaxWidth :: HasCrop f => Mod f
+unsetMaxWidth = propMod (\p -> p {propMaxWidth = Nothing})
+
+-- | Forget the 'maxHeight': no crop to a height.
+unsetMaxHeight :: HasCrop f => Mod f
+unsetMaxHeight = propMod (\p -> p {propMaxHeight = Nothing})
+
+-- Alignment -------------------------------------------------------------------
+
+-- | Horizontal alignment.
+align :: HasAlign f => Position -> Mod f
+align p = fieldMod (overAlign (\a -> a {alignH = p}))
+
+-- | Vertical alignment.
+valign :: HasAlign f => Position -> Mod f
+valign p = fieldMod (overAlign (\a -> a {alignV = p}))
+
+-- | Back to the default alignment, 'left' and 'top'.
+unsetAlign :: HasAlign f => Mod f
+unsetAlign = fieldMod (overAlign (const defAlign))
+
+-- Wrapping --------------------------------------------------------------------
+
+-- | Cut lines that are too long with an ellipsis instead of wrapping them.
+noWrap :: HasWrap f => Mod f
+noWrap = fieldMod (overWrap (const False))
+
+-- | Wrap lines again, even inside a style that sets 'noWrap'.
+unsetNoWrap :: HasWrap f => Mod f
+unsetNoWrap = fieldMod (overWrap (const True))
diff --git a/internal/Lipstick/Internal/Types.hs b/internal/Lipstick/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Types.hs
@@ -0,0 +1,158 @@
+-- | Text attributes and positions, hidden from other packages: the public
+-- parts are re-exported by "Lipstick.Mod", "Lipstick.Block",
+-- "Lipstick.Grid" and "Lipstick.Ansi".
+module Lipstick.Internal.Types
+ ( -- * Text attributes
+ Attrs (..)
+ , Underline (..)
+ , Flag (..)
+ , setFlag
+ , getFlag
+ , fillAttrs
+ , escapeUri
+
+ -- * Positions
+ , Position (..)
+ , position
+ , left
+ , center
+ , right
+ , top
+ , bottom
+ , splitExtra
+ ) where
+
+import Control.Applicative ((<|>))
+import Data.ByteString qualified as BS
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Lipstick.Internal.Color (Color)
+import Text.Printf (printf)
+
+-- | Underline styles, for 'Lipstick.Mod.underlineStyle'. 'NoUnderline'
+-- turns off an underline an enclosing style sets.
+data Underline
+ = NoUnderline
+ | SingleUnderline
+ | DoubleUnderline
+ | CurlyUnderline
+ | DottedUnderline
+ | DashedUnderline
+ deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | Boolean text attributes.
+data Flag = Bold | Faint | Italic | Blink | Reverse | Strikethrough
+ deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | Partial text attributes. 'Nothing' means "not set here": when attributes
+-- are layered with '<>', set fields on the right win and unset ones let the
+-- left show through.
+data Attrs = Attrs
+ { attrFg :: !(Maybe Color)
+ , attrBg :: !(Maybe Color)
+ , attrUnderlineColor :: !(Maybe Color)
+ , attrBold :: !(Maybe Bool)
+ , attrFaint :: !(Maybe Bool)
+ , attrItalic :: !(Maybe Bool)
+ , attrBlink :: !(Maybe Bool)
+ , attrReverse :: !(Maybe Bool)
+ , attrStrikethrough :: !(Maybe Bool)
+ , attrUnderline :: !(Maybe Underline)
+ , attrLink :: !(Maybe Text)
+ }
+ deriving (Eq, Show)
+
+instance Semigroup Attrs where
+ a <> b =
+ Attrs
+ { attrFg = attrFg b <|> attrFg a
+ , attrBg = attrBg b <|> attrBg a
+ , attrUnderlineColor = attrUnderlineColor b <|> attrUnderlineColor a
+ , attrBold = attrBold b <|> attrBold a
+ , attrFaint = attrFaint b <|> attrFaint a
+ , attrItalic = attrItalic b <|> attrItalic a
+ , attrBlink = attrBlink b <|> attrBlink a
+ , attrReverse = attrReverse b <|> attrReverse a
+ , attrStrikethrough = attrStrikethrough b <|> attrStrikethrough a
+ , attrUnderline = attrUnderline b <|> attrUnderline a
+ , attrLink = attrLink b <|> attrLink a
+ }
+
+instance Monoid Attrs where
+ mempty = Attrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+
+setFlag :: Flag -> Maybe Bool -> Attrs -> Attrs
+setFlag f v a = case f of
+ Bold -> a {attrBold = v}
+ Faint -> a {attrFaint = v}
+ Italic -> a {attrItalic = v}
+ Blink -> a {attrBlink = v}
+ Reverse -> a {attrReverse = v}
+ Strikethrough -> a {attrStrikethrough = v}
+
+getFlag :: Flag -> Attrs -> Maybe Bool
+getFlag f = case f of
+ Bold -> attrBold
+ Faint -> attrFaint
+ Italic -> attrItalic
+ Blink -> attrBlink
+ Reverse -> attrReverse
+ Strikethrough -> attrStrikethrough
+
+-- | The attributes used for whitespace a style adds around content
+-- (alignment, padding): only the background and reverse video carry over.
+fillAttrs :: Attrs -> Attrs
+fillAttrs a = mempty {attrBg = attrBg a, attrReverse = attrReverse a}
+
+-- | A URI made safe for an OSC 8 hyperlink: every character other than
+-- printable, non-space ASCII is percent-encoded as UTF-8, including the
+-- controls that would end the escape sequence early. @%@ is kept, so
+-- existing escapes survive and applying it twice changes nothing.
+escapeUri :: Text -> Text
+escapeUri = T.concatMap escape
+ where
+ escape c
+ | c > ' ' && c < '\DEL' = T.singleton c
+ | otherwise = T.pack (concatMap (printf "%%%02X") (BS.unpack (T.encodeUtf8 (T.singleton c))))
+
+-- | A position along an axis: 0 is left/top, 1 is right/bottom.
+newtype Position = Position Double
+ deriving (Eq, Ord)
+
+-- | Shown with 'position', since the constructor is hidden.
+instance Show Position where
+ showsPrec d (Position x) = showParen (d > 10) (showString "position " . showsPrec 11 x)
+
+-- | A position, clamped to [0, 1].
+position :: Double -> Position
+position = Position . max 0 . min 1
+
+-- | The left edge: position 0.
+left :: Position
+left = Position 0
+
+-- | The middle, on either axis: position 0.5.
+center :: Position
+center = Position 0.5
+
+-- | The right edge: position 1.
+right :: Position
+right = Position 1
+
+-- | The top edge: position 0.
+top :: Position
+top = Position 0
+
+-- | The bottom edge: position 1.
+bottom :: Position
+bottom = Position 1
+
+-- | Split @extra@ columns (or rows) of space into the amounts before and
+-- after content placed at a position, as @(before, after)@. @before@
+-- rounds down, so at 'center' the odd column goes after.
+splitExtra :: Position -> Int -> (Int, Int)
+splitExtra (Position p) extra =
+ let e = max 0 extra
+ before = floor (fromIntegral e * max 0 (min 1 p))
+ in (before, e - before)
diff --git a/internal/Lipstick/Internal/UnicodeTable.hs b/internal/Lipstick/Internal/UnicodeTable.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/UnicodeTable.hs
@@ -0,0 +1,301 @@
+-- | Generated by scripts/GenUnicodeTable.hs from the Unicode 16.0.0
+-- Character Database. Do not edit; to regenerate, see the header of
+-- that script.
+--
+-- The data is derived from the Unicode Character Database, © Unicode, Inc.,
+-- under the Unicode License v3: see LICENSE.Unicode.
+module Lipstick.Internal.UnicodeTable (unicodeTableVersion, runStarts, runValues) where
+
+import Data.Array.Unboxed (UArray, listArray)
+import Data.Word (Word16)
+
+unicodeTableVersion :: String
+unicodeTableVersion = "16.0.0"
+
+-- | First code point of each run, ascending.
+runStarts :: UArray Int Int
+runStarts = listArray (0, 2220)
+ [ 0, 10, 11, 13, 14, 32, 35, 36, 42, 43, 48, 58, 127, 160, 169, 170
+ , 173, 174, 175, 768, 880, 1155, 1162, 1425, 1470, 1471, 1472, 1473, 1475, 1476, 1478, 1479
+ , 1480, 1536, 1542, 1552, 1563, 1564, 1565, 1611, 1632, 1648, 1649, 1750, 1757, 1758, 1759, 1765
+ , 1767, 1769, 1770, 1774, 1807, 1808, 1809, 1810, 1840, 1867, 1958, 1969, 2027, 2036, 2045, 2046
+ , 2070, 2074, 2075, 2084, 2085, 2088, 2089, 2094, 2137, 2140, 2192, 2194, 2199, 2208, 2250, 2274
+ , 2275, 2307, 2308, 2325, 2362, 2363, 2364, 2365, 2366, 2369, 2377, 2381, 2382, 2384, 2385, 2392
+ , 2400, 2402, 2404, 2424, 2432, 2433, 2434, 2436, 2453, 2473, 2474, 2481, 2482, 2483, 2486, 2490
+ , 2492, 2493, 2494, 2495, 2497, 2501, 2503, 2505, 2507, 2509, 2510, 2519, 2520, 2524, 2526, 2527
+ , 2528, 2530, 2532, 2544, 2546, 2558, 2559, 2561, 2563, 2564, 2620, 2621, 2622, 2625, 2627, 2631
+ , 2633, 2635, 2638, 2641, 2642, 2672, 2674, 2677, 2678, 2689, 2691, 2692, 2709, 2729, 2730, 2737
+ , 2738, 2740, 2741, 2746, 2748, 2749, 2750, 2753, 2758, 2759, 2761, 2762, 2763, 2765, 2766, 2786
+ , 2788, 2809, 2810, 2816, 2817, 2818, 2820, 2837, 2857, 2858, 2865, 2866, 2868, 2869, 2874, 2876
+ , 2877, 2878, 2880, 2881, 2885, 2887, 2889, 2891, 2893, 2894, 2901, 2904, 2908, 2910, 2911, 2912
+ , 2914, 2916, 2929, 2930, 2946, 2947, 3006, 3007, 3008, 3009, 3011, 3014, 3017, 3018, 3021, 3022
+ , 3031, 3032, 3072, 3073, 3076, 3077, 3093, 3113, 3114, 3130, 3132, 3133, 3134, 3137, 3141, 3142
+ , 3145, 3146, 3149, 3150, 3157, 3159, 3160, 3163, 3170, 3172, 3201, 3202, 3204, 3260, 3261, 3262
+ , 3263, 3265, 3266, 3267, 3269, 3270, 3273, 3274, 3278, 3285, 3287, 3298, 3300, 3315, 3316, 3328
+ , 3330, 3332, 3349, 3387, 3389, 3390, 3391, 3393, 3397, 3398, 3401, 3402, 3405, 3406, 3407, 3415
+ , 3416, 3426, 3428, 3457, 3458, 3460, 3530, 3531, 3535, 3536, 3538, 3541, 3542, 3543, 3544, 3551
+ , 3552, 3570, 3572, 3633, 3634, 3635, 3636, 3643, 3655, 3663, 3761, 3762, 3763, 3764, 3773, 3784
+ , 3791, 3864, 3866, 3893, 3894, 3895, 3896, 3897, 3898, 3902, 3904, 3953, 3967, 3968, 3973, 3974
+ , 3976, 3981, 3992, 3993, 4029, 4038, 4039, 4141, 4145, 4146, 4152, 4153, 4155, 4157, 4159, 4182
+ , 4184, 4186, 4190, 4193, 4209, 4213, 4226, 4227, 4228, 4229, 4231, 4237, 4238, 4253, 4254, 4352
+ , 4448, 4520, 4608, 4957, 4960, 5906, 5910, 5938, 5941, 5970, 5972, 6002, 6004, 6068, 6070, 6071
+ , 6078, 6086, 6087, 6089, 6100, 6109, 6110, 6155, 6158, 6159, 6160, 6277, 6279, 6313, 6314, 6432
+ , 6435, 6439, 6441, 6444, 6448, 6450, 6451, 6457, 6460, 6679, 6681, 6683, 6684, 6741, 6742, 6743
+ , 6744, 6751, 6752, 6753, 6754, 6755, 6757, 6765, 6771, 6781, 6783, 6784, 6832, 6863, 6912, 6916
+ , 6917, 6964, 6974, 6978, 6981, 7019, 7028, 7040, 7042, 7043, 7073, 7074, 7078, 7080, 7086, 7142
+ , 7143, 7144, 7146, 7149, 7150, 7151, 7156, 7204, 7212, 7220, 7222, 7224, 7376, 7379, 7380, 7393
+ , 7394, 7401, 7405, 7406, 7412, 7413, 7415, 7416, 7418, 7616, 7680, 8203, 8204, 8205, 8206, 8208
+ , 8232, 8239, 8252, 8253, 8265, 8266, 8288, 8304, 8400, 8433, 8482, 8483, 8505, 8506, 8596, 8602
+ , 8617, 8619, 8986, 8988, 9000, 9001, 9003, 9096, 9097, 9167, 9168, 9193, 9197, 9200, 9201, 9203
+ , 9204, 9208, 9211, 9410, 9411, 9642, 9644, 9654, 9655, 9664, 9665, 9723, 9725, 9727, 9728, 9733
+ , 9734, 9735, 9742, 9743, 9745, 9746, 9747, 9748, 9750, 9752, 9753, 9757, 9758, 9760, 9761, 9762
+ , 9764, 9766, 9767, 9770, 9771, 9774, 9776, 9784, 9787, 9792, 9793, 9794, 9795, 9800, 9812, 9823
+ , 9825, 9827, 9828, 9829, 9831, 9832, 9833, 9851, 9852, 9854, 9855, 9856, 9862, 9866, 9872, 9874
+ , 9875, 9876, 9880, 9881, 9882, 9883, 9885, 9888, 9889, 9890, 9895, 9896, 9898, 9900, 9904, 9906
+ , 9917, 9919, 9924, 9926, 9928, 9929, 9934, 9935, 9936, 9937, 9938, 9939, 9940, 9941, 9961, 9962
+ , 9963, 9968, 9970, 9972, 9973, 9974, 9975, 9978, 9979, 9981, 9982, 9986, 9987, 9989, 9990, 9992
+ , 9994, 9996, 9998, 9999, 10000, 10002, 10003, 10004, 10005, 10006, 10007, 10013, 10014, 10017, 10018, 10024
+ , 10025, 10035, 10037, 10052, 10053, 10055, 10056, 10060, 10061, 10062, 10063, 10067, 10070, 10071, 10072, 10083
+ , 10085, 10088, 10133, 10136, 10145, 10146, 10160, 10161, 10175, 10176, 10548, 10550, 11013, 11016, 11035, 11037
+ , 11088, 11089, 11093, 11094, 11503, 11506, 11647, 11648, 11744, 11776, 11904, 11930, 11931, 12020, 12032, 12246
+ , 12272, 12330, 12336, 12337, 12349, 12350, 12351, 12353, 12439, 12441, 12443, 12544, 12549, 12592, 12593, 12687
+ , 12688, 12774, 12783, 12831, 12832, 12872, 12880, 12951, 12952, 12953, 12954, 42125, 42128, 42183, 42607, 42611
+ , 42612, 42622, 42654, 42656, 42736, 42738, 43010, 43011, 43014, 43015, 43019, 43020, 43043, 43045, 43047, 43048
+ , 43052, 43053, 43136, 43138, 43188, 43204, 43206, 43232, 43250, 43263, 43264, 43302, 43310, 43335, 43346, 43347
+ , 43348, 43360, 43389, 43392, 43395, 43396, 43443, 43444, 43446, 43450, 43452, 43454, 43456, 43457, 43493, 43494
+ , 43561, 43567, 43569, 43571, 43573, 43575, 43587, 43588, 43596, 43597, 43598, 43644, 43645, 43696, 43697, 43698
+ , 43701, 43703, 43705, 43710, 43712, 43713, 43714, 43755, 43756, 43758, 43760, 43765, 43766, 43767, 44003, 44005
+ , 44006, 44008, 44009, 44011, 44012, 44013, 44014, 44032, 44033, 44060, 44061, 44088, 44089, 44116, 44117, 44144
+ , 44145, 44172, 44173, 44200, 44201, 44228, 44229, 44256, 44257, 44284, 44285, 44312, 44313, 44340, 44341, 44368
+ , 44369, 44396, 44397, 44424, 44425, 44452, 44453, 44480, 44481, 44508, 44509, 44536, 44537, 44564, 44565, 44592
+ , 44593, 44620, 44621, 44648, 44649, 44676, 44677, 44704, 44705, 44732, 44733, 44760, 44761, 44788, 44789, 44816
+ , 44817, 44844, 44845, 44872, 44873, 44900, 44901, 44928, 44929, 44956, 44957, 44984, 44985, 45012, 45013, 45040
+ , 45041, 45068, 45069, 45096, 45097, 45124, 45125, 45152, 45153, 45180, 45181, 45208, 45209, 45236, 45237, 45264
+ , 45265, 45292, 45293, 45320, 45321, 45348, 45349, 45376, 45377, 45404, 45405, 45432, 45433, 45460, 45461, 45488
+ , 45489, 45516, 45517, 45544, 45545, 45572, 45573, 45600, 45601, 45628, 45629, 45656, 45657, 45684, 45685, 45712
+ , 45713, 45740, 45741, 45768, 45769, 45796, 45797, 45824, 45825, 45852, 45853, 45880, 45881, 45908, 45909, 45936
+ , 45937, 45964, 45965, 45992, 45993, 46020, 46021, 46048, 46049, 46076, 46077, 46104, 46105, 46132, 46133, 46160
+ , 46161, 46188, 46189, 46216, 46217, 46244, 46245, 46272, 46273, 46300, 46301, 46328, 46329, 46356, 46357, 46384
+ , 46385, 46412, 46413, 46440, 46441, 46468, 46469, 46496, 46497, 46524, 46525, 46552, 46553, 46580, 46581, 46608
+ , 46609, 46636, 46637, 46664, 46665, 46692, 46693, 46720, 46721, 46748, 46749, 46776, 46777, 46804, 46805, 46832
+ , 46833, 46860, 46861, 46888, 46889, 46916, 46917, 46944, 46945, 46972, 46973, 47000, 47001, 47028, 47029, 47056
+ , 47057, 47084, 47085, 47112, 47113, 47140, 47141, 47168, 47169, 47196, 47197, 47224, 47225, 47252, 47253, 47280
+ , 47281, 47308, 47309, 47336, 47337, 47364, 47365, 47392, 47393, 47420, 47421, 47448, 47449, 47476, 47477, 47504
+ , 47505, 47532, 47533, 47560, 47561, 47588, 47589, 47616, 47617, 47644, 47645, 47672, 47673, 47700, 47701, 47728
+ , 47729, 47756, 47757, 47784, 47785, 47812, 47813, 47840, 47841, 47868, 47869, 47896, 47897, 47924, 47925, 47952
+ , 47953, 47980, 47981, 48008, 48009, 48036, 48037, 48064, 48065, 48092, 48093, 48120, 48121, 48148, 48149, 48176
+ , 48177, 48204, 48205, 48232, 48233, 48260, 48261, 48288, 48289, 48316, 48317, 48344, 48345, 48372, 48373, 48400
+ , 48401, 48428, 48429, 48456, 48457, 48484, 48485, 48512, 48513, 48540, 48541, 48568, 48569, 48596, 48597, 48624
+ , 48625, 48652, 48653, 48680, 48681, 48708, 48709, 48736, 48737, 48764, 48765, 48792, 48793, 48820, 48821, 48848
+ , 48849, 48876, 48877, 48904, 48905, 48932, 48933, 48960, 48961, 48988, 48989, 49016, 49017, 49044, 49045, 49072
+ , 49073, 49100, 49101, 49128, 49129, 49156, 49157, 49184, 49185, 49212, 49213, 49240, 49241, 49268, 49269, 49296
+ , 49297, 49324, 49325, 49352, 49353, 49380, 49381, 49408, 49409, 49436, 49437, 49464, 49465, 49492, 49493, 49520
+ , 49521, 49548, 49549, 49576, 49577, 49604, 49605, 49632, 49633, 49660, 49661, 49688, 49689, 49716, 49717, 49744
+ , 49745, 49772, 49773, 49800, 49801, 49828, 49829, 49856, 49857, 49884, 49885, 49912, 49913, 49940, 49941, 49968
+ , 49969, 49996, 49997, 50024, 50025, 50052, 50053, 50080, 50081, 50108, 50109, 50136, 50137, 50164, 50165, 50192
+ , 50193, 50220, 50221, 50248, 50249, 50276, 50277, 50304, 50305, 50332, 50333, 50360, 50361, 50388, 50389, 50416
+ , 50417, 50444, 50445, 50472, 50473, 50500, 50501, 50528, 50529, 50556, 50557, 50584, 50585, 50612, 50613, 50640
+ , 50641, 50668, 50669, 50696, 50697, 50724, 50725, 50752, 50753, 50780, 50781, 50808, 50809, 50836, 50837, 50864
+ , 50865, 50892, 50893, 50920, 50921, 50948, 50949, 50976, 50977, 51004, 51005, 51032, 51033, 51060, 51061, 51088
+ , 51089, 51116, 51117, 51144, 51145, 51172, 51173, 51200, 51201, 51228, 51229, 51256, 51257, 51284, 51285, 51312
+ , 51313, 51340, 51341, 51368, 51369, 51396, 51397, 51424, 51425, 51452, 51453, 51480, 51481, 51508, 51509, 51536
+ , 51537, 51564, 51565, 51592, 51593, 51620, 51621, 51648, 51649, 51676, 51677, 51704, 51705, 51732, 51733, 51760
+ , 51761, 51788, 51789, 51816, 51817, 51844, 51845, 51872, 51873, 51900, 51901, 51928, 51929, 51956, 51957, 51984
+ , 51985, 52012, 52013, 52040, 52041, 52068, 52069, 52096, 52097, 52124, 52125, 52152, 52153, 52180, 52181, 52208
+ , 52209, 52236, 52237, 52264, 52265, 52292, 52293, 52320, 52321, 52348, 52349, 52376, 52377, 52404, 52405, 52432
+ , 52433, 52460, 52461, 52488, 52489, 52516, 52517, 52544, 52545, 52572, 52573, 52600, 52601, 52628, 52629, 52656
+ , 52657, 52684, 52685, 52712, 52713, 52740, 52741, 52768, 52769, 52796, 52797, 52824, 52825, 52852, 52853, 52880
+ , 52881, 52908, 52909, 52936, 52937, 52964, 52965, 52992, 52993, 53020, 53021, 53048, 53049, 53076, 53077, 53104
+ , 53105, 53132, 53133, 53160, 53161, 53188, 53189, 53216, 53217, 53244, 53245, 53272, 53273, 53300, 53301, 53328
+ , 53329, 53356, 53357, 53384, 53385, 53412, 53413, 53440, 53441, 53468, 53469, 53496, 53497, 53524, 53525, 53552
+ , 53553, 53580, 53581, 53608, 53609, 53636, 53637, 53664, 53665, 53692, 53693, 53720, 53721, 53748, 53749, 53776
+ , 53777, 53804, 53805, 53832, 53833, 53860, 53861, 53888, 53889, 53916, 53917, 53944, 53945, 53972, 53973, 54000
+ , 54001, 54028, 54029, 54056, 54057, 54084, 54085, 54112, 54113, 54140, 54141, 54168, 54169, 54196, 54197, 54224
+ , 54225, 54252, 54253, 54280, 54281, 54308, 54309, 54336, 54337, 54364, 54365, 54392, 54393, 54420, 54421, 54448
+ , 54449, 54476, 54477, 54504, 54505, 54532, 54533, 54560, 54561, 54588, 54589, 54616, 54617, 54644, 54645, 54672
+ , 54673, 54700, 54701, 54728, 54729, 54756, 54757, 54784, 54785, 54812, 54813, 54840, 54841, 54868, 54869, 54896
+ , 54897, 54924, 54925, 54952, 54953, 54980, 54981, 55008, 55009, 55036, 55037, 55064, 55065, 55092, 55093, 55120
+ , 55121, 55148, 55149, 55176, 55177, 55204, 55216, 55239, 55243, 55292, 63744, 64256, 64286, 64287, 65024, 65040
+ , 65050, 65056, 65072, 65107, 65108, 65127, 65128, 65132, 65279, 65280, 65281, 65377, 65438, 65440, 65504, 65511
+ , 65520, 65532, 66045, 66046, 66272, 66273, 66422, 66427, 68097, 68100, 68101, 68103, 68108, 68112, 68152, 68155
+ , 68159, 68160, 68325, 68327, 68900, 68904, 68969, 68974, 69291, 69293, 69372, 69376, 69446, 69457, 69506, 69510
+ , 69632, 69633, 69634, 69635, 69688, 69703, 69744, 69745, 69747, 69749, 69759, 69762, 69763, 69808, 69811, 69815
+ , 69817, 69819, 69821, 69822, 69826, 69827, 69837, 69838, 69888, 69891, 69927, 69932, 69933, 69941, 69957, 69959
+ , 70003, 70004, 70016, 70018, 70019, 70067, 70070, 70079, 70080, 70081, 70082, 70084, 70089, 70093, 70094, 70095
+ , 70096, 70188, 70191, 70194, 70196, 70200, 70206, 70207, 70209, 70210, 70367, 70368, 70371, 70379, 70400, 70402
+ , 70404, 70459, 70461, 70462, 70463, 70464, 70465, 70469, 70471, 70473, 70475, 70477, 70478, 70487, 70488, 70498
+ , 70500, 70502, 70509, 70512, 70517, 70584, 70585, 70587, 70593, 70594, 70595, 70597, 70598, 70599, 70602, 70603
+ , 70604, 70606, 70609, 70610, 70611, 70625, 70627, 70709, 70712, 70720, 70722, 70725, 70726, 70727, 70750, 70751
+ , 70832, 70833, 70835, 70841, 70842, 70843, 70845, 70846, 70847, 70849, 70850, 70852, 71087, 71088, 71090, 71094
+ , 71096, 71100, 71102, 71103, 71105, 71132, 71134, 71216, 71219, 71227, 71229, 71230, 71231, 71233, 71339, 71340
+ , 71341, 71342, 71344, 71352, 71453, 71454, 71455, 71456, 71458, 71462, 71463, 71468, 71724, 71727, 71736, 71737
+ , 71739, 71984, 71985, 71990, 71991, 71993, 71995, 71999, 72000, 72001, 72002, 72003, 72004, 72145, 72148, 72152
+ , 72154, 72156, 72160, 72161, 72164, 72165, 72193, 72203, 72243, 72249, 72250, 72251, 72255, 72263, 72264, 72273
+ , 72279, 72281, 72284, 72324, 72330, 72343, 72344, 72346, 72751, 72752, 72759, 72760, 72766, 72767, 72768, 72850
+ , 72872, 72873, 72874, 72881, 72882, 72884, 72885, 72887, 73009, 73015, 73018, 73019, 73020, 73022, 73023, 73030
+ , 73031, 73032, 73098, 73103, 73104, 73106, 73107, 73109, 73110, 73111, 73112, 73459, 73461, 73463, 73472, 73474
+ , 73475, 73476, 73524, 73526, 73531, 73534, 73536, 73539, 73562, 73563, 78896, 78912, 78913, 78919, 78934, 90398
+ , 90410, 90413, 90416, 92912, 92917, 92976, 92983, 93539, 93540, 93543, 93547, 94031, 94032, 94033, 94088, 94095
+ , 94099, 94176, 94180, 94181, 94192, 94194, 94208, 100344, 100352, 101590, 101631, 101641, 110576, 110580, 110581, 110588
+ , 110589, 110591, 110592, 110883, 110898, 110899, 110928, 110931, 110933, 110934, 110948, 110952, 110960, 111356, 113821, 113823
+ , 113824, 113828, 118528, 118574, 118576, 118599, 119141, 119146, 119149, 119155, 119163, 119171, 119173, 119180, 119210, 119214
+ , 119362, 119365, 119552, 119639, 119648, 119671, 121344, 121399, 121403, 121453, 121461, 121462, 121476, 121477, 121499, 121504
+ , 121505, 121520, 122880, 122887, 122888, 122905, 122907, 122914, 122915, 122917, 122918, 122923, 123023, 123024, 123184, 123191
+ , 123566, 123567, 123628, 123632, 124140, 124144, 124398, 124400, 125136, 125143, 125252, 125259, 126976, 126980, 126981, 127183
+ , 127184, 127232, 127245, 127248, 127279, 127280, 127340, 127344, 127346, 127358, 127360, 127374, 127375, 127377, 127387, 127405
+ , 127462, 127488, 127489, 127491, 127504, 127514, 127515, 127535, 127536, 127538, 127547, 127548, 127552, 127561, 127568, 127570
+ , 127584, 127590, 127744, 127777, 127778, 127780, 127789, 127798, 127799, 127869, 127870, 127892, 127894, 127896, 127897, 127900
+ , 127902, 127904, 127947, 127951, 127956, 127968, 127985, 127987, 127988, 127989, 127990, 127991, 127992, 127995, 128000, 128063
+ , 128064, 128065, 128066, 128253, 128254, 128255, 128318, 128326, 128329, 128331, 128335, 128336, 128360, 128367, 128369, 128371
+ , 128378, 128379, 128391, 128392, 128394, 128398, 128400, 128401, 128405, 128407, 128420, 128421, 128422, 128424, 128425, 128433
+ , 128435, 128444, 128445, 128450, 128453, 128465, 128468, 128476, 128479, 128481, 128482, 128483, 128484, 128488, 128489, 128495
+ , 128496, 128499, 128500, 128506, 128507, 128592, 128640, 128710, 128715, 128716, 128717, 128720, 128723, 128725, 128728, 128732
+ , 128736, 128742, 128745, 128746, 128747, 128749, 128752, 128753, 128755, 128756, 128765, 128768, 128884, 128896, 128981, 128992
+ , 129004, 129008, 129009, 129024, 129036, 129040, 129096, 129104, 129114, 129120, 129160, 129168, 129198, 129280, 129292, 129339
+ , 129340, 129350, 129351, 129536, 129648, 129661, 129664, 129674, 129679, 129735, 129742, 129757, 129759, 129770, 129776, 129785
+ , 129792, 130048, 131070, 131072, 196606, 196608, 262142, 917504, 917536, 917632, 917760, 918000, 921600
+ ]
+
+-- | Packed properties of each run.
+runValues :: UArray Int Word16
+runValues = listArray (0, 2220)
+ [ 3, 2, 3, 1, 3, 0, 64, 0, 64, 0, 64, 0, 3, 0, 96, 0
+ , 3, 96, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388
+ , 0, 7, 0, 388, 0, 3, 0, 388, 0, 388, 0, 388, 7, 0, 388, 0
+ , 388, 0, 388, 0, 7, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0
+ , 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 7, 0, 388, 0, 388, 7
+ , 388, 8, 0, 256, 388, 8, 388, 0, 8, 388, 8, 132, 8, 0, 388, 256
+ , 0, 388, 0, 256, 0, 388, 8, 0, 256, 0, 256, 0, 256, 0, 256, 0
+ , 388, 0, 388, 8, 388, 0, 8, 0, 8, 132, 0, 388, 0, 256, 0, 256
+ , 0, 388, 0, 256, 0, 388, 0, 388, 8, 0, 388, 0, 8, 388, 0, 388
+ , 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 8, 0, 256, 0, 256, 0
+ , 256, 0, 256, 0, 388, 0, 8, 388, 0, 388, 8, 0, 8, 132, 0, 388
+ , 0, 256, 388, 0, 388, 8, 0, 256, 0, 256, 0, 256, 0, 256, 0, 388
+ , 0, 388, 8, 388, 0, 8, 0, 8, 132, 0, 388, 0, 256, 0, 256, 0
+ , 388, 0, 256, 0, 388, 0, 388, 8, 388, 8, 0, 8, 0, 8, 388, 0
+ , 388, 0, 388, 8, 388, 0, 256, 0, 256, 0, 388, 0, 388, 8, 0, 388
+ , 0, 388, 132, 0, 388, 0, 256, 0, 388, 0, 388, 8, 0, 388, 0, 8
+ , 388, 8, 388, 8, 0, 388, 0, 388, 0, 388, 0, 388, 0, 8, 0, 388
+ , 8, 0, 256, 388, 0, 388, 8, 388, 0, 8, 0, 8, 132, 7, 0, 388
+ , 0, 388, 0, 388, 8, 0, 388, 0, 388, 8, 388, 0, 388, 0, 8, 388
+ , 0, 8, 0, 388, 0, 8, 388, 0, 388, 0, 388, 0, 8, 388, 0, 388
+ , 0, 388, 0, 388, 0, 388, 0, 388, 0, 8, 0, 388, 8, 388, 0, 388
+ , 0, 388, 0, 388, 0, 388, 0, 388, 8, 388, 0, 388, 8, 388, 0, 8
+ , 388, 0, 388, 0, 388, 0, 388, 0, 8, 388, 0, 388, 0, 388, 0, 25
+ , 10, 11, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 8, 388
+ , 8, 388, 8, 388, 0, 388, 0, 388, 3, 388, 0, 388, 0, 388, 0, 388
+ , 8, 388, 8, 0, 8, 388, 8, 388, 0, 388, 8, 388, 0, 8, 388, 8
+ , 388, 0, 388, 0, 388, 0, 388, 8, 388, 0, 388, 0, 388, 0, 388, 8
+ , 0, 388, 8, 388, 0, 388, 0, 388, 8, 0, 8, 388, 8, 388, 0, 388
+ , 8, 388, 8, 388, 8, 388, 0, 8, 388, 8, 388, 0, 388, 0, 388, 8
+ , 388, 0, 388, 0, 388, 0, 8, 388, 0, 388, 0, 3, 4, 389, 3, 0
+ , 3, 0, 96, 0, 96, 0, 3, 0, 388, 0, 96, 0, 96, 0, 96, 0
+ , 96, 0, 112, 0, 96, 16, 0, 32, 0, 96, 0, 112, 96, 112, 96, 112
+ , 0, 96, 0, 96, 0, 96, 0, 96, 0, 96, 0, 96, 112, 0, 96, 32
+ , 0, 32, 96, 32, 96, 32, 0, 112, 32, 96, 32, 96, 32, 96, 32, 96
+ , 32, 96, 32, 96, 32, 96, 48, 96, 32, 96, 32, 96, 32, 112, 32, 96
+ , 32, 96, 32, 96, 32, 96, 32, 96, 32, 96, 112, 32, 0, 16, 32, 96
+ , 112, 96, 32, 96, 32, 96, 32, 96, 112, 32, 96, 32, 112, 32, 96, 32
+ , 112, 32, 112, 32, 96, 32, 112, 96, 32, 96, 32, 96, 112, 32, 96, 112
+ , 32, 96, 112, 96, 112, 32, 96, 112, 32, 112, 32, 96, 32, 112, 0, 96
+ , 112, 96, 32, 96, 32, 96, 0, 96, 0, 96, 0, 96, 0, 96, 0, 112
+ , 0, 96, 0, 96, 0, 96, 0, 112, 0, 112, 0, 112, 0, 112, 0, 96
+ , 32, 0, 112, 0, 96, 0, 112, 0, 112, 0, 96, 0, 96, 0, 112, 0
+ , 112, 0, 112, 0, 388, 0, 388, 0, 388, 0, 16, 0, 16, 0, 16, 0
+ , 16, 404, 112, 16, 112, 16, 0, 16, 0, 404, 16, 0, 16, 0, 16, 0
+ , 16, 0, 16, 0, 16, 0, 16, 112, 16, 112, 16, 0, 16, 0, 388, 0
+ , 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 8, 388, 8, 0
+ , 388, 0, 8, 0, 8, 388, 0, 388, 0, 388, 0, 388, 0, 388, 8, 388
+ , 0, 25, 0, 388, 8, 0, 388, 8, 388, 8, 388, 8, 388, 0, 388, 0
+ , 388, 8, 388, 8, 388, 0, 388, 0, 388, 8, 0, 388, 0, 388, 0, 388
+ , 0, 388, 0, 388, 0, 388, 0, 8, 388, 8, 0, 8, 388, 0, 8, 388
+ , 8, 388, 8, 0, 8, 388, 0, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28, 29, 28
+ , 29, 28, 29, 28, 29, 0, 10, 0, 11, 0, 16, 0, 388, 0, 388, 16
+ , 0, 388, 16, 0, 16, 0, 16, 0, 3, 0, 16, 0, 388, 0, 16, 0
+ , 3, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0
+ , 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0
+ , 8, 388, 8, 0, 388, 0, 388, 0, 388, 0, 388, 8, 0, 8, 388, 8
+ , 388, 0, 7, 0, 388, 0, 7, 0, 388, 0, 388, 8, 388, 0, 8, 0
+ , 388, 0, 388, 8, 0, 8, 388, 8, 388, 0, 7, 0, 388, 0, 8, 388
+ , 0, 8, 388, 8, 388, 0, 388, 0, 388, 0, 388, 8, 388, 0, 388, 8
+ , 0, 388, 0, 388, 8, 388, 8, 0, 8, 0, 8, 388, 0, 388, 0, 8
+ , 0, 388, 0, 388, 0, 388, 8, 388, 0, 388, 0, 388, 0, 388, 8, 0
+ , 8, 388, 7, 388, 0, 388, 0, 8, 388, 8, 388, 8, 388, 0, 388, 0
+ , 388, 8, 388, 8, 388, 8, 388, 8, 388, 8, 388, 0, 388, 8, 388, 0
+ , 8, 388, 8, 388, 0, 388, 0, 8, 388, 8, 388, 8, 388, 0, 388, 8
+ , 388, 8, 388, 0, 388, 8, 388, 0, 388, 8, 388, 0, 8, 388, 8, 388
+ , 0, 388, 8, 0, 8, 0, 388, 7, 8, 7, 8, 388, 0, 8, 388, 0
+ , 388, 8, 388, 0, 8, 0, 388, 0, 388, 8, 7, 388, 0, 388, 0, 388
+ , 8, 388, 0, 7, 388, 8, 388, 0, 8, 388, 0, 388, 8, 388, 0, 388
+ , 0, 8, 388, 8, 388, 8, 388, 0, 388, 0, 388, 0, 388, 0, 388, 7
+ , 388, 0, 8, 0, 388, 0, 8, 388, 8, 388, 0, 388, 8, 0, 388, 7
+ , 8, 0, 8, 388, 0, 8, 388, 0, 388, 0, 3, 388, 0, 388, 0, 388
+ , 8, 388, 0, 388, 0, 388, 0, 10, 0, 10, 0, 388, 0, 8, 0, 388
+ , 0, 16, 404, 0, 404, 0, 16, 0, 16, 0, 16, 0, 16, 0, 16, 0
+ , 16, 0, 16, 0, 16, 0, 16, 0, 16, 0, 16, 0, 16, 0, 388, 0
+ , 3, 0, 388, 0, 388, 0, 388, 0, 388, 3, 388, 0, 388, 0, 388, 0
+ , 388, 0, 16, 0, 16, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0
+ , 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0
+ , 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 388, 0, 32, 112, 32, 112
+ , 32, 0, 32, 0, 32, 0, 32, 96, 0, 96, 0, 112, 0, 112, 0, 32
+ , 70, 16, 112, 32, 16, 112, 16, 112, 16, 112, 16, 32, 16, 32, 112, 32
+ , 48, 32, 112, 96, 32, 96, 112, 96, 112, 96, 112, 32, 96, 32, 96, 32
+ , 96, 112, 96, 112, 96, 112, 32, 96, 112, 96, 32, 96, 112, 468, 112, 96
+ , 112, 96, 112, 96, 32, 112, 0, 32, 96, 112, 32, 112, 32, 96, 32, 96
+ , 112, 32, 96, 32, 96, 32, 96, 32, 112, 32, 112, 96, 32, 96, 32, 96
+ , 32, 96, 32, 96, 32, 96, 32, 96, 32, 96, 32, 96, 32, 96, 32, 96
+ , 32, 96, 32, 96, 112, 0, 112, 32, 96, 112, 96, 112, 32, 112, 32, 112
+ , 96, 32, 96, 32, 112, 32, 96, 32, 96, 112, 32, 0, 32, 0, 32, 112
+ , 32, 112, 32, 0, 32, 0, 32, 0, 32, 0, 32, 0, 32, 0, 112, 0
+ , 112, 0, 112, 32, 112, 32, 112, 32, 112, 32, 112, 32, 112, 32, 112, 32
+ , 0, 32, 0, 16, 0, 16, 0, 3, 388, 3, 388, 3, 0
+ ]
diff --git a/internal/Lipstick/Internal/Width.hs b/internal/Lipstick/Internal/Width.hs
new file mode 100644
--- /dev/null
+++ b/internal/Lipstick/Internal/Width.hs
@@ -0,0 +1,200 @@
+-- | The implementation of "Lipstick.Width", hidden from other packages: see
+-- that module.
+module Lipstick.Internal.Width
+ ( charWidth
+ , textWidth
+ , clusters
+ , unicodeVersion
+ ) where
+
+import Data.Array.Base (unsafeAt)
+import Data.Array.Unboxed (bounds)
+import Data.Bits (shiftR, testBit, (.&.))
+import Data.Char (ord)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Word (Word16)
+import Lipstick.Internal.UnicodeTable
+
+-- | The Unicode version the tables were generated from.
+unicodeVersion :: String
+unicodeVersion = unicodeTableVersion
+
+-- | Display width of a whole text.
+textWidth :: Text -> Int
+textWidth = sum . map snd . clusters
+
+-- | Display width of a single character, ignoring context.
+charWidth :: Char -> Int
+charWidth = codeWidth . props
+
+-- | Split text into grapheme clusters, each with its display width. The
+-- clusters are slices of the text, not copies.
+clusters :: Text -> [(Text, Int)]
+clusters = go
+ where
+ go t = case T.uncons t of
+ Nothing -> []
+ Just (c, rest) ->
+ let p = props c
+ (n, ext) = extend (start p) p 1 rest
+ (cl, more) = T.splitAt n t
+ in (cl, clusterWidth ((c, p) : ext)) : go more
+
+ -- How many characters the cluster has, and the ones after the first.
+ extend st prev n t = case T.uncons t of
+ Just (c, rest)
+ | let p = props c
+ , joins st prev p ->
+ let (n', ext) = extend (step st p) p (n + 1) rest in (n', (c, p) : ext)
+ _ -> (n :: Int, [])
+
+-- Properties ------------------------------------------------------------------
+
+-- | Packed properties of a character (see the generator for the layout).
+props :: Char -> Word16
+props c
+ | n < 0x7F = if n < 0x20 then asciiControl n else asciiProps n
+ | otherwise = unsafeAt runValues (search 0 hi)
+ where
+ n = ord c
+ (_, hi) = bounds runStarts
+ -- The last run starting at or before n.
+ search lo h
+ | lo >= h = lo
+ | otherwise =
+ let mid = (lo + h + 1) `div` 2
+ in if unsafeAt runStarts mid <= n then search mid h else search lo (mid - 1)
+ -- ASCII must agree with the table: these only skip the search.
+ asciiControl k
+ | k == 0x0D = gcbCR
+ | k == 0x0A = gcbLF
+ | otherwise = gcbControl
+ asciiProps k
+ -- '#', '*' and the digits have the Emoji property (keycaps), bit 6.
+ | k == 0x23 || k == 0x2A || (k >= 0x30 && k <= 0x39) = 0x40
+ | otherwise = 0
+
+gcb :: Word16 -> Word16
+gcb p = p .&. 0xF
+
+isWide, isPictographic, isEmoji :: Word16 -> Bool
+isWide p = testBit p 4
+isPictographic p = testBit p 5
+isEmoji p = testBit p 6
+
+incb :: Word16 -> Word16
+incb p = (p `shiftR` 7) .&. 3
+
+-- These must match gcbCode and incbCode in scripts/GenUnicodeTable.hs.
+gcbCR, gcbLF, gcbControl, gcbExtend, gcbZWJ, gcbRI :: Word16
+gcbCR = 1
+gcbLF = 2
+gcbControl = 3
+gcbExtend = 4
+gcbZWJ = 5
+gcbRI = 6
+
+gcbPrepend, gcbSpacingMark, gcbL, gcbV, gcbT, gcbLV, gcbLVT :: Word16
+gcbPrepend = 7
+gcbSpacingMark = 8
+gcbL = 9
+gcbV = 10
+gcbT = 11
+gcbLV = 12
+gcbLVT = 13
+
+incbLinker, incbConsonant, incbExtend :: Word16
+incbLinker = 1
+incbConsonant = 2
+incbExtend = 3
+
+-- Segmentation ----------------------------------------------------------------
+
+-- | What the current cluster has seen, for the rules that look back further
+-- than one character.
+data State = State
+ { stRegional :: !Int -- ^ regional indicators in a row
+ , stPict :: !Pict
+ , stConjunct :: !Conjunct
+ }
+
+-- | Progress through GB11's ExtPict Extend* ZWJ.
+data Pict = NoPict | InPict | PictZWJ
+ deriving (Eq)
+
+-- | Indic conjunct: a consonant followed by extends and linkers.
+data Conjunct = NoConjunct | Consonant !Bool -- ^ a linker has been seen
+ deriving (Eq)
+
+start :: Word16 -> State
+start = step (State 0 NoPict NoConjunct)
+
+step :: State -> Word16 -> State
+step (State regional pict conjunct) p =
+ State
+ { stRegional = if gcb p == gcbRI then regional + 1 else 0
+ , stPict = pict'
+ , stConjunct = conjunct'
+ }
+ where
+ pict'
+ | isPictographic p = InPict
+ | pict == InPict && gcb p == gcbExtend = InPict
+ | pict == InPict && gcb p == gcbZWJ = PictZWJ
+ | otherwise = NoPict
+ conjunct' = case conjunct of
+ _ | incb p == incbConsonant -> Consonant False
+ Consonant _ | incb p == incbLinker -> Consonant True
+ Consonant l | incb p == incbExtend -> Consonant l
+ _ -> NoConjunct
+
+-- | Whether the next character continues the current cluster. Rule
+-- numbers are UAX #29's, Unicode 16.0.
+joins :: State -> Word16 -> Word16 -> Bool
+joins st prevP nextP
+ | prev == gcbCR && next == gcbLF = True -- GB3
+ | prev `elem` [gcbControl, gcbCR, gcbLF] = False -- GB4
+ | next `elem` [gcbControl, gcbCR, gcbLF] = False -- GB5
+ | prev == gcbL && next `elem` [gcbL, gcbV, gcbLV, gcbLVT] = True -- GB6
+ | prev `elem` [gcbLV, gcbV] && next `elem` [gcbV, gcbT] = True -- GB7
+ | prev `elem` [gcbLVT, gcbT] && next == gcbT = True -- GB8
+ | next == gcbExtend || next == gcbZWJ = True -- GB9
+ | next == gcbSpacingMark = True -- GB9a
+ | prev == gcbPrepend = True -- GB9b
+ | incb nextP == incbConsonant && stConjunct st == Consonant True = True -- GB9c
+ | prev == gcbZWJ && isPictographic nextP && stPict st == PictZWJ = True -- GB11
+ | prev == gcbRI && next == gcbRI = odd (stRegional st) -- GB12, GB13
+ | otherwise = False -- GB999
+ where
+ prev = gcb prevP
+ next = gcb nextP
+
+-- Width -----------------------------------------------------------------------
+
+codeWidth :: Word16 -> Int
+codeWidth p
+ | isEmojiModifier p = 2
+ | g `elem` [gcbControl, gcbCR, gcbLF, gcbExtend, gcbZWJ, gcbV, gcbT] = 0
+ | isWide p = 2
+ | otherwise = 1
+ where
+ g = gcb p
+
+-- | Extend characters with the Emoji property: in Unicode 16.0, exactly
+-- the skin tone modifiers U+1F3FB–1F3FF. They join the emoji before them,
+-- but are wide on their own.
+isEmojiModifier :: Word16 -> Bool
+isEmojiModifier p = gcb p == gcbExtend && isEmoji p
+
+-- | VS16 and a skin tone modifier both make an emoji wide (UTS #51), also
+-- one that is narrow on its own, such as ☝. VS15 changes nothing: it asks
+-- for text presentation, not for a width.
+clusterWidth :: [(Char, Word16)] -> Int
+clusterWidth cl = case cl of
+ [(_, p1), (_, p2)] | gcb p1 == gcbRI && gcb p2 == gcbRI -> 2
+ (_, p) : rest
+ | isEmoji p && any (\(c, q) -> c == '\xFE0F' || isEmojiModifier q) rest -> 2
+ _ -> case filter (> 0) (map (codeWidth . snd) cl) of
+ w : _ -> w
+ [] -> 0
diff --git a/lipstick.cabal b/lipstick.cabal
new file mode 100644
--- /dev/null
+++ b/lipstick.cabal
@@ -0,0 +1,156 @@
+cabal-version: 3.12
+name: lipstick
+version: 0.1.0.0
+synopsis: Style definitions for nice terminal layouts
+category: Console, Text
+description:
+ A port of charmbracelet's lipgloss (v2): colours, borders, padding,
+ alignment, tables, lists, trees and layered compositions for command-line
+ output. Styles are composable modifiers; they render to blocks of styled
+ text, laid out in the width available and turned into ANSI escape
+ sequences only when printed. lipstick-brick shows the blocks in brick and
+ vty applications.
+license: MIT AND Unicode-3.0
+license-files:
+ LICENSE
+ LICENSE.Unicode
+author: Andrea Bedini
+maintainer: andrea@bedini.au
+homepage: https://github.com/andreabedini/lipstick
+bug-reports: https://github.com/andreabedini/lipstick/issues
+build-type: Simple
+tested-with: GHC == 9.10.3 || == 9.12.2 || == 9.14.1
+extra-doc-files:
+ CHANGELOG.md
+ README.md
+extra-source-files:
+ scripts/GenUnicodeTable.hs
+ test/data/GraphemeBreakTest.txt
+
+source-repository head
+ type: git
+ location: https://github.com/andreabedini/lipstick.git
+
+-- The demo and the screenshot generator are for developing lipstick:
+-- cabal.project switches them on, so that installing the package from
+-- Hackage does not install them.
+flag examples
+ description: Build the example programs
+ default: False
+ manual: True
+
+common warnings
+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates
+
+library
+ import: warnings
+ -- The public modules are in src; the representation of blocks, grids,
+ -- styles and colours is in internal, as other-modules, so other
+ -- packages cannot import it.
+ hs-source-dirs: src internal
+ exposed-modules:
+ Lipstick
+ Lipstick.Ansi
+ Lipstick.Block
+ Lipstick.Border
+ Lipstick.Color
+ Lipstick.Grid
+ Lipstick.Layer
+ Lipstick.Mod
+ Lipstick.Place
+ Lipstick.Style
+ Lipstick.Table
+ Lipstick.Outline
+ Lipstick.Terminal
+ Lipstick.Width
+ other-modules:
+ Lipstick.Internal.Border
+ Lipstick.Internal.Color
+ Lipstick.Internal.Grid
+ Lipstick.Internal.Layout
+ Lipstick.Internal.Mod
+ Lipstick.Internal.Types
+ Lipstick.Internal.UnicodeTable
+ Lipstick.Internal.Width
+ build-depends:
+ base >=4.20 && <4.23,
+ array ^>=0.5,
+ bytestring >=0.11 && <0.13,
+ text >=2.1.2 && <2.2,
+ ansi-terminal ^>=1.1,
+ terminal-size >=0.3.4 && <0.4,
+ colour ^>=2.3,
+ containers >=0.6 && <0.9
+ default-language: GHC2024
+
+executable lipstick-demo
+ import: warnings
+ if !flag(examples)
+ buildable: False
+ main-is: Main.hs
+ hs-source-dirs: examples
+ build-depends:
+ base,
+ text,
+ lipstick
+ default-language: GHC2024
+
+executable lipstick-screenshots
+ import: warnings
+ if !flag(examples)
+ buildable: False
+ main-is: Screenshots.hs
+ other-modules: Svg
+ hs-source-dirs: examples
+ build-depends:
+ base,
+ filepath ^>=1.5,
+ text,
+ lipstick
+ default-language: GHC2024
+
+test-suite lipstick-test
+ import: warnings
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ -- The tests reach the library's internals by compiling its sources, so
+ -- other-modules and build-depends must include the library's.
+ hs-source-dirs: test src internal
+ other-modules:
+ Lipstick
+ Lipstick.Ansi
+ Lipstick.Block
+ Lipstick.Border
+ Lipstick.Color
+ Lipstick.Grid
+ Lipstick.Layer
+ Lipstick.Mod
+ Lipstick.Place
+ Lipstick.Style
+ Lipstick.Table
+ Lipstick.Outline
+ Lipstick.Terminal
+ Lipstick.Width
+ Lipstick.Internal.Border
+ Lipstick.Internal.Color
+ Lipstick.Internal.Grid
+ Lipstick.Internal.Layout
+ Lipstick.Internal.Mod
+ Lipstick.Internal.Types
+ Lipstick.Internal.UnicodeTable
+ Lipstick.Internal.Width
+ build-depends:
+ base >=4.20 && <4.23,
+ array ^>=0.5,
+ bytestring >=0.11 && <0.13,
+ text >=2.1.2 && <2.2,
+ ansi-terminal ^>=1.1,
+ terminal-size >=0.3.4 && <0.4,
+ colour ^>=2.3,
+ containers >=0.6 && <0.9,
+ directory,
+ tasty ^>=1.5,
+ tasty-hunit ^>=0.10,
+ tasty-quickcheck ^>=0.11,
+ QuickCheck >=2.14 && <2.20
+ default-language: GHC2024
diff --git a/scripts/GenUnicodeTable.hs b/scripts/GenUnicodeTable.hs
new file mode 100644
--- /dev/null
+++ b/scripts/GenUnicodeTable.hs
@@ -0,0 +1,186 @@
+-- | Generate internal/Lipstick/Internal/UnicodeTable.hs from the Unicode
+-- Character Database.
+--
+-- Usage:
+--
+-- > runghc scripts/GenUnicodeTable.hs VERSION UCD_DIR > internal/Lipstick/Internal/UnicodeTable.hs
+--
+-- where UCD_DIR holds, side by side, EastAsianWidth.txt,
+-- GraphemeBreakProperty.txt, emoji-data.txt and DerivedCoreProperties.txt,
+-- downloaded from https://www.unicode.org/Public/VERSION/ucd/ (the second
+-- from auxiliary/, the third from emoji/).
+--
+-- The tests pin the tables to Unicode 16.0.0. To move to another version,
+-- also update the version that test/Main.hs and the Lipstick.Width
+-- doctest expect, and test/data/GraphemeBreakTest.txt (from auxiliary/).
+--
+-- The table maps every code point to a packed Word16:
+--
+-- * bits 0–3: grapheme cluster break property (see gcbCode)
+-- * bit 4: East Asian Width is W or F
+-- * bit 5: Extended_Pictographic
+-- * bit 6: Emoji
+-- * bits 7–8: Indic_Conjunct_Break (0 None, 1 Linker, 2 Consonant, 3 Extend)
+--
+-- and is stored run-length encoded as the start of each run and its value.
+module Main (main) where
+
+import Control.Monad (forM_, when)
+import Data.Array.ST (newArray, readArray, runSTUArray, writeArray)
+import Data.Array.Unboxed (UArray, assocs)
+import Data.Bits (complement, shiftL, (.&.), (.|.))
+import Data.Char (isSpace)
+import Data.List (intercalate, isPrefixOf)
+import Data.Word (Word16)
+import Numeric (readHex)
+import System.Environment (getArgs)
+import System.FilePath (())
+
+main :: IO ()
+main = do
+ [version, dir] <- getArgs
+ eaw <- readFile (dir "EastAsianWidth.txt")
+ gcb <- readFile (dir "GraphemeBreakProperty.txt")
+ emoji <- readFile (dir "emoji-data.txt")
+ dcp <- readFile (dir "DerivedCoreProperties.txt")
+
+ let wide =
+ [ r
+ | (r, [w]) <- missing eaw ++ entries eaw
+ , w `elem` ["W", "F"]
+ ]
+ -- @missing lines give defaults and come first, so later explicit
+ -- entries override them; record which ranges are explicitly not wide.
+ notWide = [r | (r, [w]) <- entries eaw, w `notElem` ["W", "F"]]
+ gcbs = [(r, gcbCode p) | (r, [p]) <- entries gcb]
+ pict = [r | (r, ["Extended_Pictographic"]) <- entries emoji]
+ emo = [r | (r, ["Emoji"]) <- entries emoji]
+ incb = [(r, incbCode v) | (r, ["InCB", v]) <- entries dcp]
+
+ table :: UArray Int Word16
+ table = runSTUArray $ do
+ arr <- newArray (0, 0x10FFFF) 0
+ let paint (lo, hi) f = forM_ [lo .. hi] $ \i -> readArray arr i >>= writeArray arr i . f
+ forM_ wide $ \r -> paint r (.|. bit 4)
+ forM_ notWide $ \r -> paint r (.&. complement (bit 4))
+ forM_ gcbs $ \(r, v) -> paint r (\x -> (x .&. complement 0xF) .|. v)
+ forM_ pict $ \r -> paint r (.|. bit 5)
+ forM_ emo $ \r -> paint r (.|. bit 6)
+ forM_ incb $ \(r, v) -> paint r (\x -> (x .&. complement (3 `shiftL` 7)) .|. (v `shiftL` 7))
+ pure arr
+
+ runs = compress (assocs table)
+
+ when (null runs) (error "empty table")
+ putStr (render version runs)
+
+bit :: Int -> Word16
+bit n = 1 `shiftL` n
+
+gcbCode :: String -> Word16
+gcbCode p = case p of
+ "CR" -> 1
+ "LF" -> 2
+ "Control" -> 3
+ "Extend" -> 4
+ "ZWJ" -> 5
+ "Regional_Indicator" -> 6
+ "Prepend" -> 7
+ "SpacingMark" -> 8
+ "L" -> 9
+ "V" -> 10
+ "T" -> 11
+ "LV" -> 12
+ "LVT" -> 13
+ _ -> error ("unknown grapheme break property " ++ p)
+
+incbCode :: String -> Word16
+incbCode v = case v of
+ "Linker" -> 1
+ "Consonant" -> 2
+ "Extend" -> 3
+ _ -> error ("unknown InCB value " ++ v)
+
+-- | Data lines: a code point range and the semicolon-separated fields.
+entries :: String -> [((Int, Int), [String])]
+entries = concatMap entry . lines
+ where
+ entry l = case splitFields (takeWhile (/= '#') l) of
+ r : fields | not (null r) -> [(range r, fields)]
+ _ -> []
+
+-- | Default values from "# @missing: 3400..4DBF; W" lines.
+missing :: String -> [((Int, Int), [String])]
+missing = concatMap entry . lines
+ where
+ prefix = "# @missing: "
+ entry l
+ | prefix `isPrefixOf` l = case splitFields (drop (length prefix) l) of
+ r : fields -> [(range r, fields)]
+ [] -> []
+ | otherwise = []
+
+splitFields :: String -> [String]
+splitFields s = case map trim (splitOn ';' s) of
+ [""] -> []
+ fs -> fs
+ where
+ splitOn c xs = case break (== c) xs of
+ (a, []) -> [a]
+ (a, _ : rest) -> a : splitOn c rest
+ trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+range :: String -> (Int, Int)
+range r = case break (== '.') r of
+ (lo, []) -> (hexInt lo, hexInt lo)
+ (lo, _ : _ : hi) -> (hexInt lo, hexInt hi)
+ _ -> error ("bad range " ++ r)
+ where
+ hexInt h = case readHex h of
+ [(n, "")] -> n
+ _ -> error ("bad code point " ++ h)
+
+compress :: [(Int, Word16)] -> [(Int, Word16)]
+compress = go Nothing
+ where
+ go _ [] = []
+ go prev ((i, v) : rest)
+ | Just v == prev = go prev rest
+ | otherwise = (i, v) : go (Just v) rest
+
+render :: String -> [(Int, Word16)] -> String
+render version runs =
+ unlines $
+ [ "-- | Generated by scripts/GenUnicodeTable.hs from the Unicode " ++ version
+ , "-- Character Database. Do not edit; to regenerate, see the header of"
+ , "-- that script."
+ , "--"
+ , "-- The data is derived from the Unicode Character Database, © Unicode, Inc.,"
+ , "-- under the Unicode License v3: see LICENSE.Unicode."
+ , "module Lipstick.Internal.UnicodeTable (unicodeTableVersion, runStarts, runValues) where"
+ , ""
+ , "import Data.Array.Unboxed (UArray, listArray)"
+ , "import Data.Word (Word16)"
+ , ""
+ , "unicodeTableVersion :: String"
+ , "unicodeTableVersion = " ++ show version
+ , ""
+ , "-- | First code point of each run, ascending."
+ , "runStarts :: UArray Int Int"
+ , "runStarts = listArray (0, " ++ show (n - 1) ++ ")"
+ ]
+ ++ listLines (map (show . fst) runs)
+ ++ [ ""
+ , "-- | Packed properties of each run."
+ , "runValues :: UArray Int Word16"
+ , "runValues = listArray (0, " ++ show (n - 1) ++ ")"
+ ]
+ ++ listLines (map (show . snd) runs)
+ where
+ n = length runs
+ listLines xs = case chunk 16 xs of
+ [] -> [" []"]
+ c : cs -> (" [ " ++ intercalate ", " c) : map ((" , " ++) . intercalate ", ") cs ++ [" ]"]
+ chunk k xs = case splitAt k xs of
+ ([], _) -> []
+ (a, b) -> a : chunk k b
diff --git a/src/Lipstick.hs b/src/Lipstick.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick.hs
@@ -0,0 +1,531 @@
+-- | Style definitions for nice terminal layouts: colours, borders,
+-- padding, alignment, tables, lists, trees and layered compositions,
+-- printed with ANSI escape sequences.
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > import Lipstick
+-- >
+-- > card :: Mod Style
+-- > card = bold <> fg "#FAFAFA" <> bg "#7D56F4" <> padding 1 4 <> width 22
+-- >
+-- > main :: IO ()
+-- > main = putBlock (render card "Hello, kitty")
+--
+-- == Concepts
+--
+-- [Modifiers] A @'Mod' f@ is a change to a thing @f@: a 'Style', a
+-- 'Table', an 'Outline', a 'Place' or a 'Layer', or the 'Inline' text of
+-- 'styled'. Modifiers form a monoid: '<>' applies the left one first, so
+-- later settings win, and 'mempty' changes nothing. Text attributes
+-- ('fg', 'bold', 'link', …) work on every thing. The other modifiers work
+-- on the things that have the part they set. The classes 'HasBox',
+-- 'HasBorder', 'HasSize', 'HasAlign', 'HasWrap' and 'HasCrop' say which
+-- things have the parts that several share; the rest, such as 'offset'
+-- and 'cellStyle', belong to one thing. A modifier on a thing without
+-- that part is a type error. A modifier for several kinds of thing that
+-- uses these classes needs a signature, as in
+-- @boxed :: (HasBorder f, HasSize f) => Mod f@: without one, the
+-- monomorphism restriction gives it a single type.
+--
+-- [Text] 'Inline' is text with styles: string literals, 'styled' pieces
+-- joined with '<>', and text with escape sequences read by 'fromAnsi'.
+-- Styles nest, and the enclosing style shows through wherever an inner
+-- one does not set an attribute.
+--
+-- [Blocks] A 'Block' is a rectangle of styled text: 'render' and
+-- 'frame' draw text and blocks in a box, and 'table', 'list', 'tree',
+-- 'place' and 'compose' make the other kinds. Blocks are joined with
+-- 'hcat', 'vcat', 'joinHorizontal' and 'joinVertical'. A block is not laid
+-- out until it is printed: it knows the narrowest width it can take
+-- without breaking words and the width it would like, and is laid out in
+-- the width it is given, so text wraps, table columns shrink, and blocks
+-- with 'fillWidth' take the spare columns of their row. The text settings
+-- of a style ('align', 'noWrap', 'breakAfter', 'tabWidth', 'transform',
+-- 'inline') also apply to the text inside the blocks it frames, unless
+-- something nearer sets them again.
+--
+-- [Sizes] @'width' n@ makes a thing @n@ columns wide when there is room
+-- (a table with 'fitContent' at most @n@), and narrower when there is
+-- not. @'height' n@ is the least number of lines. 'maxWidth' and
+-- 'maxHeight' crop the result to at most that many columns and lines;
+-- with 'maxHeight', a table leaves out body rows instead. For a style,
+-- 'width' and 'height' include padding and border but not margins, and
+-- the crops include margins too.
+--
+-- [Output] Nothing becomes escape sequences until a block is printed.
+-- A 'RenderEnv' says what the output can show (the colour profile,
+-- whether the background is dark) and its width; 'putBlock' detects it
+-- for the terminal, 'toAnsi' gives the text for a given one, and
+-- 'renderPlain' gives text without escape sequences. Adaptive colours
+-- ('lightDark', 'complete') are resolved then, and colours are reduced
+-- to what the output supports. 'layout' gives the laid-out 'Grid', to
+-- show blocks in other ways ("Lipstick.Grid", the lipstick-brick
+-- package).
+--
+-- == Names
+--
+-- The names are short and some are common: 'bold', 'fg', 'border',
+-- 'center', 'text', 'render', 'width' and the colour names are also
+-- exported by brick, vty, colour or prettyprinter. Programs that use
+-- those as well can import lipstick qualified,
+--
+-- > import Lipstick qualified as L
+--
+-- or import only the names they need.
+--
+-- == Modules
+--
+-- This module exports what most programs need. The API is also split
+-- into modules by feature, each with more examples, and "Lipstick.Grid",
+-- "Lipstick.Width" and "Lipstick.Terminal" have a few functions more:
+--
+-- * "Lipstick.Mod": modifiers, which configure everything below
+-- * "Lipstick.Style": text in a box with padding, border and margins
+-- * "Lipstick.Block": blocks of text, and joining them
+-- * "Lipstick.Place": a block in a larger area
+-- * "Lipstick.Border": border character sets
+-- * "Lipstick.Table": tables
+-- * "Lipstick.Outline": lists and trees
+-- * "Lipstick.Layer": blocks stacked at any position
+-- * "Lipstick.Color": colours and gradients
+-- * "Lipstick.Terminal": printing, and detecting what the terminal supports
+-- * "Lipstick.Ansi": blocks as text with escape sequences, and back
+-- * "Lipstick.Width": the display width of text
+-- * "Lipstick.Grid": laid-out blocks, for other outputs
+--
+-- Most examples print with 'putBlock', whose output is shown without
+-- colours and other attributes. All of them need @OverloadedStrings@.
+module Lipstick
+ ( -- * Modifiers
+ -- | A @'Mod' f@ configures a thing @f@. Modifiers combine with '<>',
+ -- and later settings win. See "Lipstick.Mod".
+ --
+ -- >>> let card = bold <> fg "#FAFAFA" <> bg "#7D56F4" <> border roundedBorder <> padding 0 1
+ -- >>> putBlock (render card "a card")
+ -- ╭────────╮
+ -- │ a card │
+ -- ╰────────╯
+ -- >>> putBlock (render (card <> border doubleBorder) "a card with a double border")
+ -- ╔═════════════════════════════╗
+ -- ║ a card with a double border ║
+ -- ╚═════════════════════════════╝
+ Mod
+ , HasBox
+ , HasBorder
+ , HasSize
+ , HasAlign
+ , HasWrap
+ , HasCrop
+
+ -- * Styles
+ -- | A style draws text, or a block, in a box. See "Lipstick.Style".
+ --
+ -- >>> putBlock (render (width 20 <> border normalBorder <> align center) "Text wraps to fit the width")
+ -- ┌──────────────────┐
+ -- │Text wraps to fit │
+ -- │ the width │
+ -- └──────────────────┘
+ -- >>> putBlock (frame (border roundedBorder) (render (border normalBorder) "nested"))
+ -- ╭────────╮
+ -- │┌──────┐│
+ -- ││nested││
+ -- │└──────┘│
+ -- ╰────────╯
+ , Style
+ , render
+ , frame
+ , inherit
+ , tabWidth
+ , unsetTabWidth
+ , inline
+ , unsetInline
+ , transform
+ , unsetTransform
+ , breakAfter
+ , colorWhitespace
+ , underlineSpaces
+ , strikethroughSpaces
+
+ -- * Blocks
+ -- | A block is a rectangle of styled text, laid out in the width it is
+ -- given. See "Lipstick.Block".
+ --
+ -- >>> let para = text "A block takes the width it is given."
+ -- >>> putBlock para
+ -- A block takes the width it is given.
+ -- >>> putBlock (fromGrid (layout (Just 16) para))
+ -- A block takes
+ -- the width it is
+ -- given.
+ -- >>> putBlock (fromInline (styled bold "Error: " <> "file not found"))
+ -- Error: file not found
+ , Block
+ , blockWidth
+ , blockHeight
+ , blockMinWidth
+ , blockGrows
+ , emptyBlock
+ , text
+ , fromInline
+ , layout
+ , Grid
+ , gridWidth
+ , gridHeight
+ , fromGrid
+ , Inline
+ , plain
+ , styled
+ , fromAnsi
+ , escapeUri
+ , styleRanges
+ , styleIndices
+ , Attrs (attrFg, attrBg, attrUnderlineColor, attrBold, attrFaint, attrItalic, attrBlink, attrReverse, attrStrikethrough, attrUnderline, attrLink)
+
+ -- * Layout
+ -- | Blocks side by side, stacked, or placed in a larger area. See
+ -- "Lipstick.Block" and "Lipstick.Place".
+ --
+ -- >>> let tall = render (border normalBorder) "one\ntwo\nthree"
+ -- >>> let short = render (border normalBorder) "four"
+ -- >>> putBlock (joinHorizontal center [tall, short])
+ -- ┌─────┐
+ -- │one │┌────┐
+ -- │two ││four│
+ -- │three│└────┘
+ -- └─────┘
+ -- >>> putBlock (place (width 12 <> height 3 <> align center <> valign center <> whitespaceChars "·") "centred")
+ -- ············
+ -- ··centred···
+ -- ············
+ , joinHorizontal
+ , joinVertical
+ , hcat
+ , vcat
+ , Place
+ , place
+ , whitespaceChars
+ , Position
+ , position
+ , left
+ , center
+ , right
+ , top
+ , bottom
+
+ -- * Text attributes
+ -- | Text attributes are modifiers of every thing.
+ --
+ -- >>> toAnsi defaultRenderEnv (render (bold <> underline <> fg red) "hi")
+ -- "\ESC[0;1;4;31mhi\ESC[0m"
+ -- >>> toAnsi defaultRenderEnv (render (link "https://example.com") "a link")
+ -- "\ESC]8;;https://example.com\ESC\\a link\ESC]8;;\ESC\\"
+ , bold
+ , faint
+ , italic
+ , blink
+ , reverseVideo
+ , strikethrough
+ , Flag (..)
+ , flag
+ , unsetFlag
+ , underline
+ , Underline (..)
+ , underlineStyle
+ , underlineColor
+ , fg
+ , bg
+ , unsetFg
+ , unsetBg
+ , unsetUnderline
+ , unsetUnderlineColor
+ , link
+ , unsetLink
+
+ -- * Padding and margins
+ -- | 'padding' and 'margin' take vertical then horizontal amounts.
+ --
+ -- >>> putBlock (render (border normalBorder <> padding 1 2 <> paddingChar '·' <> margin 0 2 <> marginChar '░') "box")
+ -- ░░┌───────┐░░
+ -- ░░│·······│░░
+ -- ░░│··box··│░░
+ -- ░░│·······│░░
+ -- ░░└───────┘░░
+ , padding
+ , paddingAll
+ , paddingTop
+ , paddingRight
+ , paddingBottom
+ , paddingLeft
+ , margin
+ , marginAll
+ , marginTop
+ , marginRight
+ , marginBottom
+ , marginLeft
+ , marginBg
+ , paddingChar
+ , marginChar
+ , unsetPadding
+ , unsetMargins
+ , unsetMarginBg
+ , Sides (..)
+
+ -- * Borders
+ -- | See "Lipstick.Border" for all the border character sets.
+ --
+ -- >>> putBlock (hcat [render (border b) "text" | b <- [normalBorder, roundedBorder, thickBorder, doubleBorder]])
+ -- ┌────┐╭────╮┏━━━━┓╔════╗
+ -- │text││text│┃text┃║text║
+ -- └────┘╰────╯┗━━━━┛╚════╝
+ -- >>> putBlock (render (border roundedBorder <> borderBottom False) "open below")
+ -- ╭──────────╮
+ -- │open below│
+ , Border (topEdge, bottomEdge, leftEdge, rightEdge, topLeftCorner, topRightCorner, bottomLeftCorner, bottomRightCorner, middleLeft, middleRight, middle, middleTop, middleBottom)
+ , border
+ , borderFg
+ , borderBg
+ , borderFgBlend
+ , borderFgBlendOffset
+ , borderTopFg
+ , borderRightFg
+ , borderBottomFg
+ , borderLeftFg
+ , borderTopBg
+ , borderRightBg
+ , borderBottomBg
+ , borderLeftBg
+ , unsetBorder
+ , borderTop
+ , borderRight
+ , borderBottom
+ , borderLeft
+ , normalBorder
+ , roundedBorder
+ , thickBorder
+ , doubleBorder
+ , blockBorder
+ , outerHalfBlockBorder
+ , innerHalfBlockBorder
+ , hiddenBorder
+ , asciiBorder
+ , markdownBorder
+
+ -- * Size, alignment and wrapping
+ -- | For a style, 'width' and 'height' include padding and border but
+ -- not margins, and 'maxWidth' and 'maxHeight' crop margins too. With
+ -- less room than its 'width', a thing shrinks.
+ --
+ -- >>> putBlock (render (width 12 <> height 4 <> border normalBorder <> align right <> valign bottom) "corner")
+ -- ┌──────────┐
+ -- │ │
+ -- │ corner│
+ -- └──────────┘
+ -- >>> putBlock (render (width 14 <> border normalBorder <> noWrap) "This line is too long")
+ -- ┌────────────┐
+ -- │This line i…│
+ -- └────────────┘
+ , width
+ , height
+ , maxWidth
+ , maxHeight
+ , grow
+ , fillWidth
+ , stretchHeight
+ , unsetWidth
+ , unsetHeight
+ , unsetMaxWidth
+ , unsetMaxHeight
+ , align
+ , valign
+ , unsetAlign
+ , noWrap
+ , unsetNoWrap
+
+ -- * Getters
+ -- | The settings of a modifier, read back: what it sets, not what it
+ -- inherits inside a 'frame' (see "Lipstick.Style").
+ --
+ -- >>> let s = border normalBorder <> padding 1 2 <> width 20
+ -- >>> (getWidth s, getPadding s, frameSize s)
+ -- (Just 20,Sides {sideTop = 1, sideRight = 2, sideBottom = 1, sideLeft = 2},(6,4))
+ , getAttrs
+ , getMaxWidth
+ , getMaxHeight
+ , getPadding
+ , getMargins
+ , getMarginBg
+ , getBorder
+ , getBorderSides
+ , getWidth
+ , getHeight
+ , getAlign
+ , getVAlign
+ , getTabWidth
+ , getInline
+ , horizontalPadding
+ , verticalPadding
+ , horizontalMargins
+ , verticalMargins
+ , horizontalBorderSize
+ , verticalBorderSize
+ , horizontalFrameSize
+ , verticalFrameSize
+ , frameSize
+
+ -- * Tables
+ -- | See "Lipstick.Table".
+ --
+ -- >>> putBlock (table (headerStyle (align center) <> cellStyle (const (padding 0 1))) ["Language", "Greeting"] [["Japanese", "こんにちは"], ["Russian", "Привет"]])
+ -- ╭──────────┬────────────╮
+ -- │ Language │ Greeting │
+ -- ├──────────┼────────────┤
+ -- │ Japanese │ こんにちは │
+ -- │ Russian │ Привет │
+ -- ╰──────────┴────────────╯
+ , Table
+ , table
+ , TableCell (..)
+ , cellRow
+ , cellColumn
+ , cellStyle
+ , headerStyle
+ , headerRule
+ , columnRules
+ , rowRules
+ , yOffset
+ , fitContent
+ , visibleRows
+
+ -- * Lists and trees
+ -- | See "Lipstick.Outline".
+ --
+ -- >>> putBlock (tree mempty (Node "." [Node "macOS" [], Node "Linux" [Node "NixOS" [], Node "Arch" []]]))
+ -- .
+ -- ├── macOS
+ -- └── Linux
+ -- ├── NixOS
+ -- └── Arch
+ -- >>> putBlock (list (enumerator arabic) ["Glossier", "Claire's Boutique", "Nyx"])
+ -- 1. Glossier
+ -- 2. Claire's Boutique
+ -- 3. Nyx
+ , Outline
+ , tree
+ , forest
+ , list
+ , nestedList
+ , Tree (..)
+ , Forest
+ , ItemPos (itemDepth, itemIndex, itemSiblings)
+ , rootStyle
+ , itemStyle
+ , itemStyleWith
+ , enumeratorStyle
+ , enumeratorStyleWith
+ , indenterStyle
+ , indenterStyleWith
+ , itemOffset
+ , Enumerator (enumMarker, enumIndent)
+ , markers
+ , enumerator
+ , byDepth
+ , isLast
+ , indenter
+ , treeEnumerator
+ , roundedTreeEnumerator
+ , bullet
+ , dash
+ , asterisk
+ , arabic
+ , alphabet
+ , roman
+
+ -- * Colours
+ -- | See "Lipstick.Color".
+ --
+ -- >>> blend 3 ["#ff0000", "#0000ff"]
+ -- [rgb 255 0 0,rgb 140 83 162,rgb 0 0 255]
+ -- >>> resolveColor TrueColor True (lightDark "#5A3FC0" "#B39DFF")
+ -- Just (TCRGB 179 157 255)
+ , module Lipstick.Color
+
+ -- * Output
+ -- | Printing detects what the output supports; 'toAnsi' gives the text
+ -- for an environment of your own. See "Lipstick.Terminal" and
+ -- "Lipstick.Ansi".
+ --
+ -- >>> toAnsi defaultRenderEnv {envProfile = ANSI16} (render (fg "#F25D94") "pink")
+ -- "\ESC[0;35mpink\ESC[0m"
+ -- >>> renderPlain (render (fg "#F25D94") "pink")
+ -- "pink"
+ , RenderEnv
+ , envProfile
+ , envDarkBackground
+ , envWidth
+ , defaultRenderEnv
+ , toAnsi
+ , toAnsiLines
+ , renderPlain
+ , putBlock
+ , hPutBlock
+ , hPutBlockWith
+ , detectEnv
+ , detectEnvQuery
+ , detectProfile
+ , detectWidth
+ , queryDarkBackground
+
+ -- * Compositing
+ -- | Blocks on top of each other. See "Lipstick.Layer".
+ --
+ -- >>> let background = place (width 20 <> height 5 <> whitespaceChars "╱") emptyBlock
+ -- >>> putBlock (overlay 3 1 (render (border roundedBorder <> padding 0 1) "dialog") background)
+ -- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+ -- ╱╱╱╭────────╮╱╱╱╱╱╱╱
+ -- ╱╱╱│ dialog │╱╱╱╱╱╱╱
+ -- ╱╱╱╰────────╯╱╱╱╱╱╱╱
+ -- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+ , Layer
+ , layer
+ , offset
+ , zIndex
+ , layerId
+ , transparent
+ , sublayers
+ , compose
+ , overlay
+ , layerAt
+ , layerHit
+ , findLayer
+ , Rect (rectX, rectY, rectWidth, rectHeight)
+
+ -- * Measuring text
+ -- | Display widths. See "Lipstick.Width".
+ --
+ -- >>> textWidth "こんにちは"
+ -- 10
+ -- >>> ansiWidth "\ESC[1mbold\ESC[0m"
+ -- 4
+ , textWidth
+ , ansiWidth
+ , ansiHeight
+ , unicodeVersion
+ ) where
+
+import Data.Tree (Forest, Tree (..))
+import Lipstick.Ansi
+import Lipstick.Block
+import Lipstick.Border
+import Lipstick.Color
+import Lipstick.Internal.Types
+import Lipstick.Layer
+import Lipstick.Mod
+import Lipstick.Outline
+import Lipstick.Place
+import Lipstick.Style
+import Lipstick.Table
+import Lipstick.Terminal
+import Lipstick.Width (textWidth, unicodeVersion)
+
+-- $setup
+-- >>> import Lipstick
diff --git a/src/Lipstick/Ansi.hs b/src/Lipstick/Ansi.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Ansi.hs
@@ -0,0 +1,374 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Serialising blocks to text with ANSI escape sequences, and parsing
+-- such text back into styled 'Inline' text.
+--
+-- == Examples
+--
+-- A block as text with escape sequences, for a 'RenderEnv':
+--
+-- >>> let hi = render (bold <> fg "#F25D94") "hi"
+-- >>> toAnsi defaultRenderEnv hi
+-- "\ESC[0;1;38;2;242;93;148mhi\ESC[0m"
+-- >>> toAnsi defaultRenderEnv {envProfile = ANSI256} hi
+-- "\ESC[0;1;38;5;204mhi\ESC[0m"
+-- >>> toAnsi defaultRenderEnv {envProfile = ANSI16} hi
+-- "\ESC[0;1;35mhi\ESC[0m"
+-- >>> toAnsi defaultRenderEnv {envProfile = NoTTY} hi
+-- "hi"
+--
+-- Each line on its own, or without any escape sequences:
+--
+-- >>> toAnsiLines defaultRenderEnv (vcat [render (fg red) "hi", "there"])
+-- ["\ESC[0;31mhi\ESC[0m ","there"]
+-- >>> renderPlain (vcat [render (fg red) "hi", "there"])
+-- "hi \nthere"
+--
+-- The 'envWidth' is the width blocks are laid out in:
+--
+-- >>> renderPlain (render (border asciiBorder <> fillWidth) "hi")
+-- "+--+\n|hi|\n+--+"
+-- >>> toAnsi defaultRenderEnv {envProfile = NoTTY, envWidth = Just 10} (render (border asciiBorder <> fillWidth) "hi")
+-- "+--------+\n|hi |\n+--------+"
+--
+-- Text that already has escape sequences, such as another program's
+-- output, becomes 'Inline' text with the same attributes:
+--
+-- >>> let report = fromAnsi "\ESC[1;32mok\ESC[0m 3 tests passed"
+-- >>> putBlock (render (border roundedBorder <> padding 0 1) report)
+-- ╭───────────────────╮
+-- │ ok 3 tests passed │
+-- ╰───────────────────╯
+-- >>> toAnsi defaultRenderEnv (fromInline report)
+-- "\ESC[0;1;32mok\ESC[0m 3 tests passed"
+-- >>> ansiWidth "\ESC[1;32mok\ESC[0m 3 tests passed"
+-- 17
+module Lipstick.Ansi
+ ( RenderEnv
+ , envProfile
+ , envDarkBackground
+ , envWidth
+ , defaultRenderEnv
+ , toAnsi
+ , toAnsiLines
+ , renderPlain
+ , escapeUri
+ , fromAnsi
+ , ansiWidth
+ , ansiHeight
+ ) where
+
+import Data.Array (Array, listArray, (!))
+import Data.Char (isDigit)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Word (Word8)
+import Lipstick.Color
+import Lipstick.Internal.Color (Color (..))
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Layout (Block, layout)
+import Lipstick.Internal.Types
+
+-- $setup
+-- >>> import Lipstick
+
+-- | What the output can display, and the width to lay blocks out in.
+-- Change 'defaultRenderEnv' with record update syntax.
+data RenderEnv = RenderEnv
+ { envProfile :: !ColorProfile
+ -- ^ the colours and attributes the output can display
+ , envDarkBackground :: !Bool
+ -- ^ whether 'lightDark' colours take their dark variant
+ , envWidth :: !(Maybe Int)
+ -- ^ the width blocks are laid out in; 'Nothing' for their natural width
+ }
+ deriving (Eq, Show)
+
+-- | True colour on a dark background, blocks at their natural width.
+defaultRenderEnv :: RenderEnv
+defaultRenderEnv = RenderEnv TrueColor True Nothing
+
+-- | 'toAnsiLines' joined with newlines, without a trailing newline.
+toAnsi :: RenderEnv -> Block -> Text
+toAnsi env = T.intercalate (T.singleton '\n') . toAnsiLines env
+
+-- | The block laid out in the 'envWidth', one 'Text' per line. Every line
+-- is the block's full width, padded with spaces, and stands alone:
+-- attributes are reset and hyperlinks closed at its end.
+toAnsiLines :: RenderEnv -> Block -> [Text]
+toAnsiLines env = map (T.concat . renderLine env) . gridLines . layout (envWidth env)
+
+-- | The block at its natural width, without any escape sequences.
+renderPlain :: Block -> Text
+renderPlain = toAnsi (RenderEnv NoTTY True Nothing)
+
+-- | Fully resolved graphic rendition.
+data SGR = SGR
+ { sgrFg, sgrBg, sgrUl :: !(Maybe TermColor)
+ , sgrBold, sgrFaint, sgrItalic, sgrBlink, sgrReverse, sgrStrike :: !Bool
+ , sgrUnderline :: !Underline
+ }
+ deriving (Eq)
+
+plainSGR :: SGR
+plainSGR = SGR Nothing Nothing Nothing False False False False False False NoUnderline
+
+resolveAttrs :: RenderEnv -> Attrs -> (SGR, Maybe Text)
+resolveAttrs (RenderEnv NoTTY _ _) _ = (plainSGR, Nothing)
+resolveAttrs (RenderEnv p dark _) a =
+ ( SGR
+ { sgrFg = col (attrFg a)
+ , sgrBg = col (attrBg a)
+ , sgrUl = if ul /= NoUnderline && p >= ANSI256 then col (attrUnderlineColor a) else Nothing
+ , sgrBold = on attrBold
+ , sgrFaint = on attrFaint
+ , sgrItalic = on attrItalic
+ , sgrBlink = on attrBlink
+ , sgrReverse = on attrReverse
+ , sgrStrike = on attrStrikethrough
+ , sgrUnderline = if ul /= NoUnderline && p < TrueColor then SingleUnderline else ul
+ }
+ , attrLink a
+ )
+ where
+ col c = c >>= resolveColor p dark
+ on f = fromMaybe False (f a)
+ ul = fromMaybe NoUnderline (attrUnderline a)
+
+-- | The pieces of a line: cluster texts and escape sequences, to be joined
+-- with one 'T.concat'. Attributes are resolved only where they change.
+renderLine :: RenderEnv -> Line -> [Text]
+renderLine env = go plainSGR Nothing Nothing . lineCells
+ where
+ go cur lnk _ [] =
+ [sgrCode plainSGR | cur /= plainSGR] ++ [closeLink | Just _ <- [lnk]]
+ go cur lnk prev (Cell a t _ _ : rest)
+ | Just a == prev = t : go cur lnk prev rest
+ | otherwise =
+ let (sgr, lnk') = resolveAttrs env a
+ linkB
+ | lnk' == lnk = []
+ | otherwise = [closeLink | Just _ <- [lnk]] ++ [openLink u | Just u <- [lnk']]
+ sgrB = [sgrCode sgr | sgr /= cur]
+ in linkB ++ sgrB ++ t : go sgr lnk' (Just a) rest
+
+openLink :: Text -> Text
+openLink url = T.concat ["\ESC]8;;", escapeUri url, "\ESC\\"]
+
+closeLink :: Text
+closeLink = "\ESC]8;;\ESC\\"
+
+-- | A complete SGR sequence: reset, then every active attribute.
+sgrCode :: SGR -> Text
+sgrCode s = T.concat ["\ESC[", T.intercalate ";" ("0" : params), "m"]
+ where
+ params =
+ concat
+ [ ["1" | sgrBold s]
+ , ["2" | sgrFaint s]
+ , ["3" | sgrItalic s]
+ , underlineParams (sgrUnderline s)
+ , ["5" | sgrBlink s]
+ , ["7" | sgrReverse s]
+ , ["9" | sgrStrike s]
+ , maybe [] (colorParams 30 90 "38") (sgrFg s)
+ , maybe [] (colorParams 40 100 "48") (sgrBg s)
+ , maybe [] ulColorParams (sgrUl s)
+ ]
+ underlineParams = \case
+ NoUnderline -> []
+ SingleUnderline -> ["4"]
+ DoubleUnderline -> ["4:2"]
+ CurlyUnderline -> ["4:3"]
+ DottedUnderline -> ["4:4"]
+ DashedUnderline -> ["4:5"]
+ colorParams :: Word8 -> Word8 -> Text -> TermColor -> [Text]
+ colorParams base brightBase ext = \case
+ TC16 n
+ | n < 8 -> [decimal (base + n)]
+ | otherwise -> [decimal (brightBase + n - 8)]
+ TC256 n -> [ext, "5", decimal n]
+ TCRGB r g b -> [ext, "2", decimal r, decimal g, decimal b]
+ ulColorParams = \case
+ TC16 n -> ["58", "5", decimal n]
+ TC256 n -> ["58", "5", decimal n]
+ TCRGB r g b -> ["58", "2", decimal r, decimal g, decimal b]
+
+-- | A byte in decimal, from a table: SGR parameters are all bytes.
+decimal :: Word8 -> Text
+decimal = (numbers !)
+ where
+ numbers :: Array Word8 Text
+ numbers = listArray (0, 255) [T.pack (show i) | i <- [0 :: Int .. 255]]
+
+-- Parsing ---------------------------------------------------------------------
+
+-- | Parse text containing ANSI escape sequences, such as the output of
+-- another program, into styled text.
+--
+-- SGR sequences (colours, attributes, underline styles and colours) and
+-- OSC 8 hyperlinks are kept; every other escape sequence is dropped, along
+-- with the payload of control strings (DCS, SOS, PM, APC: sixel and kitty
+-- graphics, tmux passthrough).
+-- Sequences that switch an attribute off (such as @22@ or @39@) unset it,
+-- so the attributes of an enclosing style show through, and a reset
+-- reveals the enclosing style completely but does not end a hyperlink,
+-- which only OSC 8 does.
+fromAnsi :: Text -> Inline
+fromAnsi = Inline . go mempty
+ where
+ -- ESC, and the 8-bit forms of CSI, OSC and the control strings.
+ isEscape c = c == '\ESC' || c `elem` ['\x9B', '\x9D', '\x90', '\x98', '\x9E', '\x9F']
+
+ go a t =
+ let (txt, rest) = T.break isEscape t
+ in [(a, txt) | not (T.null txt)] ++ case T.uncons rest of
+ Nothing -> []
+ Just ('\x9B', r) -> csi a r
+ Just ('\x9D', r) -> osc a r
+ Just ('\ESC', r) -> case T.uncons r of
+ Just ('[', r') -> csi a r'
+ Just (']', r') -> osc a r'
+ Just (c, r')
+ -- DCS, SOS, PM, APC
+ | c `elem` ['P', 'X', '^', '_'] -> go a (controlString r')
+ -- ESC, intermediates, final (e.g. ESC ( B)
+ | c >= ' ' && c <= '/' -> go a (escFinal (T.dropWhile (\x -> x >= ' ' && x <= '/') r'))
+ | otherwise -> go a (escFinal r)
+ Nothing -> []
+ Just (_, r) -> go a (controlString r)
+
+ -- CSI: parameters, intermediates, final byte; anything else cuts it
+ -- short and is kept, as after ESC. Only a sequence with neither a
+ -- private marker (<=>?), as in xterm's CSI > 4 ; 2 m, nor
+ -- intermediates is SGR.
+ csi a r =
+ let (params, r1) = T.span (\c -> c >= '0' && c <= '?') r
+ (inter, r2) = T.span (\c -> c >= ' ' && c <= '/') r1
+ isSGR = T.all (\c -> c < '<') params && T.null inter
+ in case T.uncons r2 of
+ Just ('m', r3) | isSGR -> go (applySGR (sgrGroups params) a) r3
+ Just (c, r3) | c >= '@' && c <= '~' -> go a r3
+ _ -> go a r2
+
+ -- The final byte of an escape sequence. Anything else, such as a
+ -- newline or the ESC of another sequence, cuts the sequence short and
+ -- is kept.
+ escFinal r = case T.uncons r of
+ Just (c, r') | c >= '0' && c <= '~' -> r'
+ _ -> r
+
+ -- OSC: up to BEL or ST.
+ osc a r =
+ let (body, r1) = T.break endsString r
+ in go (applyOSC body a) (afterString r1)
+
+ -- A control string ends with ST (ESC \ or 0x9C) or BEL, or is cut
+ -- short by the ESC of another sequence.
+ endsString c = c == '\a' || c == '\ESC' || c == '\x9C'
+ -- The payload of DCS, SOS, PM or APC. tmux passthrough doubles every
+ -- ESC of the sequence it wraps, so ESC ESC does not end the string.
+ controlString r =
+ let r1 = T.dropWhile (not . endsString) r
+ in maybe (afterString r1) controlString (T.stripPrefix "\ESC\ESC" r1)
+ afterString r = case T.uncons r of
+ Just ('\ESC', x) -> fromMaybe r (T.stripPrefix (T.singleton '\\') x)
+ Just (_, x) -> x
+ Nothing -> T.empty
+
+ applyOSC body a = case T.splitOn ";" body of
+ "8" : _params : uri -> a {attrLink = if T.null (T.intercalate ";" uri) then Nothing else Just (T.intercalate ";" uri)}
+ _ -> a
+
+-- | SGR parameters: groups separated by @;@, each with @:@ sub-parameters.
+-- Missing numbers count as 0. Numbers too long to mean anything are kept
+-- out of range rather than read modulo the size of 'Int'.
+sgrGroups :: Text -> [[Int]]
+sgrGroups params
+ | T.null params = [[0]]
+ | otherwise = map (map number . T.splitOn ":") (T.splitOn ";" params)
+ where
+ number t
+ | T.null t || not (T.all isDigit t) = 0
+ | T.length t > 6 = 1000000
+ | otherwise = read (T.unpack t)
+
+applySGR :: [[Int]] -> Attrs -> Attrs
+applySGR groups a = case groups of
+ [] -> a
+ grp : gs -> case grp of
+ -- A reset does not end a hyperlink: that is OSC 8, not SGR, state.
+ [0] -> applySGR gs mempty {attrLink = attrLink a}
+ [1] -> next a {attrBold = Just True}
+ [2] -> next a {attrFaint = Just True}
+ [3] -> next a {attrItalic = Just True}
+ [4] -> next a {attrUnderline = Just SingleUnderline}
+ [4, n] -> next a {attrUnderline = if n == 0 then Nothing else Just (underlineFrom n)}
+ [n] | n == 5 || n == 6 -> next a {attrBlink = Just True}
+ [7] -> next a {attrReverse = Just True}
+ [9] -> next a {attrStrikethrough = Just True}
+ [21] -> next a {attrUnderline = Just DoubleUnderline}
+ [22] -> next a {attrBold = Nothing, attrFaint = Nothing}
+ [23] -> next a {attrItalic = Nothing}
+ [24] -> next a {attrUnderline = Nothing}
+ [25] -> next a {attrBlink = Nothing}
+ [27] -> next a {attrReverse = Nothing}
+ [29] -> next a {attrStrikethrough = Nothing}
+ [n]
+ | n >= 30 && n <= 37 -> next a {attrFg = Just (Color16 (fromIntegral (n - 30)))}
+ | n >= 40 && n <= 47 -> next a {attrBg = Just (Color16 (fromIntegral (n - 40)))}
+ | n >= 90 && n <= 97 -> next a {attrFg = Just (Color16 (fromIntegral (n - 82)))}
+ | n >= 100 && n <= 107 -> next a {attrBg = Just (Color16 (fromIntegral (n - 92)))}
+ [39] -> next a {attrFg = Nothing}
+ [49] -> next a {attrBg = Nothing}
+ [59] -> next a {attrUnderlineColor = Nothing}
+ -- "38;5;n" and "38;2;r;g;b". A colour out of range is ignored; when
+ -- the colour is cut short, or of an unknown kind, the parameters left
+ -- are taken to be part of it and ignored too, rather than read as
+ -- attributes.
+ [n] | isColorParam n -> case gs of
+ [5] : [i] : rest -> applySGR rest (setColor n (palette i) a)
+ [2] : [r] : [g] : [b] : rest -> applySGR rest (setColor n (rgbOf r g b) a)
+ _ -> a
+ -- "38:5:n", "38:2:r:g:b" and "38:2:colourspace:r:g:b"
+ n : sub | isColorParam n -> next (setColor n (colon sub) a)
+ _ -> next a
+ where
+ next = applySGR gs
+ where
+ isColorParam n = n == 38 || n == 48 || n == 58
+
+ colon = \case
+ [5, i] -> palette i
+ [2, r, g, b] -> rgbOf r g b
+ 2 : _ : r : g : b : _ -> rgbOf r g b
+ _ -> Nothing
+
+ byte i = if i >= 0 && i <= 255 then Just (fromIntegral i) else Nothing
+ palette i = Color256 <$> byte i
+ rgbOf r g b = RGB <$> byte r <*> byte g <*> byte b
+
+ -- Without a colour, the attributes are left as they were.
+ setColor n c x = case (n, c) of
+ (_, Nothing) -> x
+ (38, _) -> x {attrFg = c}
+ (48, _) -> x {attrBg = c}
+ _ -> x {attrUnderlineColor = c}
+
+ underlineFrom n = case n of
+ 2 -> DoubleUnderline
+ 3 -> CurlyUnderline
+ 4 -> DottedUnderline
+ 5 -> DashedUnderline
+ _ -> SingleUnderline
+
+-- | The display width of text that may contain escape sequences: the width
+-- of its widest line, with tabs as four columns.
+ansiWidth :: Text -> Int
+ansiWidth = gridWidth . fromCellLines . inlineLines 4 . fromAnsi
+
+-- | The number of lines of text that may contain escape sequences: one
+-- more than the number of newlines.
+ansiHeight :: Text -> Int
+ansiHeight = gridHeight . fromCellLines . inlineLines 4 . fromAnsi
diff --git a/src/Lipstick/Block.hs b/src/Lipstick/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Block.hs
@@ -0,0 +1,268 @@
+-- | Blocks of styled text and how to combine them.
+--
+-- A 'Block' does not have a width until it is laid out: text in it wraps,
+-- and things that 'Lipstick.Mod.grow' take spare columns, to fit the width
+-- it gets. Output functions lay blocks out in the output's width (see
+-- 'Lipstick.Ansi.envWidth'); 'layout' does it explicitly.
+--
+-- == Examples
+--
+-- A block of text has a natural width, the narrowest it can be without
+-- breaking words, and a height at its natural width:
+--
+-- >>> let para = text "A block takes the width it is given."
+-- >>> (blockWidth para, blockMinWidth para, blockHeight para)
+-- (36,6,1)
+--
+-- Laid out in less width, the text wraps:
+--
+-- >>> putBlock (fromGrid (layout (Just 16) para))
+-- A block takes
+-- the width it is
+-- given.
+--
+-- Blocks side by side, aligned by a 'Position':
+--
+-- >>> let tall = render (border normalBorder) "one\ntwo\nthree"
+-- >>> let short = render (border normalBorder) "four"
+-- >>> putBlock (joinHorizontal top [tall, short])
+-- ┌─────┐┌────┐
+-- │one ││four│
+-- │two │└────┘
+-- │three│
+-- └─────┘
+-- >>> putBlock (joinHorizontal center [tall, short])
+-- ┌─────┐
+-- │one │┌────┐
+-- │two ││four│
+-- │three│└────┘
+-- └─────┘
+--
+-- Stacked:
+--
+-- >>> putBlock (joinVertical right [tall, short])
+-- ┌─────┐
+-- │one │
+-- │two │
+-- │three│
+-- └─────┘
+-- ┌────┐
+-- │four│
+-- └────┘
+--
+-- A block that 'Lipstick.Mod.fillWidth's takes the spare columns of its
+-- row, and one that 'Lipstick.Mod.stretchHeight's is as tall as the row:
+--
+-- >>> let stretchy = render (border normalBorder <> fillWidth <> stretchHeight) "fills"
+-- >>> putBlock (fromGrid (layout (Just 30) (hcat [tall, stretchy])))
+-- ┌─────┐┌─────────────────────┐
+-- │one ││fills │
+-- │two ││ │
+-- │three││ │
+-- └─────┘└─────────────────────┘
+--
+-- Text with several styles is 'Inline', built with 'styled' and '<>'
+-- (the output is shown without its attributes):
+--
+-- >>> putBlock (render (width 20) (styled bold "Error: " <> "the file " <> styled italic "notes.txt" <> " was not found"))
+-- Error: the file
+-- notes.txt was not
+-- found
+module Lipstick.Block
+ ( -- * Blocks
+ Block
+ , blockWidth
+ , blockHeight
+ , blockMinWidth
+ , blockGrows
+ , emptyBlock
+ , text
+ , fromInline
+
+ -- * Laying out
+ , layout
+ , Grid
+ , gridWidth
+ , gridHeight
+ , fromGrid
+
+ -- * Inline text
+ , Inline
+ , plain
+ , styled
+ , styleRanges
+ , styleIndices
+
+ -- * Joining
+ , joinHorizontal
+ , joinVertical
+ , hcat
+ , vcat
+ , Position
+ , position
+ , left
+ , center
+ , right
+ , top
+ , bottom
+ ) where
+
+import Data.IntSet qualified as IntSet
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick.Grid (Grid, gridHeight, gridWidth)
+import Lipstick.Internal.Grid hiding (Grid (..))
+import Lipstick.Internal.Layout
+import Lipstick.Internal.Types
+import Lipstick.Internal.Mod (Mod, Props (..), propsOf, runMod)
+
+-- $setup
+-- >>> import Lipstick
+
+-- | The natural width of a block: the 'Lipstick.Mod.width' of a box that
+-- has one, or else as wide as it is with nothing wrapped.
+blockWidth :: Block -> Int
+blockWidth = reqMax . blockRequest . measure
+
+-- | The height of a block at its natural width.
+blockHeight :: Block -> Int
+blockHeight b = snd (blockLayout (measure b) (Assign (blockWidth b) 0))
+
+-- | The least width a block gets when width is shared out: the
+-- 'Lipstick.Mod.width' of a box that has one, or else the narrowest it can
+-- be without breaking a word. Given less, it still shrinks.
+blockMinWidth :: Block -> Int
+blockMinWidth = reqMin . blockRequest . measure
+
+-- | Whether a block takes spare width (see 'Lipstick.Mod.grow'), as an
+-- adapter needs to know to size it.
+blockGrows :: Block -> Bool
+blockGrows = (> 0) . reqGrow . blockRequest . measure
+
+-- | Unstyled text; lines are split on newlines, and wrap to the width the
+-- block is given.
+text :: Text -> Block
+text = fromInline . plain
+
+-- | Inline text as a block, without any box around it. Lines wrap to the
+-- width the block is given.
+fromInline :: Inline -> Block
+fromInline = textBlock
+
+-- | Text with attributes, for building 'Inline' text with '<>'. Only the
+-- text attributes of the modifier apply.
+--
+-- >>> putBlock (fromInline (styled bold "Error: " <> "file not found"))
+-- Error: file not found
+styled :: Mod Inline -> Text -> Inline
+styled m t = Inline [(propAttrs (snd (runMod m mempty)), t)]
+
+-- | Place blocks side by side. Spare columns go to blocks that
+-- 'Lipstick.Mod.grow'; when there are too few columns, the widest blocks
+-- shrink first, and what does not fit even at one column each is cut off
+-- on the right. The position aligns shorter blocks vertically ('top',
+-- 'center', 'bottom'); blocks that 'Lipstick.Mod.stretchHeight' take the
+-- row's height instead.
+joinHorizontal :: Position -> [Block] -> Block
+joinHorizontal p bs = Block $ \ctx ->
+ let ns = map (measureIn ctx) bs
+ rs = map blockRequest ns
+ in rowNode p ns rs
+
+rowNode :: Position -> [Measured] -> [Request] -> Measured
+rowNode p ns rs = Measured req run
+ where
+ req =
+ Request
+ { reqMin = sum (map reqMin rs)
+ , reqMax = sum (map reqMax rs)
+ , reqGrow = sum (map reqGrow rs)
+ , reqLimit = addLimits rs
+ , reqStretch = any reqStretch rs
+ , reqFill = False
+ }
+ run (Assign w h) = (fitWidth w (joinGridsH p (map fst results)), natural)
+ where
+ ws = allocateWithin w [(reqMin r, reqMax r, reqGrow r, reqLimit r) | r <- rs]
+ -- The row height goes into the calls that give the natural heights
+ -- it is computed from: a block's natural height never depends on
+ -- the height it is asked to stretch to.
+ results = [blockLayout n (Assign bw rowH) | (n, bw) <- zip ns ws]
+ natural = maximum (0 : map snd results)
+ rowH = if reqStretch req then max h natural else natural
+
+-- | Stack blocks. Each takes as much of the column's width as it can use
+-- (all of it if it grows without a limit), and the position aligns them
+-- horizontally ('left', 'center', 'right').
+joinVertical :: Position -> [Block] -> Block
+joinVertical p bs = Block $ \ctx ->
+ let ns = map (measureIn ctx) bs
+ rs = map blockRequest ns
+ in columnNode p ns rs
+
+columnNode :: Position -> [Measured] -> [Request] -> Measured
+columnNode p ns rs = Measured req run
+ where
+ req =
+ Request
+ { reqMin = maximum (0 : map reqMin rs)
+ , reqMax = maximum (0 : map reqMax rs)
+ , reqGrow = maximum (0 : map reqGrow rs)
+ , reqLimit = maxLimit rs
+ , reqStretch = False
+ , reqFill = False
+ }
+ run (Assign w _) = (joinGridsV p w (map fst results), sum (map snd results))
+ where
+ results = [blockLayout n (Assign (takenWidth r w) 0) | (n, r) <- zip ns rs]
+
+-- | Side by side, aligned to the top.
+hcat :: [Block] -> Block
+hcat = joinHorizontal top
+
+-- | Stacked, aligned to the left.
+vcat :: [Block] -> Block
+vcat = joinVertical left
+
+-- | Add attributes to ranges of display columns @[start, end)@, counted
+-- from the start of the text and continuing across lines (a newline takes
+-- no columns); a cluster is styled when its first column is in a range.
+-- A tab counts as four columns, the default 'Lipstick.Style.tabWidth':
+-- where the text ends up, and so its tab width, is not known yet. The
+-- range attributes go on top of the text's own.
+--
+-- >>> toAnsi defaultRenderEnv (fromInline (styleRanges [(0, 3, bold <> fg red)] "foobar"))
+-- "\ESC[0;1;31mfoo\ESC[0mbar"
+styleRanges :: [(Int, Int, Mod Inline)] -> Inline -> Inline
+styleRanges ranges = restyle $ \col _ ->
+ mconcat [propAttrs (propsOf m) | (s, e, m) <- ranges, col >= s, col < e]
+
+-- | Add attributes to the characters (grapheme clusters, not counting
+-- newlines) at the given indices, and other attributes to the rest. Handy
+-- for highlighting fuzzy-search matches.
+--
+-- >>> toAnsi defaultRenderEnv (fromInline (styleIndices [0, 3] underline mempty "foobar"))
+-- "\ESC[0;4mf\ESC[0moo\ESC[0;4mb\ESC[0mar"
+styleIndices :: [Int] -> Mod Inline -> Mod Inline -> Inline -> Inline
+styleIndices indices matched unmatched = restyle $ \_ i ->
+ if IntSet.member i chosen then on else off
+ where
+ chosen = IntSet.fromList indices
+ on = propAttrs (propsOf matched)
+ off = propAttrs (propsOf unmatched)
+
+-- | Layer extra attributes over each cluster, given its starting column and
+-- its index.
+restyle :: (Int -> Int -> Attrs) -> Inline -> Inline
+restyle extra (Inline segs) = Inline (merge (go 0 0 (styledClusters segs)))
+ where
+ go _ _ [] = []
+ go col i ((a, c, cw) : rest)
+ | T.any (== '\n') c = (a, c) : go col i rest
+ | c == T.singleton '\t' = (a <> extra col i, c) : go (col + textTabWidth defTextStyle) (i + 1) rest
+ | otherwise = (a <> extra col i, c) : go (col + cw) (i + 1) rest
+ -- Runs of clusters with the same attributes, each joined once.
+ merge ((a, t) : rest) =
+ let (same, rest') = span ((== a) . fst) rest
+ in (a, T.concat (t : map snd same)) : merge rest'
+ merge [] = []
diff --git a/src/Lipstick/Border.hs b/src/Lipstick/Border.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Border.hs
@@ -0,0 +1,53 @@
+-- | Border character sets.
+--
+-- == Examples
+--
+-- >>> let sample b = render (border b <> marginRight 1) "text"
+-- >>> putBlock (hcat (map sample [normalBorder, roundedBorder, thickBorder, doubleBorder]))
+-- ┌────┐ ╭────╮ ┏━━━━┓ ╔════╗
+-- │text│ │text│ ┃text┃ ║text║
+-- └────┘ ╰────╯ ┗━━━━┛ ╚════╝
+-- >>> putBlock (hcat (map sample [blockBorder, outerHalfBlockBorder, innerHalfBlockBorder]))
+-- ██████ ▛▀▀▀▀▜ ▗▄▄▄▄▖
+-- █text█ ▌text▐ ▐text▌
+-- ██████ ▙▄▄▄▄▟ ▝▀▀▀▀▘
+-- >>> putBlock (hcat (map sample [asciiBorder, markdownBorder, hiddenBorder]))
+-- +----+ |----|
+-- |text| |text| text
+-- +----+ |----|
+--
+-- A border is a record of the pieces, so a new one is made by changing
+-- some of them:
+--
+-- >>> let dotted = normalBorder {topEdge = "┈", bottomEdge = "┈", leftEdge = "┊", rightEdge = "┊"}
+-- >>> putBlock (render (border dotted <> padding 0 1) "dotted")
+-- ┌┈┈┈┈┈┈┈┈┐
+-- ┊ dotted ┊
+-- └┈┈┈┈┈┈┈┈┘
+--
+-- Tables use the @middle*@ pieces:
+--
+-- >>> putBlock (table (border doubleBorder) ["a", "b"] [["1", "2"]])
+-- ╔═╦═╗
+-- ║a║b║
+-- ╠═╬═╣
+-- ║1║2║
+-- ╚═╩═╝
+module Lipstick.Border
+ ( Border (topEdge, bottomEdge, leftEdge, rightEdge, topLeftCorner, topRightCorner, bottomLeftCorner, bottomRightCorner, middleLeft, middleRight, middle, middleTop, middleBottom)
+ , normalBorder
+ , roundedBorder
+ , thickBorder
+ , doubleBorder
+ , blockBorder
+ , outerHalfBlockBorder
+ , innerHalfBlockBorder
+ , hiddenBorder
+ , asciiBorder
+ , markdownBorder
+ ) where
+
+import Lipstick.Internal.Border
+
+-- $setup
+-- >>> import Lipstick
diff --git a/src/Lipstick/Color.hs b/src/Lipstick/Color.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Color.hs
@@ -0,0 +1,89 @@
+-- | Colours, colour profiles and downsampling.
+--
+-- A 'Color' is what you write in a style. It may be adaptive ('lightDark',
+-- 'complete'), so it is only turned into a concrete 'TermColor' when the
+-- block is serialised and the terminal's 'ColorProfile' is known.
+--
+-- == Examples
+--
+-- Colours are written as strings (hex or a palette index), or with the
+-- functions and names below:
+--
+-- >>> ["#7D56F4", "#fa0", "201", "5"] :: [Color]
+-- [rgb 125 86 244,rgb 255 170 0,ansi256 201,ansi 5]
+-- >>> (rgb 125 86 244, ansi256 201, brightBlue)
+-- (rgb 125 86 244,ansi256 201,ansi 12)
+-- >>> hex "7D56F4"
+-- Just (rgb 125 86 244)
+-- >>> hex "nope"
+-- Nothing
+--
+-- An adaptive colour is resolved for a profile and background (dark or
+-- not) when it is printed:
+--
+-- >>> let accent = lightDark "#5A3FC0" "#B39DFF"
+-- >>> resolveColor TrueColor True accent
+-- Just (TCRGB 179 157 255)
+-- >>> resolveColor TrueColor False accent
+-- Just (TCRGB 90 63 192)
+-- >>> resolveColor ANSI256 True "#7D56F4"
+-- Just (TC256 99)
+-- >>> resolveColor ANSI16 True "#7D56F4"
+-- Just (TC16 12)
+-- >>> resolveColor Ascii True "#7D56F4"
+-- Nothing
+-- >>> resolveColor ANSI16 True (complete "#7D56F4" "99" magenta)
+-- Just (TC16 5)
+--
+-- Gradients and adjustments:
+--
+-- >>> blend 3 ["#ff0000", "#0000ff"]
+-- [rgb 255 0 0,rgb 140 83 162,rgb 0 0 255]
+-- >>> mix 0.25 black white
+-- rgb 29 29 29
+-- >>> darken 0.5 "#7D56F4"
+-- rgb 44 28 94
+-- >>> lighten 0.5 "#7D56F4"
+-- rgb 184 175 255
+-- >>> complementary "#7D56F4"
+-- rgb 138 128 0
+module Lipstick.Color
+ ( -- * Colours
+ Color
+ , rgb
+ , ansi
+ , ansi256
+ , hex
+ , lightDark
+ , complete
+
+ -- ** The 16 basic colours
+ -- | What they look like is up to the terminal's palette. Where they
+ -- are turned into RGB, xterm's palette is used.
+ , black, red, green, yellow, blue, magenta, cyan, white
+ , brightBlack, brightRed, brightGreen, brightYellow
+ , brightBlue, brightMagenta, brightCyan, brightWhite
+
+ -- * Manipulating colours
+ -- | These work in the OkLab colour space, so steps look even. Palette
+ -- colours are converted to RGB using xterm's palette, and adaptive
+ -- colours are transformed in every variant.
+ , mix
+ , blend
+ , blend2D
+ , darken
+ , lighten
+ , complementary
+
+ -- * Terminal colours
+ , TermColor (..)
+ , ColorProfile (..)
+ , resolveColor
+ , downsample
+ , termColorRGB
+ ) where
+
+import Lipstick.Internal.Color
+
+-- $setup
+-- >>> import Lipstick
diff --git a/src/Lipstick/Grid.hs b/src/Lipstick/Grid.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Grid.hs
@@ -0,0 +1,94 @@
+-- | Laid-out blocks, for showing them somewhere other than a terminal (a
+-- vty image, an SVG, …).
+--
+-- A 'Grid' is what 'Lipstick.Block.layout' gives: a rectangle of lines,
+-- each exactly 'gridWidth' columns wide, made of 'Cell's, one grapheme
+-- cluster each. 'lineSpans' groups a line's cells into runs with the same
+-- attributes, which is usually what an output needs.
+--
+-- == Examples
+--
+-- >>> let g = layout Nothing (render (border asciiBorder) (styled bold "hi" <> " there"))
+-- >>> (gridWidth g, gridHeight g)
+-- (10,3)
+-- >>> map lineWidth (gridLines g)
+-- [10,10,10]
+-- >>> let middle = gridLines g !! 1
+-- >>> map cellText (lineCells middle)
+-- ["|","h","i"," ","t","h","e","r","e","|"]
+-- >>> [(spanText s, spanWidth s, attrBold (spanAttrs s)) | s <- lineSpans middle]
+-- [("|",1,Nothing),("hi",2,Just True),(" there|",7,Nothing)]
+--
+-- A wide character takes one cell, two columns wide:
+--
+-- >>> [cellWidth c | l <- gridLines (layout Nothing "a你b"), c <- lineCells l]
+-- [1,2,1]
+module Lipstick.Grid
+ ( -- * Grids
+ Grid
+ , gridWidth
+ , gridHeight
+ , gridLines
+
+ -- * Lines
+ , Line
+ , lineWidth
+ , lineCells
+ , lineSpans
+ , Span
+ , spanAttrs
+ , spanText
+ , spanWidth
+
+ -- * Cells
+ , Cell
+ , cellText
+ , cellAttrs
+ , cellWidth
+
+ -- * Attributes
+ , Attrs (attrFg, attrBg, attrUnderlineColor, attrBold, attrFaint, attrItalic, attrBlink, attrReverse, attrStrikethrough, attrUnderline, attrLink)
+ ) where
+
+import Data.Text (Text)
+import Lipstick.Internal.Grid (Cell, Grid, Line, Span (..), lineSpans)
+import Lipstick.Internal.Grid qualified as I
+import Lipstick.Internal.Types (Attrs (..))
+
+-- $setup
+-- >>> import Lipstick
+-- >>> import Lipstick.Grid
+
+-- | The width in columns, the same for every line.
+gridWidth :: Grid -> Int
+gridWidth = I.gridWidth
+
+-- | The number of lines.
+gridHeight :: Grid -> Int
+gridHeight = I.gridHeight
+
+-- | The lines, from the top.
+gridLines :: Grid -> [Line]
+gridLines = I.gridLines
+
+-- | The width in columns: the sum of the cells' widths, and the
+-- grid's 'gridWidth'.
+lineWidth :: Line -> Int
+lineWidth = I.lineWidth
+
+-- | The cells of a line, from the left.
+lineCells :: Line -> [Cell]
+lineCells = I.lineCells
+
+-- | The grapheme cluster in a cell.
+cellText :: Cell -> Text
+cellText = I.cellText
+
+-- | The attributes the cell is drawn with, from everything that styles
+-- it. Fields that nothing set are 'Nothing'.
+cellAttrs :: Cell -> Attrs
+cellAttrs = I.cellAttrs
+
+-- | How many columns the cell takes (0, 1 or 2).
+cellWidth :: Cell -> Int
+cellWidth = I.cellWidth
diff --git a/src/Lipstick/Layer.hs b/src/Lipstick/Layer.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Layer.hs
@@ -0,0 +1,315 @@
+-- | Compositing: blocks stacked on top of each other at any position.
+--
+-- Layers are drawn from the lowest z-index up (a sublayer's 'zIndex'
+-- adds to its parent's); layers with the same z-index are drawn in list
+-- order, each followed by its sublayers. A layer hides what is below it,
+-- unless it is 'transparent'. Where a layer covers half of a wide
+-- character, the other half becomes a space, so columns never shift.
+--
+-- == Examples
+--
+-- >>> let background = place (width 26 <> height 6 <> whitespaceChars "╱") emptyBlock
+-- >>> let shadow = render (bg black <> width 16 <> height 3) ""
+-- >>> let dialog = render (border roundedBorder <> width 16 <> align center) "Really quit?"
+-- >>> let layers = [layer mempty background, layer (offset 6 2 <> zIndex 1) shadow, layer (offset 4 1 <> zIndex 2 <> layerId "dialog") dialog]
+-- >>> putBlock (compose layers)
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╭──────────────╮╱╱╱╱╱╱
+-- ╱╱╱╱│ Really quit? │ ╱╱╱╱
+-- ╱╱╱╱╰──────────────╯ ╱╱╱╱
+-- ╱╱╱╱╱╱ ╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+--
+-- Finding the named layer under a column and row, for mouse handling, and
+-- where a layer is:
+--
+-- >>> layerAt Nothing 8 2 layers
+-- Just "dialog"
+-- >>> layerAt Nothing 1 1 layers
+-- Nothing
+-- >>> findLayer Nothing "dialog" layers
+-- Just (Rect {rectX = 4, rectY = 1, rectWidth = 16, rectHeight = 3})
+--
+-- A 'transparent' layer shows what is below its unstyled spaces:
+--
+-- >>> let label = render (padding 0 2) "label"
+-- >>> putBlock (compose [layer mempty background, layer (offset 2 2) label])
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱ label ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- >>> putBlock (compose [layer mempty background, layer (offset 2 2 <> transparent) label])
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱label╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+-- ╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱╱
+module Lipstick.Layer
+ ( Layer
+ , layer
+ , offset
+ , zIndex
+ , layerId
+ , transparent
+ , sublayers
+ , compose
+ , overlay
+ , layerAt
+ , layerHit
+ , findLayer
+ , Rect (rectX, rectY, rectWidth, rectHeight)
+ ) where
+
+import Data.List (sortOn)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Layout (Assign (..), Block (..), Measured (..), Request (..), TextStyle, cropLayoutWidth, defTextStyle, measureIn, takenWidth, usableWidth)
+import Lipstick.Internal.Mod (HasCrop, Mod, Props (..), defProps, fieldMod, runMod, withProps)
+
+-- $setup
+-- >>> import Lipstick
+
+-- | A block to draw on a canvas, with its position, z-index, name and
+-- sublayers. Make one with 'layer', set those with a @t'Mod' t'Layer'@
+-- ('offset', 'zIndex', …), and draw layers with 'compose'.
+data Layer = Layer
+ { layerX :: !Int
+ , layerY :: !Int
+ , layerZ :: !Int
+ , layerName :: !(Maybe Text)
+ , layerTransparent :: !Bool
+ , layerChildren :: [Layer]
+ , layerBlock :: Block
+ , layerProps :: Props
+ }
+
+instance HasCrop Layer
+
+-- | A layer showing a block, at the origin unless moved with 'offset'. The
+-- layer's text attributes are the base for the block. The block is laid
+-- out when the layers are composed, in the width of the canvas to the
+-- right of the layer.
+layer :: Mod Layer -> Block -> Layer
+layer m b =
+ let (l, props) = runMod m (Layer 0 0 0 Nothing False [] b defProps)
+ in l {layerProps = props}
+
+-- | Move the layer right and down (relative to its parent, for sublayers).
+-- Parts moved off the top or left of the canvas are cut off.
+offset :: Int -> Int -> Mod Layer
+offset x y = fieldMod (\l -> l {layerX = x, layerY = y})
+
+-- | Layers with a higher z-index are drawn on top (relative to the parent,
+-- for sublayers).
+zIndex :: Int -> Mod Layer
+zIndex z = fieldMod (\l -> l {layerZ = z})
+
+-- | Name the layer, for 'layerAt', 'layerHit' and 'findLayer'.
+layerId :: Text -> Mod Layer
+layerId t = fieldMod (\l -> l {layerName = Just t})
+
+-- | Let unstyled spaces show what is below them.
+transparent :: Mod Layer
+transparent = fieldMod (\l -> l {layerTransparent = True})
+
+-- | Layers positioned relative to this one.
+sublayers :: [Layer] -> Mod Layer
+sublayers ls = fieldMod (\l -> l {layerChildren = layerChildren l ++ ls})
+
+-- | Absolute layers, in drawing order.
+flatten :: [Layer] -> [Layer]
+flatten = sortOn layerZ . concatMap (go 0 0 0)
+ where
+ go dx dy dz l =
+ let l' = l {layerX = layerX l + dx, layerY = layerY l + dy, layerZ = layerZ l + dz}
+ in l' : concatMap (go (layerX l') (layerY l') (layerZ l')) (layerChildren l)
+
+-- | What occupies a column: a cluster starting there, or the second half
+-- of a wide cluster starting to the left.
+data Slot = Start !Cell | Continued
+
+-- | Draw layers onto a canvas from column 0, row 0 to the far edges of
+-- the layers, or as wide as the space it is laid out in if a layer grows.
+-- In less width, each layer is laid out in the columns to the right of its
+-- offset, and what still does not fit is cut off.
+compose :: [Layer] -> Block
+compose layers = Block $ \ctx -> Measured (canvasRequest (measured ctx layers)) $ \(Assign w _) ->
+ let g = fitWidth w (canvas w (drawLayers w (measured ctx layers)))
+ in (g, gridHeight g)
+
+-- | Absolute layers, in drawing order, with their blocks in inherited text
+-- settings.
+measured :: TextStyle -> [Layer] -> [(Layer, Measured)]
+measured ctx layers = [(l, measureIn ctx (layerBlock l)) | l <- flatten layers]
+
+-- | What a canvas of layers asks for: room for each layer to the right of
+-- its column.
+canvasRequest :: [(Layer, Measured)] -> Request
+canvasRequest ls =
+ Request
+ { reqMin = maximum (0 : [max 0 (layerX l + reqMin r) | (l, r) <- rs])
+ , reqMax = maximum (0 : [max 0 (layerX l + reqMax r) | (l, r) <- rs])
+ , reqGrow = maximum (0 : map (reqGrow . snd) rs)
+ , reqLimit = maximum . (0 :) <$> traverse (\(l, r) -> (layerX l +) <$> usableWidth r) rs
+ , reqStretch = False
+ , reqFill = False
+ }
+ where
+ rs = [(l, layerRequest l m) | (l, m) <- ls]
+
+-- | A layer's request, within its 'Lipstick.Mod.maxWidth' crop.
+layerRequest :: Layer -> Measured -> Request
+layerRequest l m =
+ let r = blockRequest m
+ cap x = maybe x (min x . max 0) (propMaxWidth (layerProps l))
+ in r {reqMin = cap (reqMin r), reqMax = cap (reqMax r), reqLimit = cap <$> reqLimit r}
+
+-- | Absolute layers laid out in a canvas width: each takes what it needs
+-- of the columns to its right.
+drawLayers :: Int -> [(Layer, Measured)] -> [(Layer, Grid)]
+drawLayers w ls =
+ [ (l, withProps (layerProps l) (gridCells (fst (blockLayout m (Assign lw 0)))))
+ | (l, m) <- ls
+ , let r = blockRequest m
+ -- As for a style: when the crop is what limits the layer, it is
+ -- laid out at its natural width and cut, not made to wrap.
+ lw = cropLayoutWidth (propMaxWidth (layerProps l)) (reqGrow r) (reqMax r) (takenWidth (layerRequest l m) (w - layerX l))
+ ]
+
+-- | The width a canvas of layers takes in an available width, as for
+-- 'Lipstick.Block.layout'.
+canvasWidth :: Maybe Int -> [(Layer, Measured)] -> Int
+canvasWidth avail ls = let r = canvasRequest ls in maybe (reqMax r) (takenWidth r) avail
+
+canvas :: Int -> [(Layer, Grid)] -> Grid
+canvas w drawn = fromCellLines [row r | r <- [0 .. h - 1]]
+ where
+ h = maximum (0 : [layerY l + gridHeight g | (l, g) <- drawn])
+ painted = foldl paintLayer Map.empty drawn
+
+ row r = go 0
+ where
+ go c
+ | c >= w = []
+ | otherwise = case Map.lookup (r, c) painted of
+ Just (Start cell) -> cell : go (c + max 1 (cellWidth cell))
+ _ -> blank : go (c + 1)
+ blank = Cell mempty (T.singleton ' ') 1 False
+
+-- | @overlay x y top base@ draws @top@ over @base@, @x@ columns right of
+-- and @y@ rows below its top-left corner. The result grows to fit @top@
+-- where it reaches past @base@.
+overlay :: Int -> Int -> Block -> Block -> Block
+overlay x y top base = compose [layer mempty base, layer (offset x y) top]
+
+paintLayer :: Map (Int, Int) Slot -> (Layer, Grid) -> Map (Int, Int) Slot
+paintLayer painted (l, g) = foldl paintRow painted (zip [layerY l ..] (gridCells g))
+ where
+ paintRow m (r, cells)
+ | r < 0 = m
+ | otherwise = go m (layerX l) cells
+ where
+ go acc _ [] = acc
+ go acc c (cell : rest)
+ -- Zero-width clusters (a lone zero-width space, say) are
+ -- invisible on their own and would otherwise take a column.
+ | cw == 0 = go acc c rest
+ | layerTransparent l && isBlank cell = go acc (c + cw) rest
+ | c < 0 = go (clipLeft acc c cell) (c + cw) rest
+ | otherwise = go (put acc c cell) (c + cw) rest
+ where
+ cw = cellWidth cell
+
+ -- A wide cluster cut by the left edge: show a space for the part
+ -- still on the canvas.
+ clipLeft acc c cell =
+ foldl (\a p -> put a p (spaceLike cell)) acc [p | p <- [c .. c + cellWidth cell - 1], p >= 0]
+
+ put acc c cell =
+ let cw = cellWidth cell
+ -- Repair wide clusters that this cell cuts in half.
+ acc1 = case Map.lookup (r, c) acc of
+ Just Continued -> breakWide acc (c - 1)
+ _ -> acc
+ acc2 = case Map.lookup (r, c + cw - 1) acc1 of
+ Just (Start old) | cellWidth old > 1 -> blankFrom acc1 (c + cw) (cellWidth old - 1) old
+ _ -> acc1
+ acc3 = Map.insert (r, c) (Start cell) acc2
+ in foldl (\a p -> Map.insert (r, p) Continued a) acc3 [c + 1 .. c + cw - 1]
+
+ -- The cluster that starts at or before column c and continues into
+ -- column c + 1 is replaced by spaces up to c.
+ breakWide acc c = case findStart acc c of
+ Just (sc, old) -> foldl (\a p -> Map.insert (r, p) (Start (spaceLike old)) a) acc [sc .. c]
+ Nothing -> acc
+ findStart acc c = listToMaybe [(sc, old) | sc <- [c, c - 1 .. max 0 (c - 3)], Just (Start old) <- [Map.lookup (r, sc) acc]]
+
+ -- Columns left over from a wide cluster whose start was overwritten.
+ blankFrom acc from n old =
+ foldl
+ ( \a p -> case Map.lookup (r, p) a of
+ Just Continued -> Map.insert (r, p) (Start (spaceLike old)) a
+ _ -> a
+ )
+ acc
+ [from .. from + n - 1]
+
+ spaceLike cell = Cell (cellAttrs cell) (T.singleton ' ') 1 (cellFill cell)
+ isBlank cell = cellText cell == T.singleton ' ' && cellAttrs cell == mempty
+
+-- | Where a layer is drawn, in canvas columns and rows.
+data Rect = Rect
+ { rectX :: !Int
+ , rectY :: !Int
+ , rectWidth :: !Int
+ , rectHeight :: !Int
+ }
+ deriving (Eq, Show)
+
+bounds :: (Layer, Grid) -> Rect
+bounds (l, g) = Rect (layerX l) (layerY l) (gridWidth g) (gridHeight g)
+
+contains :: Int -> Int -> Rect -> Bool
+contains x y (Rect rx ry w h) = x >= rx && x < rx + w && y >= ry && y < ry + h
+
+-- | Layers laid out as 'compose' lays them out in an available width
+-- ('Nothing' for its natural width), topmost first.
+topmostFirst :: Maybe Int -> [Layer] -> [(Layer, Grid)]
+topmostFirst avail layers =
+ let ls = measured defTextStyle layers
+ in reverse (drawLayers (canvasWidth avail ls) ls)
+
+-- | The topmost named layer covering a column and row, for mouse handling,
+-- with the layers composed in an available width ('Nothing' for their
+-- natural width).
+--
+-- Like 'Lipstick.Block.layout', it lays the composition out on its own, in
+-- the default text settings, and the columns and rows count from its
+-- top-left corner. Where the composition is framed by a style, take off
+-- what is drawn before it; and if that style sets 'Lipstick.Mod.noWrap',
+-- 'Lipstick.Style.tabWidth' or another text setting that changes how the
+-- layers are laid out, the result can differ from what is drawn.
+layerAt :: Maybe Int -> Int -> Int -> [Layer] -> Maybe Text
+layerAt avail x y = fmap fst . layerHit avail x y
+
+-- | Like 'layerAt', with where the layer is drawn.
+layerHit :: Maybe Int -> Int -> Int -> [Layer] -> Maybe (Text, Rect)
+layerHit avail x y layers =
+ listToMaybe
+ [ (name, bounds d)
+ | d@(l, _) <- topmostFirst avail layers
+ , Just name <- [layerName l]
+ , contains x y (bounds d)
+ ]
+
+-- | Where the layer with a given name is drawn (the topmost, if several
+-- share it), laid out as for 'layerAt'.
+findLayer :: Maybe Int -> Text -> [Layer] -> Maybe Rect
+findLayer avail name layers = listToMaybe [bounds d | d@(l, _) <- topmostFirst avail layers, layerName l == Just name]
diff --git a/src/Lipstick/Mod.hs b/src/Lipstick/Mod.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Mod.hs
@@ -0,0 +1,210 @@
+-- | Modifiers, in the style of optparse-applicative's builder.
+--
+-- A @'Mod' f@ is a change to a thing @f@ (a 'Lipstick.Style.Style', a
+-- 'Lipstick.Table.Table', a 'Lipstick.Place.Place', …). Modifiers form a
+-- monoid in which the later setting wins, so styles are built and extended
+-- with '<>':
+--
+-- > card :: Mod Style
+-- > card = bold <> fg "#FAFAFA" <> bg "#7D56F4" <> padding 1 2
+-- >
+-- > warning :: Mod Style
+-- > warning = card <> bg "#F25D94"
+--
+-- As in optparse-applicative's @Mod@, a change to the properties every
+-- thing has is kept apart from a change to the thing's own fields:
+--
+-- * the properties every thing has are text attributes and the
+-- 'maxWidth' / 'maxHeight' crop. Text attributes, such as 'fg' or
+-- 'bold', can be set on any thing, and the crop on any thing but
+-- 'Lipstick.Block.Inline' text ('HasCrop'). Each thing's text attributes
+-- are the base for what it draws (for a style, only its content: see
+-- 'Lipstick.Style.Style'), overridden by anything more specific inside
+-- it (a cell style, an item style, the attributes of a placed block).
+--
+-- * modifiers of fields that several things have go through the classes
+-- 'HasBox', 'HasBorder', 'HasSize', 'HasAlign' and 'HasWrap'; the rest,
+-- such as 'Lipstick.Table.cellStyle', belong to one thing.
+--
+-- == Examples
+--
+-- The examples print with 'Lipstick.Terminal.putBlock'; the output is
+-- shown without colours and other attributes.
+--
+-- Text attributes work on any thing:
+--
+-- >>> let base = bold <> fg red
+-- >>> putBlock (render (base <> border normalBorder) "a style")
+-- ┌───────┐
+-- │a style│
+-- └───────┘
+-- >>> putBlock (table base ["a table"] [["cell"]])
+-- ╭───────╮
+-- │a table│
+-- ├───────┤
+-- │cell │
+-- ╰───────╯
+-- >>> putBlock (list base ["a list"])
+-- • a list
+--
+-- Padding and margins are given as vertical then horizontal amounts, or
+-- per side:
+--
+-- >>> putBlock (render (border normalBorder <> padding 0 3) "wide")
+-- ┌──────────┐
+-- │ wide │
+-- └──────────┘
+-- >>> putBlock (render (border normalBorder <> paddingLeft 4) "indented")
+-- ┌────────────┐
+-- │ indented│
+-- └────────────┘
+--
+-- Borders, and which of their sides are drawn:
+--
+-- >>> putBlock (render (border roundedBorder <> borderBottom False) "open below")
+-- ╭──────────╮
+-- │open below│
+--
+-- 'width' is the width with padding and border. The thing shrinks when
+-- there is less room:
+--
+-- >>> let note = render (width 24 <> border normalBorder) "Wraps to its width"
+-- >>> putBlock note
+-- ┌──────────────────────┐
+-- │Wraps to its width │
+-- └──────────────────────┘
+-- >>> putBlock (fromGrid (layout (Just 14) note))
+-- ┌────────────┐
+-- │Wraps to its│
+-- │width │
+-- └────────────┘
+--
+-- 'maxWidth' and 'maxHeight' crop the result:
+--
+-- >>> putBlock (render (border normalBorder <> maxWidth 6) "cropped")
+-- ┌─────
+-- │cropp
+-- └─────
+--
+-- Alignment of content in a box that is larger than it:
+--
+-- >>> putBlock (render (width 12 <> height 5 <> border normalBorder <> align right <> valign bottom) "corner")
+-- ┌──────────┐
+-- │ │
+-- │ │
+-- │ corner│
+-- └──────────┘
+--
+-- An @unset@ modifier undoes a setting made earlier:
+--
+-- >>> let boxed = border normalBorder <> padding 0 1
+-- >>> putBlock (render (boxed <> unsetBorder) "no border")
+-- no border
+module Lipstick.Mod
+ ( Mod
+ , HasBox
+ , HasBorder
+ , HasSize
+ , HasAlign
+ , HasWrap
+ , HasCrop
+ , Sides (..)
+
+ -- * Text attributes
+ , bold
+ , faint
+ , italic
+ , blink
+ , reverseVideo
+ , strikethrough
+ , Flag (..)
+ , flag
+ , unsetFlag
+ , underline
+ , Underline (..)
+ , underlineStyle
+ , underlineColor
+ , fg
+ , bg
+ , unsetFg
+ , unsetBg
+ , unsetUnderline
+ , unsetUnderlineColor
+ , link
+ , unsetLink
+
+ -- * Padding and margins
+ , padding
+ , paddingAll
+ , paddingTop
+ , paddingRight
+ , paddingBottom
+ , paddingLeft
+ , margin
+ , marginAll
+ , marginTop
+ , marginRight
+ , marginBottom
+ , marginLeft
+ , marginBg
+ , paddingChar
+ , marginChar
+ , unsetPadding
+ , unsetMargins
+ , unsetMarginBg
+
+ -- * Borders
+ , border
+ , borderFg
+ , borderBg
+ , borderFgBlend
+ , borderFgBlendOffset
+ , borderTopFg
+ , borderRightFg
+ , borderBottomFg
+ , borderLeftFg
+ , borderTopBg
+ , borderRightBg
+ , borderBottomBg
+ , borderLeftBg
+ , unsetBorder
+ , borderTop
+ , borderRight
+ , borderBottom
+ , borderLeft
+
+ -- * Size
+ , width
+ , height
+ , maxWidth
+ , maxHeight
+ , grow
+ , fillWidth
+ , stretchHeight
+ , unsetWidth
+ , unsetHeight
+ , unsetMaxWidth
+ , unsetMaxHeight
+
+ -- * Alignment
+ , align
+ , valign
+ , unsetAlign
+ , Position
+ , position
+ , left
+ , center
+ , right
+ , top
+ , bottom
+
+ -- * Wrapping
+ , noWrap
+ , unsetNoWrap
+ ) where
+
+import Lipstick.Internal.Mod
+import Lipstick.Internal.Types (Flag (..), Position, Underline (..), bottom, center, left, position, right, top)
+
+-- $setup
+-- >>> import Lipstick
diff --git a/src/Lipstick/Outline.hs b/src/Lipstick/Outline.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Outline.hs
@@ -0,0 +1,425 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Lists and trees.
+--
+-- Both are outlines: items with an enumerator (a bullet, a number, a tree
+-- branch) and nested items indented below them. A 'tree' has a root;
+-- 'forest', 'list' and 'nestedList' do not. By default 'tree' and 'forest'
+-- use tree branches, 'list' and 'nestedList' bullets.
+--
+-- Items are blocks, so anything can go in an outline, tables included.
+--
+-- == Examples
+--
+-- >>> let os = Node "." [Node "macOS" [], Node "Linux" [Node "NixOS" [], Node "Arch" []], Node "BSD" []]
+-- >>> putBlock (tree mempty os)
+-- .
+-- ├── macOS
+-- ├── Linux
+-- │ ├── NixOS
+-- │ └── Arch
+-- └── BSD
+-- >>> putBlock (tree (enumerator roundedTreeEnumerator) os)
+-- .
+-- ├── macOS
+-- ├── Linux
+-- │ ├── NixOS
+-- │ ╰── Arch
+-- ╰── BSD
+--
+-- >>> let shops = ["Glossier", "Claire's Boutique", "Nyx"]
+-- >>> putBlock (list mempty shops)
+-- • Glossier
+-- • Claire's Boutique
+-- • Nyx
+-- >>> putBlock (list (enumerator arabic) shops)
+-- 1. Glossier
+-- 2. Claire's Boutique
+-- 3. Nyx
+--
+-- Nested lists, with an enumerator for each depth:
+--
+-- >>> let products = [Node "Glossier" [Node "Cloud Paint" [], Node "Boy Brow" []], Node "Nyx" []]
+-- >>> putBlock (nestedList (enumerator (byDepth (\d -> if d == 0 then roman else dash))) products)
+-- I. Glossier
+-- - Cloud Paint
+-- - Boy Brow
+-- II. Nyx
+--
+-- Items wrap in the width left after their enumerator:
+--
+-- >>> putBlock (fromGrid (layout (Just 16) (list mempty ["A long item that wraps", "short"])))
+-- • A long item
+-- that wraps
+-- • short
+--
+-- Items can be styled by position, and are blocks themselves:
+--
+-- >>> putBlock (list (itemStyleWith (\p -> if isLast p then border roundedBorder else mempty)) ["one", "two", "last"])
+-- • one
+-- • two
+-- • ╭────╮
+-- │last│
+-- ╰────╯
+--
+-- An enumerator of your own:
+--
+-- >>> let arrows = markers (const "→ ")
+-- >>> putBlock (list (enumerator arrows) shops)
+-- → Glossier
+-- → Claire's Boutique
+-- → Nyx
+module Lipstick.Outline
+ ( Outline
+ , tree
+ , forest
+ , list
+ , nestedList
+
+ -- * Styling
+ , ItemPos (itemDepth, itemIndex, itemSiblings)
+ , rootStyle
+ , itemStyle
+ , itemStyleWith
+ , enumeratorStyle
+ , enumeratorStyleWith
+ , indenterStyle
+ , indenterStyleWith
+ , itemOffset
+
+ -- * Enumerators
+ , Enumerator (enumMarker, enumIndent)
+ , markers
+ , enumerator
+ , byDepth
+ , isLast
+ , indenter
+ , treeEnumerator
+ , roundedTreeEnumerator
+ , bullet
+ , dash
+ , asterisk
+ , arabic
+ , alphabet
+ , roman
+ ) where
+
+import Control.Applicative ((<|>))
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Tree (Forest, Tree (..))
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Layout (Assign (..), Block (..), Measured (..), Request (..), TextStyle, cropLayoutWidth, layoutIn, measureIn, takenWidth)
+import Lipstick.Internal.Types (Attrs, fillAttrs, left, right)
+import Lipstick.Internal.Mod
+import Lipstick.Style (Style, frame, render)
+
+-- $setup
+-- >>> import Lipstick
+
+-- | How items are marked. Markers of different widths at one level are
+-- right-aligned to the widest. Make one with 'markers', and change its
+-- fields with record update syntax:
+--
+-- >>> let arrows = (markers (\p -> if isLast p then "└> " else "├> ")) {enumIndent = \p -> Just (if isLast p then " " else "│ ")}
+-- >>> putBlock (tree (enumerator arrows) (Node "root" [Node "a" [Node "a.1" []], Node "b" []]))
+-- root
+-- ├> a
+-- │ └> a.1
+-- └> b
+data Enumerator = Enumerator
+ { enumMarker :: ItemPos -> Text
+ -- ^ the marker for an item
+ , enumIndent :: ItemPos -> Maybe Text
+ -- ^ what goes before the item's further lines and its children;
+ -- 'Nothing' for spaces as wide as the widest marker at the item's level
+ }
+
+-- | Where an item is: its depth (0 for the top level), its index among its
+-- siblings (from 0), and how many siblings there are, itself included. At
+-- the top level, only the items that 'itemOffset' shows count.
+data ItemPos = ItemPos
+ { itemDepth :: !Int
+ , itemIndex :: !Int
+ , itemSiblings :: !Int
+ }
+ deriving (Eq, Show)
+
+-- | The settings of a list or tree: its enumerator and indenter, the
+-- styles of the root, items, enumerators and indentation, its size, and
+-- the items it shows. Change them with the @t'Mod' t'Outline'@ passed to
+-- 'tree', 'forest', 'list' or 'nestedList'.
+--
+-- Items are laid out in the width left after their indentation and
+-- enumerator, so their text wraps to fit. 'width' is the width of the
+-- outline when there is room for it, as for a style: items wrap to fit it,
+-- and every line is padded to it with the background of its item's style.
+-- 'fillWidth' pads to the width the outline is given, and 'height' pads
+-- with blank lines up to that many.
+data Outline = Outline
+ { outEnumerator :: Enumerator
+ , outIndenter :: Maybe (ItemPos -> Text)
+ , outItemStyle :: ItemPos -> Mod Style
+ , outEnumStyle :: ItemPos -> Mod Style
+ , outIndentStyle :: Maybe (ItemPos -> Mod Style)
+ , outRootStyle :: Mod Style
+ , outSize :: Size
+ , outOffset :: (Int, Int)
+ }
+
+instance HasSize Outline where
+ overSize f o = o {outSize = f (outSize o)}
+
+instance HasCrop Outline
+
+treeDefaults, listDefaults :: Outline
+treeDefaults =
+ Outline
+ { outEnumerator = treeEnumerator
+ , outIndenter = Nothing
+ , outItemStyle = const mempty
+ , outEnumStyle = const mempty
+ , outIndentStyle = Nothing
+ , outRootStyle = mempty
+ , outSize = defSize
+ , outOffset = (0, 0)
+ }
+listDefaults = treeDefaults {outEnumerator = bullet}
+
+-- | A tree: the root, then its children, with tree branches by default.
+tree :: Mod Outline -> Tree Block -> Block
+tree m (Node root kids) =
+ let (o, props) = runMod m treeDefaults
+ in outline o props $ \ctx -> Entry [] [] [] (fillOf (outRootStyle o)) (frame (outRootStyle o) root) : items ctx o 0 [] kids
+
+-- | Trees without a common root, with tree branches by default.
+forest :: Mod Outline -> Forest Block -> Block
+forest m kids = let (o, props) = runMod m treeDefaults in outline o props (\ctx -> items ctx o 0 [] kids)
+
+-- | A list of items, with bullets by default.
+list :: Mod Outline -> [Block] -> Block
+list m = nestedList m . map (`Node` [])
+
+-- | A list whose items can have nested items, with bullets by default.
+nestedList :: Mod Outline -> Forest Block -> Block
+nestedList m kids = let (o, props) = runMod m listDefaults in outline o props (\ctx -> items ctx o 0 [] kids)
+
+-- | An item of an outline, flattened: what goes before its lines, and the
+-- item itself, laid out in the width that is left.
+data Entry = Entry
+ { entryOuter :: [Cell]
+ -- ^ the indentation of the levels above, before every line
+ , entryMarker :: [Cell]
+ -- ^ before the first line: the enumerator
+ , entryIndent :: [Cell]
+ -- ^ before the other lines
+ , entryFill :: Attrs
+ -- ^ for padding the item's lines
+ , entryBlock :: Block
+ }
+
+-- | The columns before an entry's lines.
+prefixWidth :: Entry -> Int
+prefixWidth e = cellsWidth (entryOuter e) + max (cellsWidth (entryMarker e)) (cellsWidth (entryIndent e))
+
+-- | Entries laid out in the width they are given, padded to it (each line
+-- with its item's fill attributes) and to the height, with the common
+-- properties on top.
+outline :: Outline -> Props -> (TextStyle -> [Entry]) -> Block
+outline o props entriesIn = Block $ \ctx -> outlineNode o props [(e, measureIn ctx (entryBlock e)) | e <- entriesIn ctx]
+
+outlineNode :: Outline -> Props -> [(Entry, Measured)] -> Measured
+outlineNode o props entries = Measured req run
+ where
+ Size wSet hSet weight stretch = outSize o
+ natural = fromMaybe (maximum (0 : [prefixWidth e + reqMax (blockRequest n) | (e, n) <- entries])) wSet
+ smallest = fromMaybe (maximum (0 : [prefixWidth e + reqMin (blockRequest n) | (e, n) <- entries])) wSet
+ capW x = maybe x (min x . max 0) (propMaxWidth props)
+ capH x = maybe x (min x . max 0) (propMaxHeight props)
+ req = Request (capW smallest) (capW natural) weight (max 0 <$> propMaxWidth props) stretch False
+ run (Assign w h) = (fitWidth w (withProps props tall), capH (max (fromMaybe 0 hSet) (sum (map snd laid))))
+ where
+ wide = cropLayoutWidth (propMaxWidth props) weight natural w
+ laid = map entryLines entries
+ padded = [alignCells a left wide l | (ls, _) <- laid, (a, l) <- ls]
+ tallest = max (fromMaybe 0 hSet) (if stretch then h else 0)
+ tall = padded ++ replicate (tallest - length padded) (blankCells mempty wide)
+ entryLines (e, node) =
+ let (g, n) = blockLayout node (Assign (takenWidth (blockRequest node) (wide - prefixWidth e)) 0)
+ body = case gridCells g of
+ [] -> [[]]
+ ls -> ls
+ in ( [(entryFill e, entryOuter e ++ p ++ l) | (p, l) <- zip (entryMarker e : repeat (entryIndent e)) body]
+ , max 1 n
+ )
+
+-- | The background (and reverse video) of a style, for padding.
+fillOf :: Mod Style -> Attrs
+fillOf = fillAttrs . propAttrs . propsOf
+
+-- | The entries of a level of items, below the indentation of the levels
+-- above.
+items :: TextStyle -> Outline -> Int -> [Cell] -> Forest Block -> [Entry]
+items ctx o depth outer kids0 = concat (zipWith3 item [0 ..] markerCells kids)
+ where
+ kids =
+ if depth == 0
+ then let (start, end) = outOffset o in take (length kids0 - start - end) (drop start kids0)
+ else kids0
+ n = length kids
+ e = outEnumerator o
+ pos i = ItemPos depth i n
+ styledLine m t = concat (take 1 (gridCells (layoutIn ctx Nothing (render m (plain t)))))
+ enumStyle i = outEnumStyle o (pos i)
+ indentStyle i = maybe (enumStyle i) ($ pos i) (outIndentStyle o)
+ markerCells = [styledLine (enumStyle i) (enumMarker e (pos i)) | i <- [0 .. n - 1]]
+ markerW = maximum (0 : map cellsWidth markerCells)
+
+ item i mk (Node b children) =
+ let -- Alignment space keeps the enumerator's background, as in lipgloss.
+ markerRight = alignCells (fillOf (enumStyle i)) right markerW mk
+ -- Without indentation text, spaces that make the indentation as
+ -- wide as the enumerator once the style adds its padding and margins.
+ frameW = cellsWidth (styledLine (indentStyle i) "")
+ indentText =
+ fromMaybe (T.replicate (markerW - frameW) " ") (fmap ($ pos i) (outIndenter o) <|> enumIndent e (pos i))
+ indent = alignCells (fillOf (indentStyle i)) left markerW (styledLine (indentStyle i) indentText)
+ -- An indentation wider than the enumerators widens the
+ -- enumerator, so that every line of the item starts in one column.
+ marker = alignCells (fillOf (enumStyle i)) left (cellsWidth indent) markerRight
+ itemStyle' = outItemStyle o (pos i)
+ in Entry outer marker indent (fillOf itemStyle') (frame itemStyle' b)
+ : items ctx o (depth + 1) (outer ++ indent) children
+
+-- Styling ---------------------------------------------------------------------
+
+-- | Style the root of a tree.
+rootStyle :: Mod Style -> Mod Outline
+rootStyle m = fieldMod (\o -> o {outRootStyle = outRootStyle o <> m})
+
+-- | Style every item.
+itemStyle :: Mod Style -> Mod Outline
+itemStyle m = itemStyleWith (const m)
+
+-- | Style items by position. Successive item styles add up.
+itemStyleWith :: (ItemPos -> Mod Style) -> Mod Outline
+itemStyleWith f = fieldMod (\o -> o {outItemStyle = \p -> outItemStyle o p <> f p})
+
+-- | Style every enumerator (and the indentation below it).
+enumeratorStyle :: Mod Style -> Mod Outline
+enumeratorStyle m = enumeratorStyleWith (const m)
+
+-- | Style the indentation before an item's further lines and its
+-- children. Until an indenter style is set, the enumerator style is used.
+indenterStyle :: Mod Style -> Mod Outline
+indenterStyle m = indenterStyleWith (const m)
+
+-- | Style the indentation by position. Successive indenter styles add up.
+indenterStyleWith :: (ItemPos -> Mod Style) -> Mod Outline
+indenterStyleWith f = fieldMod (\o -> o {outIndentStyle = Just (\p -> maybe mempty ($ p) (outIndentStyle o) <> f p)})
+
+-- | @itemOffset start end@ shows only part of the top-level items, leaving
+-- out @start@ at the beginning and @end@ at the end. Enumerators and
+-- 'ItemPos' count only the items shown.
+itemOffset :: Int -> Int -> Mod Outline
+itemOffset start end = fieldMod (\o -> o {outOffset = (max 0 start, max 0 end)})
+
+-- | Style enumerators by position. Successive enumerator styles add up.
+enumeratorStyleWith :: (ItemPos -> Mod Style) -> Mod Outline
+enumeratorStyleWith f = fieldMod (\o -> o {outEnumStyle = \p -> outEnumStyle o p <> f p})
+
+-- Enumerators -----------------------------------------------------------------
+
+-- | Mark items with this enumerator.
+--
+-- >>> putBlock (nestedList (enumerator (byDepth (\d -> if d == 0 then roman else bullet))) [Node "one" [Node "two" []]])
+-- I. one
+-- • two
+enumerator :: Enumerator -> Mod Outline
+enumerator e = fieldMod (\o -> o {outEnumerator = e})
+
+-- | What goes before an item's further lines and its children, instead of
+-- the enumerator's own indentation.
+indenter :: (ItemPos -> Text) -> Mod Outline
+indenter f = fieldMod (\o -> o {outIndenter = Just f})
+
+-- | An enumerator chosen by depth (0 for the top level).
+byDepth :: (Int -> Enumerator) -> Enumerator
+byDepth f =
+ Enumerator
+ { enumMarker = \p -> enumMarker (f (itemDepth p)) p
+ , enumIndent = \p -> enumIndent (f (itemDepth p)) p
+ }
+
+-- | Whether an item is the last among its siblings.
+isLast :: ItemPos -> Bool
+isLast p = itemIndex p == itemSiblings p - 1
+
+-- | @├── @ and @└── @, with @│@ continuing the branch.
+treeEnumerator :: Enumerator
+treeEnumerator = branches "└── "
+
+-- | Like 'treeEnumerator' with a rounded last branch: @╰── @.
+roundedTreeEnumerator :: Enumerator
+roundedTreeEnumerator = branches "╰── "
+
+branches :: Text -> Enumerator
+branches lastBranch =
+ Enumerator
+ { enumMarker = \p -> if isLast p then lastBranch else "├── "
+ , enumIndent = \p -> Just (if isLast p then " " else "│ ")
+ }
+
+-- | An enumerator with these markers, and further lines and children
+-- indented by spaces as wide as the widest marker at their level.
+--
+-- >>> putBlock (list (enumerator (markers (\p -> if isLast p then "> " else "- "))) ["a", "b", "c"])
+-- - a
+-- - b
+-- > c
+markers :: (ItemPos -> Text) -> Enumerator
+markers f = Enumerator f (const Nothing)
+
+constant :: Text -> Enumerator
+constant t = markers (const t)
+
+-- | @• @
+bullet :: Enumerator
+bullet = constant "• "
+
+-- | @- @
+dash :: Enumerator
+dash = constant "- "
+
+-- | @* @
+asterisk :: Enumerator
+asterisk = constant "* "
+
+numbered :: (Int -> Text) -> Enumerator
+numbered f = markers (\p -> f (itemIndex p + 1) <> ". ")
+
+-- | @1. @, @2. @, …
+arabic :: Enumerator
+arabic = numbered (T.pack . show)
+
+-- | @A. @, @B. @, … @Z. @, @AA. @, …
+alphabet :: Enumerator
+alphabet = numbered letters
+ where
+ letters k
+ | k <= 0 = ""
+ | otherwise = let (q, r) = (k - 1) `divMod` 26 in letters q <> T.singleton (toEnum (fromEnum 'A' + r))
+
+-- | @I. @, @II. @, @III. @, @IV. @, …
+roman :: Enumerator
+roman = numbered (T.pack . go)
+ where
+ go 0 = ""
+ go k = case dropWhile ((> k) . fst) numerals of
+ (v, s) : _ -> s ++ go (k - v)
+ [] -> ""
+ numerals =
+ [ (1000, "M"), (900, "CM"), (500, "D"), (400, "CD"), (100, "C"), (90, "XC")
+ , (50, "L"), (40, "XL"), (10, "X"), (9, "IX"), (5, "V"), (4, "IV"), (1, "I")
+ ]
diff --git a/src/Lipstick/Place.hs b/src/Lipstick/Place.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Place.hs
@@ -0,0 +1,106 @@
+-- | Placing a block in a larger area filled with whitespace.
+--
+-- == Examples
+--
+-- >>> let hi = render (border roundedBorder) "hi"
+-- >>> putBlock (place (width 16 <> height 5 <> align center <> valign center <> whitespaceChars "·") hi)
+-- ················
+-- ······╭──╮······
+-- ······│hi│······
+-- ······╰──╯······
+-- ················
+-- >>> putBlock (place (width 16 <> height 3 <> align right <> valign bottom <> whitespaceChars "·") hi)
+-- ············╭──╮
+-- ············│hi│
+-- ············╰──╯
+--
+-- Without a 'Lipstick.Mod.width', the area is as wide as the space it is
+-- laid out in:
+--
+-- >>> putBlock (fromGrid (layout (Just 20) (place (align center <> whitespaceChars "-") " centred ")))
+-- ----- centred ------
+module Lipstick.Place
+ ( Place
+ , place
+ , whitespaceChars
+ ) where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Layout (Assign (..), Block (..), Measured (..), Request (..), cropLayoutWidth, measureIn)
+import Lipstick.Internal.Types
+import Lipstick.Internal.Mod
+
+-- $setup
+-- >>> import Lipstick
+
+-- | The surrounding area: its size, where the block sits in it, and the
+-- characters of the whitespace. Its text attributes colour the whitespace
+-- and are the base for the placed block.
+data Place = Place
+ { placeSize :: !Size
+ , placeAlign :: !Align
+ , placeChars :: !Text
+ }
+ deriving (Eq, Show)
+
+instance HasSize Place where
+ overSize f p = p {placeSize = f (placeSize p)}
+
+instance HasAlign Place where
+ overAlign f p = p {placeAlign = f (placeAlign p)}
+
+instance HasCrop Place
+
+defPlace :: Place
+defPlace = Place defSize defAlign (T.singleton ' ')
+
+-- | Characters repeated to fill the whitespace (default a space).
+whitespaceChars :: Text -> Mod Place
+whitespaceChars t = fieldMod (\p -> p {placeChars = t})
+
+-- | Place a block in an area, at the position set by 'align' and
+-- 'valign'. The area is as wide as the space it is laid out in, or 'width'
+-- columns if set and there is room for them, and at least 'height' lines
+-- if set. A block wider than the area is laid out in its width, so its
+-- text wraps; a block taller than the area makes it taller.
+--
+-- >>> putBlock (place (width 7 <> height 3 <> align center <> valign center <> whitespaceChars ".") "b")
+-- .......
+-- ...b...
+-- .......
+place :: Mod Place -> Block -> Block
+place m b = Block $ \ctx -> placeNode m (measureIn ctx b)
+
+placeNode :: Mod Place -> Measured -> Measured
+placeNode m nb = Measured req run
+ where
+ (Place (Size wSet hSet weight stretch) (Align ah av) chars, props) = runMod m defPlace
+ r = blockRequest nb
+ capW x = maybe x (min x . max 0) (propMaxWidth props)
+ capH x = maybe x (min x . max 0) (propMaxHeight props)
+ req =
+ Request
+ { reqMin = capW (fromMaybe (reqMin r) wSet)
+ , reqMax = capW (fromMaybe (reqMax r) wSet)
+ , -- Without a width, the area is all the space there is.
+ reqGrow = maybe (max 1 weight) (const weight) wSet
+ , reqLimit = max 0 <$> propMaxWidth props
+ , reqStretch = stretch
+ , reqFill = False
+ }
+ run (Assign w h) = (fitWidth w (withProps props ls), natural)
+ where
+ outerW = cropLayoutWidth (propMaxWidth props) (reqGrow req) (fromMaybe (reqMax r) wSet) w
+ (g, n) = blockLayout nb (Assign (if reqGrow r > 0 then outerW else min outerW (reqMax r)) outerH)
+ natural = capH (max (fromMaybe 0 hSet) n)
+ -- From the child's natural height, not its grid's: the grid is
+ -- laid out with this height, for a child that stretches.
+ outerH = maximum [n, fromMaybe 0 hSet, if stretch then h else 0]
+ ws k = fillCells mempty chars k
+ (left', right') = splitExtra ah (outerW - gridWidth g)
+ (above, below) = splitExtra av (outerH - gridHeight g)
+ body = [ws left' ++ l ++ ws right' | l <- gridCells g]
+ ls = replicate above (ws outerW) ++ body ++ replicate below (ws outerW)
diff --git a/src/Lipstick/Style.hs b/src/Lipstick/Style.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Style.hs
@@ -0,0 +1,554 @@
+-- | Styles: text attributes plus a box model (alignment, padding, border,
+-- margins), applied to text or to an existing block.
+--
+-- A style is a @'Mod' 'Style'@, built from the modifiers in
+-- "Lipstick.Mod". The examples print with 'Lipstick.Terminal.putBlock';
+-- the output is shown without colours.
+--
+-- == Examples
+--
+-- Text in a box:
+--
+-- >>> putBlock (render (border roundedBorder <> padding 0 1) "Hello, kitty")
+-- ╭──────────────╮
+-- │ Hello, kitty │
+-- ╰──────────────╯
+--
+-- With a 'width', text is word-wrapped and aligned inside it:
+--
+-- >>> putBlock (render (width 18 <> border normalBorder <> align center) "Text wraps to fit the width")
+-- ┌────────────────┐
+-- │ Text wraps to │
+-- │ fit the width │
+-- └────────────────┘
+--
+-- With 'noWrap', lines that are too long are cut short instead:
+--
+-- >>> putBlock (render (width 14 <> border normalBorder <> noWrap) "This line is too long")
+-- ┌────────────┐
+-- │This line i…│
+-- └────────────┘
+--
+-- Padding is inside the border and margins outside it; 'paddingChar' and
+-- 'marginChar' make them visible:
+--
+-- >>> putBlock (render (border normalBorder <> padding 1 2 <> paddingChar '·' <> margin 1 3 <> marginChar '░') "box")
+-- ░░░░░░░░░░░░░░░
+-- ░░░┌───────┐░░░
+-- ░░░│·······│░░░
+-- ░░░│··box··│░░░
+-- ░░░│·······│░░░
+-- ░░░└───────┘░░░
+-- ░░░░░░░░░░░░░░░
+--
+-- Some sides of the border only:
+--
+-- >>> putBlock (render (border thickBorder <> borderLeft False <> borderRight False) "rules above and below")
+-- ━━━━━━━━━━━━━━━━━━━━━
+-- rules above and below
+-- ━━━━━━━━━━━━━━━━━━━━━
+--
+-- Later settings win, so a style is extended with '<>':
+--
+-- >>> let card = border roundedBorder <> padding 0 1 <> width 20
+-- >>> let wide = card <> width 30
+-- >>> putBlock (vcat [render card "a card", render wide "a wider card"])
+-- ╭──────────────────╮
+-- │ a card │
+-- ╰──────────────────╯
+-- ╭────────────────────────────╮
+-- │ a wider card │
+-- ╰────────────────────────────╯
+--
+-- 'frame' puts a block that already exists in a box:
+--
+-- >>> putBlock (frame (border doubleBorder <> padding 0 1) (vcat ["one", "two", "three"]))
+-- ╔═══════╗
+-- ║ one ║
+-- ║ two ║
+-- ║ three ║
+-- ╚═══════╝
+--
+-- The getters read a style back:
+--
+-- >>> frameSize (border normalBorder <> padding 1 2 <> margin 0 1)
+-- (8,4)
+module Lipstick.Style
+ ( Style
+ , render
+ , frame
+ , tabWidth
+ , unsetTabWidth
+ , inline
+ , unsetInline
+ , transform
+ , unsetTransform
+ , breakAfter
+ , colorWhitespace
+ , underlineSpaces
+ , strikethroughSpaces
+ , inherit
+
+ -- * Getters
+ -- | The getters read what a style sets, applied to the defaults. They
+ -- do not see what it inherits where it is used: inside a 'frame', the
+ -- 'align', 'noWrap', 'breakAfter', 'tabWidth' and 'transform' it leaves
+ -- unset come from the enclosing style.
+ , getAttrs
+ , getMaxWidth
+ , getMaxHeight
+ , getPadding
+ , getMargins
+ , getMarginBg
+ , getBorder
+ , getBorderSides
+ , getWidth
+ , getHeight
+ , getAlign
+ , getVAlign
+ , getTabWidth
+ , getInline
+ , horizontalPadding
+ , verticalPadding
+ , horizontalMargins
+ , verticalMargins
+ , horizontalBorderSize
+ , verticalBorderSize
+ , horizontalFrameSize
+ , verticalFrameSize
+ , frameSize
+ ) where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Lipstick.Border
+import Lipstick.Color (Color)
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Layout (Assign (..), Block (..), Measured (..), Request (..), TextStyle (..), cropLayoutWidth, measureIn, takenWidth, textBlock)
+import Lipstick.Internal.Types
+import Lipstick.Internal.Mod
+import Lipstick.Width (textWidth)
+
+-- $setup
+-- >>> import Lipstick
+-- >>> import Data.Text qualified as T
+
+-- | What 'render' and 'frame' draw with, set by a @'Mod' 'Style'@. Its
+-- text attributes apply to the content. The background and reverse video
+-- also fill the padding and alignment space (the background unless
+-- @'colorWhitespace' False@). The border and margins have their own
+-- colours ('borderFg', 'borderBg', 'marginBg').
+data Style = Style
+ { styleBox :: !Box
+ , styleBorder :: !BorderProps
+ , styleSize :: !Size
+ , styleAlign :: !Align
+ , styleTabWidth :: !Int
+ , styleInline :: !(Maybe Bool)
+ , styleWrap :: !Bool
+ , styleBreaks :: ![Char]
+ , styleColorWhitespace :: !Bool
+ , styleUnderlineSpaces :: !(Maybe Bool)
+ , styleStrikeSpaces :: !(Maybe Bool)
+ , styleTransform :: !(Maybe (Text -> Text))
+ }
+
+instance HasBox Style where
+ overBox f s = s {styleBox = f (styleBox s)}
+
+instance HasBorder Style where
+ overBorder f s = s {styleBorder = f (styleBorder s)}
+
+instance HasSize Style where
+ overSize f s = s {styleSize = f (styleSize s)}
+
+instance HasAlign Style where
+ overAlign f s = s {styleAlign = f (styleAlign s)}
+
+instance HasWrap Style where
+ overWrap f s = s {styleWrap = f (styleWrap s)}
+
+instance HasCrop Style
+
+defStyle :: Style
+defStyle = Style defBox defBorderProps defSize defAlign 4 Nothing True [] True Nothing Nothing Nothing
+
+-- | The style and properties a modifier produces from the defaults.
+resolveStyle :: Mod Style -> (Style, Props)
+resolveStyle m = runMod m defStyle
+
+-- | How many spaces a tab becomes (default 4).
+tabWidth :: Int -> Mod Style
+tabWidth n = fieldMod (\s -> s {styleTabWidth = max 0 n})
+
+-- | Back to the default of 4 spaces per tab, even inside a style that
+-- sets another 'tabWidth'.
+unsetTabWidth :: Mod Style
+unsetTabWidth = fieldMod (\s -> s {styleTabWidth = styleTabWidth defStyle})
+
+-- | No box: padding, margins, border, size and alignment are ignored, but
+-- the 'maxWidth' and 'maxHeight' crops apply. Newlines are removed from
+-- the text, including the text in blocks the style frames, unless
+-- something nearer sets 'unsetInline'. Only text is joined into one line:
+-- blocks inside, such as a 'Lipstick.Block.vcat' or another box, keep
+-- their lines.
+--
+-- >>> putBlock (render (inline <> border normalBorder <> padding 1 1) "one\ntwo")
+-- onetwo
+inline :: Mod Style
+inline = fieldMod (\s -> s {styleInline = Just True})
+
+-- | Undo 'inline': render with the box, and keep the newlines even inside
+-- a style that sets 'inline'.
+unsetInline :: Mod Style
+unsetInline = fieldMod (\s -> s {styleInline = Just False})
+
+-- | Change the text before rendering it (each styled piece separately),
+-- including text inside blocks the style frames.
+--
+-- >>> putBlock (render (transform T.toUpper) "raow!")
+-- RAOW!
+transform :: (Text -> Text) -> Mod Style
+transform f = fieldMod (\s -> s {styleTransform = Just f})
+
+-- | No 'transform', not even one from an enclosing style.
+unsetTransform :: Mod Style
+unsetTransform = fieldMod (\s -> s {styleTransform = Nothing})
+
+-- | Also allow a line break after any of these characters (such as @-@),
+-- besides at spaces.
+--
+-- >>> putBlock (render (width 9) "a long-winded sentence")
+-- a
+-- long-wind
+-- ed
+-- sentence
+-- >>> putBlock (render (breakAfter "-" <> width 9) "a long-winded sentence")
+-- a long-
+-- winded
+-- sentence
+breakAfter :: [Char] -> Mod Style
+breakAfter cs = fieldMod (\s -> s {styleBreaks = cs})
+
+-- | Whether the background colours the padding and alignment space
+-- (default 'True').
+colorWhitespace :: Bool -> Mod Style
+colorWhitespace v = fieldMod (\s -> s {styleColorWhitespace = v})
+
+-- | Whether spaces in the text are underlined. By default they are when
+-- the text is; @underlineSpaces True@ underlines them even when the text
+-- is not.
+underlineSpaces :: Bool -> Mod Style
+underlineSpaces v = fieldMod (\s -> s {styleUnderlineSpaces = Just v})
+
+-- | Like 'underlineSpaces', for strikethrough.
+strikethroughSpaces :: Bool -> Mod Style
+strikethroughSpaces v = fieldMod (\s -> s {styleStrikeSpaces = Just v})
+
+-- | A parent style without its padding and margin amounts, to put before
+-- a child style: in @inherit parent <> child@, the child gets the
+-- parent's settings except those amounts, and its own settings win, as
+-- with lipgloss's @child.Inherit(parent)@.
+--
+-- >>> let parent = border roundedBorder <> padding 1 4 <> width 20
+-- >>> putBlock (render (inherit parent <> padding 0 1 <> width 9) "child")
+-- ╭───────╮
+-- │ child │
+-- ╰───────╯
+--
+-- Settings that come after a modifier always win over it, so
+-- @child <> inherit parent@ would let the parent override the child.
+inherit :: Mod Style -> Mod Style
+inherit (Mod f g) = Mod (\s -> keepSpacing s (f s)) g
+ where
+ keepSpacing s s' =
+ s' {styleBox = (styleBox s') {boxPadding = boxPadding (styleBox s), boxMargin = boxMargin (styleBox s)}}
+
+-- | Text in a box: @render m inl@ is
+-- @'frame' m ('Lipstick.Block.fromInline' inl)@. The text wraps to fit
+-- inside the padding and border, in a box that is its 'width' wide when
+-- there is room for it, and otherwise no wider than the space it is laid
+-- out in. With 'noWrap', lines that are too long are cut short with an
+-- ellipsis instead.
+render :: Mod Style -> Inline -> Block
+render m = frame m . textBlock
+
+-- | Put a block in a box. The block is laid out in the width left inside
+-- the padding and border: text in it wraps to fit, and other blocks take
+-- what they need, aligned by 'align'.
+--
+-- The style's text settings ('align', 'noWrap', 'breakAfter', 'tabWidth',
+-- 'transform', 'inline') apply to all the text inside, unless something
+-- nearer sets them again, as its colours do.
+frame :: Mod Style -> Block -> Block
+frame m b = Block $ \ctx ->
+ let (s, p) = runMod m (inheriting ctx)
+ n = measureIn (textStyleOf ctx s) b
+ in if styleInline s == Just True then inlineNode p n else box s p n
+
+-- | The defaults of a style inside inherited text settings. Whether the
+-- style itself is 'inline' (has no box) is not inherited: 'styleInline'
+-- stays unset, and 'textStyleOf' passes the inherited removal of newlines
+-- on unless the style sets it.
+inheriting :: TextStyle -> Style
+inheriting ctx =
+ defStyle
+ { styleAlign = (styleAlign defStyle) {alignH = textAlign ctx}
+ , styleWrap = textWrap ctx
+ , styleBreaks = textBreaks ctx
+ , styleTabWidth = textTabWidth ctx
+ , styleTransform = textTransform ctx
+ }
+
+-- | The text settings a style passes on to what it frames.
+textStyleOf :: TextStyle -> Style -> TextStyle
+textStyleOf ctx s =
+ TextStyle
+ { textAlign = alignH (styleAlign s)
+ , textWrap = styleWrap s
+ , textBreaks = styleBreaks s
+ , textTabWidth = styleTabWidth s
+ , textTransform = styleTransform s
+ , textInline = fromMaybe (textInline ctx) (styleInline s)
+ }
+
+-- | An 'inline' style: no box, only its attributes under the content and
+-- its 'maxWidth' and 'maxHeight' crop.
+inlineNode :: Props -> Measured -> Measured
+inlineNode p n = Measured req run
+ where
+ r = blockRequest n
+ capW x = maybe x (min x . max 0) (propMaxWidth p)
+ capH x = maybe x (min x . max 0) (propMaxHeight p)
+ req = r {reqMin = capW (reqMin r), reqMax = capW (reqMax r), reqLimit = max 0 <$> propMaxWidth p, reqFill = False}
+ run (Assign w h) =
+ let (g, natural) = blockLayout n (Assign (cropLayoutWidth (propMaxWidth p) (reqGrow r) (reqMax r) w) h)
+ in (fitWidth w (withProps p (gridCells g)), capH natural)
+
+-- | A box around a block, laid out at the width it is given: margins,
+-- border and padding take their columns and the block gets the rest (all
+-- of it if it is text, and what it needs otherwise).
+box :: Style -> Props -> Measured -> Measured
+box s p c = Measured req run
+ where
+ Box (Sides pt pr pb pl) (Sides mt mr mb ml) _ _ _ = styleBox s
+ Size wSet hSet weight stretch = styleSize s
+ (bl, br) = borderColumns (styleBorder s)
+ Edges et _ eb _ = snd (borderEdges (styleBorder s))
+ frameW = pl + pr + bl + br
+ frameH = pt + pb + fromEnum et + fromEnum eb
+ capW x = maybe x (min x . max 0) (propMaxWidth p)
+ capH x = maybe x (min x . max 0) (propMaxHeight p)
+ cr = blockRequest c
+ natW = maybe (reqMax cr + frameW) id wSet + ml + mr
+ req =
+ Request
+ { reqMin = capW (maybe (reqMin cr + frameW) id wSet + ml + mr)
+ , reqMax = capW natW
+ , reqGrow = weight
+ , reqLimit = max 0 <$> propMaxWidth p
+ , reqStretch = stretch
+ , reqFill = False
+ }
+ run (Assign w h) = (fitWidth w grid, natural)
+ where
+ boxW = max 0 (cropLayoutWidth (propMaxWidth p) weight natW w - ml - mr)
+ innerW = max 0 (boxW - frameW)
+ -- The height the box (without margins) is drawn at; the natural
+ -- height must not depend on it.
+ target = max (fromMaybe 0 hSet) (if stretch then h - mt - mb else 0)
+ childW = if reqFill cr then innerW else takenWidth cr innerW
+ (g, n) = blockLayout c (Assign childW (max 0 (target - frameH)))
+ natural = capH (max (n + frameH) (fromMaybe 0 hSet) + mt + mb)
+ sized = (styleSize s) {sizeWidth = Just boxW, sizeHeight = Just target}
+ grid = layoutBox s {styleSize = sized} p (gridCells g)
+
+-- | Widths of the left and right border columns.
+borderColumns :: BorderProps -> (Int, Int)
+borderColumns p =
+ let (b, e) = borderEdges p
+ w on t = if on then max 1 (textWidth t) else 0
+ in (w (edgeLeft e) (leftEdge b), w (edgeRight e) (rightEdge b))
+
+contentWidth :: Style -> Maybe Int
+contentWidth s = do
+ w <- sizeWidth (styleSize s)
+ let Sides _ pr _ pl = boxPadding (styleBox s)
+ (bl, br) = borderColumns (styleBorder s)
+ pure (max 0 (w - pl - pr - bl - br))
+
+-- | Draw a box around lines of content, at the style's width and height.
+layoutBox :: Style -> Props -> [[Cell]] -> Grid
+layoutBox s props content0 =
+ let attrs = propAttrs props
+ fill
+ | styleColorWhitespace s = fillAttrs attrs
+ | otherwise = (fillAttrs attrs) {attrBg = Nothing}
+ Box (Sides pt pr pb pl) (Sides mt mr mb ml) mbg pch mch = styleBox s
+ hgt = sizeHeight (styleSize s)
+ Align ah av = styleAlign s
+ bp = styleBorder s
+ (chars, edges) = borderEdges bp
+ (bl, br) = borderColumns bp
+ bt = if edgeTop edges then 1 else 0
+ bb = if edgeBottom edges then 1 else 0
+
+ content = map (map spaceRule) (underlay attrs fill content0)
+ spaceRule c
+ | cellText c == T.singleton ' ' && not (cellFill c) = c {cellAttrs = spaceAttrs (cellAttrs c)}
+ | otherwise = c
+ spaceAttrs a =
+ a
+ { attrUnderline = case styleUnderlineSpaces s of
+ Just True -> Just (fromMaybe SingleUnderline (attrUnderline a >>= visible))
+ Just False -> Just NoUnderline
+ Nothing -> attrUnderline a
+ , attrStrikethrough = maybe (attrStrikethrough a) Just (styleStrikeSpaces s)
+ }
+ visible u = if u == NoUnderline then Nothing else Just u
+
+ -- Horizontal alignment within the content width.
+ innerW = maximum (fromMaybe 0 (contentWidth s) : map cellsWidth content)
+ aligned = map (alignCells fill ah innerW) content
+
+ -- Vertical alignment within the content height.
+ innerH = maximum (length aligned : [h - pt - pb - bt - bb | Just h <- [hgt]])
+ (above, below) = splitExtra av (innerH - length aligned)
+ blankLine = blankCells fill innerW
+ tall = replicate above blankLine ++ aligned ++ replicate below blankLine
+
+ padW = pl + innerW + pr
+ padCells = fillCells fill (T.singleton pch)
+ padded =
+ replicate pt (padCells padW)
+ ++ [padCells pl ++ l ++ padCells pr | l <- tall]
+ ++ replicate pb (padCells padW)
+
+ sideAttrs side = mempty {attrFg = side (borderFgColors bp), attrBg = side (borderBgColors bp)}
+ piece a t n = fillCells a t n
+ corner a on t n = if on then piece a t n else []
+ hRule a l edge r = corner a (edgeLeft edges) l bl ++ piece a edge padW ++ corner a (edgeRight edges) r br
+ topRow = hRule (sideAttrs sideTop) (topLeftCorner chars) (topEdge chars) (topRightCorner chars)
+ bottomRow = hRule (sideAttrs sideBottom) (bottomLeftCorner chars) (bottomEdge chars) (bottomRightCorner chars)
+ sideL = if edgeLeft edges then piece (sideAttrs sideLeft) (leftEdge chars) bl else []
+ sideR = if edgeRight edges then piece (sideAttrs sideRight) (rightEdge chars) br else []
+ bordered =
+ blendBorder (borderFgStops bp) (borderFgOffset bp) edges (length sideL) (length sideR) $
+ [topRow | edgeTop edges]
+ ++ [sideL ++ l ++ sideR | l <- padded]
+ ++ [bottomRow | edgeBottom edges]
+
+ ma = mempty {attrBg = mbg}
+ boxW = bl + padW + br
+ outerW = ml + boxW + mr
+ marginCells = fillCells ma (T.singleton mch)
+ margined =
+ replicate mt (marginCells outerW)
+ ++ [marginCells ml ++ l ++ marginCells mr | l <- bordered]
+ ++ replicate mb (marginCells outerW)
+
+ in cropToProps props margined
+
+-- Getters ---------------------------------------------------------------------
+
+-- | The text attributes a modifier sets (on any thing).
+getAttrs :: Mod f -> Attrs
+getAttrs = propAttrs . propsOf
+
+-- | The 'maxWidth' a modifier sets (on any thing).
+getMaxWidth :: Mod f -> Maybe Int
+getMaxWidth = propMaxWidth . propsOf
+
+-- | The 'maxHeight' a modifier sets (on any thing).
+getMaxHeight :: Mod f -> Maybe Int
+getMaxHeight = propMaxHeight . propsOf
+
+field :: (Style -> a) -> Mod Style -> a
+field f = f . fst . resolveStyle
+
+-- | The padding on each side.
+getPadding :: Mod Style -> Sides Int
+getPadding = field (boxPadding . styleBox)
+
+-- | The margins on each side.
+getMargins :: Mod Style -> Sides Int
+getMargins = field (boxMargin . styleBox)
+
+-- | The 'marginBg', if one is set.
+getMarginBg :: Mod Style -> Maybe Color
+getMarginBg = field (boxMarginBg . styleBox)
+
+-- | The border characters, if a border is drawn.
+getBorder :: Mod Style -> Maybe Border
+getBorder m =
+ let bp = field styleBorder m
+ (chars, Edges t r b l) = borderEdges bp
+ in if or [t, r, b, l] then Just chars else Nothing
+
+-- | Which sides of the border are drawn.
+getBorderSides :: Mod Style -> Sides Bool
+getBorderSides m = let Edges t r b l = snd (borderEdges (field styleBorder m)) in Sides t r b l
+
+-- | The 'width', if one is set.
+getWidth :: Mod Style -> Maybe Int
+getWidth = field (sizeWidth . styleSize)
+
+-- | The 'height', if one is set.
+getHeight :: Mod Style -> Maybe Int
+getHeight = field (sizeHeight . styleSize)
+
+-- | The horizontal alignment ('left' by default).
+getAlign :: Mod Style -> Position
+getAlign = field (alignH . styleAlign)
+
+-- | The vertical alignment ('top' by default).
+getVAlign :: Mod Style -> Position
+getVAlign = field (alignV . styleAlign)
+
+-- | How many spaces a tab becomes.
+getTabWidth :: Mod Style -> Int
+getTabWidth = field styleTabWidth
+
+-- | Whether the style is 'inline'.
+getInline :: Mod Style -> Bool
+getInline = field ((== Just True) . styleInline)
+
+-- | Columns of padding: left plus right.
+horizontalPadding :: Mod Style -> Int
+horizontalPadding m = let Sides _ r _ l = getPadding m in l + r
+
+-- | Rows of padding: top plus bottom.
+verticalPadding :: Mod Style -> Int
+verticalPadding m = let Sides t _ b _ = getPadding m in t + b
+
+-- | Columns of margins: left plus right.
+horizontalMargins :: Mod Style -> Int
+horizontalMargins m = let Sides _ r _ l = getMargins m in l + r
+
+-- | Rows of margins: top plus bottom.
+verticalMargins :: Mod Style -> Int
+verticalMargins m = let Sides t _ b _ = getMargins m in t + b
+
+-- | Columns taken by the left and right sides of the border, where they
+-- are drawn.
+horizontalBorderSize :: Mod Style -> Int
+horizontalBorderSize m = let (l, r) = borderColumns (field styleBorder m) in l + r
+
+-- | Rows taken by the top and bottom sides of the border, where they are
+-- drawn.
+verticalBorderSize :: Mod Style -> Int
+verticalBorderSize m = let Sides t _ b _ = getBorderSides m in fromEnum t + fromEnum b
+
+-- | Columns taken by padding, border and margins: what is left for content
+-- is the available width minus this.
+horizontalFrameSize :: Mod Style -> Int
+horizontalFrameSize m = horizontalPadding m + horizontalBorderSize m + horizontalMargins m
+
+-- | Rows taken by padding, border and margins.
+verticalFrameSize :: Mod Style -> Int
+verticalFrameSize m = verticalPadding m + verticalBorderSize m + verticalMargins m
+
+-- | @(horizontalFrameSize, verticalFrameSize)@
+frameSize :: Mod Style -> (Int, Int)
+frameSize m = (horizontalFrameSize m, verticalFrameSize m)
diff --git a/src/Lipstick/Table.hs b/src/Lipstick/Table.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Table.hs
@@ -0,0 +1,394 @@
+-- | Tables: a header row and body rows of blocks, with borders and rules
+-- between them.
+--
+-- == Examples
+--
+-- The examples print with 'Lipstick.Terminal.putBlock'; the output is
+-- shown without colours and other attributes.
+--
+-- >>> let header = ["Language", "Formal", "Informal"]
+-- >>> let rows = [["Chinese", "您好", "你好"], ["Japanese", "こんにちは", "やあ"], ["Russian", "Здравствуйте", "Привет"]]
+-- >>> putBlock (table mempty header rows)
+-- ╭────────┬────────────┬────────╮
+-- │Language│Formal │Informal│
+-- ├────────┼────────────┼────────┤
+-- │Chinese │您好 │你好 │
+-- │Japanese│こんにちは │やあ │
+-- │Russian │Здравствуйте│Привет │
+-- ╰────────┴────────────┴────────╯
+--
+-- Styled cells, by position:
+--
+-- >>> let padded = cellStyle (const (padding 0 1))
+-- >>> let striped = cellStyle (\c -> if maybe False odd (cellRow c) then faint else mempty)
+-- >>> putBlock (table (padded <> striped <> headerStyle (bold <> align center)) header rows)
+-- ╭──────────┬──────────────┬──────────╮
+-- │ Language │ Formal │ Informal │
+-- ├──────────┼──────────────┼──────────┤
+-- │ Chinese │ 您好 │ 你好 │
+-- │ Japanese │ こんにちは │ やあ │
+-- │ Russian │ Здравствуйте │ Привет │
+-- ╰──────────┴──────────────┴──────────╯
+--
+-- Choosing the lines:
+--
+-- >>> putBlock (table (columnRules False <> rowRules True) header rows)
+-- ╭────────────────────────────╮
+-- │LanguageFormal Informal│
+-- ├────────────────────────────┤
+-- │Chinese 您好 你好 │
+-- ├────────────────────────────┤
+-- │Japaneseこんにちは やあ │
+-- ├────────────────────────────┤
+-- │Russian ЗдравствуйтеПривет │
+-- ╰────────────────────────────╯
+-- >>> putBlock (table (border markdownBorder <> borderTop False <> borderBottom False) header rows)
+-- |Language|Formal |Informal|
+-- |--------|------------|--------|
+-- |Chinese |您好 |你好 |
+-- |Japanese|こんにちは |やあ |
+-- |Russian |Здравствуйте|Привет |
+--
+-- Laid out in less width than it needs, a table shrinks its widest
+-- columns: body cells wrap, and header cells are cut short:
+--
+-- >>> putBlock (fromGrid (layout (Just 28) (table mempty header rows)))
+-- ╭────────┬──────────┬──────╮
+-- │Language│Formal │Infor…│
+-- ├────────┼──────────┼──────┤
+-- │Chinese │您好 │你好 │
+-- │Japanese│こんにちは│やあ │
+-- │Russian │Здравствуй│Привет│
+-- │ │те │ │
+-- ╰────────┴──────────┴──────╯
+--
+-- With a 'maxHeight', rows that do not fit are replaced by a row of
+-- ellipses, and 'yOffset' scrolls:
+--
+-- >>> let numbers = [[text (T.pack (show n)), text (T.pack (show (n * n)))] | n <- [1 .. 20 :: Int]]
+-- >>> putBlock (table (maxHeight 8 <> yOffset 5) ["n", "n²"] numbers)
+-- ╭──┬───╮
+-- │n │n² │
+-- ├──┼───┤
+-- │6 │36 │
+-- │7 │49 │
+-- │8 │64 │
+-- │… │… │
+-- ╰──┴───╯
+-- >>> visibleRows Nothing (maxHeight 8 <> yOffset 5) ["n", "n²"] numbers
+-- Just (5,7)
+--
+-- Cells are blocks, so they can hold anything:
+--
+-- >>> putBlock (table mempty ["Tool", "Platforms"] [["GHC", list mempty ["Linux", "macOS", "Windows"]]])
+-- ╭────┬─────────╮
+-- │Tool│Platforms│
+-- ├────┼─────────┤
+-- │GHC │• Linux │
+-- │ │• macOS │
+-- │ │• Windows│
+-- ╰────┴─────────╯
+module Lipstick.Table
+ ( Table
+ , table
+ , TableCell (..)
+ , cellRow
+ , cellColumn
+ , cellStyle
+ , headerStyle
+ , headerRule
+ , columnRules
+ , rowRules
+ , yOffset
+ , fitContent
+ , visibleRows
+ ) where
+
+import Data.Array (Array, listArray, (!))
+import Data.List (intercalate, transpose)
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text qualified as T
+import Lipstick.Border
+import Lipstick.Internal.Grid
+import Lipstick.Internal.Layout (Assign (..), Block (..), Measured (..), Request (..), TextStyle (..), allocate, cropLayoutWidth, defTextStyle, measureIn, takenWidth, textBlock)
+import Lipstick.Internal.Types (Attrs (..))
+import Lipstick.Internal.Mod
+import Lipstick.Style (Style, frame)
+import Lipstick.Width (textWidth)
+
+-- $setup
+-- >>> import Lipstick
+-- >>> import Data.Text qualified as T
+
+-- | Where a cell is. Rows and columns count from 0.
+data TableCell
+ = -- | A header cell, by column.
+ HeaderCell !Int
+ | -- | A body cell, by row and column.
+ BodyCell !Int !Int
+ deriving (Eq, Show)
+
+-- | The body row of a cell, or 'Nothing' for the header.
+cellRow :: TableCell -> Maybe Int
+cellRow = \case
+ HeaderCell _ -> Nothing
+ BodyCell r _ -> Just r
+
+-- | The column of a cell, counting from 0.
+cellColumn :: TableCell -> Int
+cellColumn = \case
+ HeaderCell c -> c
+ BodyCell _ c -> c
+
+-- | The settings of a 'table': its border (rounded by default), the rules
+-- under the header and between columns and rows, its size, wrapping and
+-- cell styles. Change them with the @t'Mod' t'Table'@ passed to 'table'.
+--
+-- Without a 'width', columns are as wide as their cells need, and shrink
+-- (wrapping their text) when the table is laid out in less space: widest
+-- first, but not below their longest word while another column can still
+-- wrap; with 'fillWidth', they grow to fill it. 'width' is the total width
+-- of the table: columns shrink or grow to fit it.
+--
+-- 'height' is the least number of lines the table takes: lines of empty
+-- cells are added below the body to reach it. 'maxHeight' is the most:
+-- body rows that do not fit are left out, with a row of ellipses in their
+-- place where there is room for it, and 'yOffset' sets the first row
+-- shown.
+--
+-- With 'noWrap', set on the table or on a style around it, body cells
+-- that are too wide are cut with an ellipsis; 'unsetNoWrap' makes them
+-- wrap again. Header cells are always cut, never wrapped.
+data Table = Table
+ { tableBorder :: !BorderProps
+ , tableSize :: !Size
+ , tableWrap :: !Bool
+ , tableHeaderRule :: !Bool
+ , tableColumnRules :: !Bool
+ , tableRowRules :: !Bool
+ , tableCellStyle :: TableCell -> Mod Style
+ , tableYOffset :: !Int
+ , tableFitContent :: !Bool
+ }
+
+instance HasBorder Table where
+ overBorder f t = t {tableBorder = f (tableBorder t)}
+
+instance HasSize Table where
+ overSize f t = t {tableSize = f (tableSize t)}
+
+instance HasWrap Table where
+ overWrap f t = t {tableWrap = f (tableWrap t)}
+
+instance HasCrop Table
+
+defTable :: Table
+defTable =
+ Table
+ { tableBorder = defBorderProps {borderChars = Just roundedBorder}
+ , tableSize = defSize
+ , tableWrap = True
+ , tableHeaderRule = True
+ , tableColumnRules = True
+ , tableRowRules = False
+ , tableCellStyle = const mempty
+ , tableYOffset = 0
+ , tableFitContent = False
+ }
+
+-- | Style cells by position. Successive 'cellStyle's add up: later ones
+-- win where they set the same thing.
+cellStyle :: (TableCell -> Mod Style) -> Mod Table
+cellStyle f = fieldMod (\t -> t {tableCellStyle = \c -> tableCellStyle t c <> f c})
+
+-- | Style the header cells.
+headerStyle :: Mod Style -> Mod Table
+headerStyle m = cellStyle $ \case
+ HeaderCell _ -> m
+ BodyCell _ _ -> mempty
+
+-- | The rule under the header (default on).
+headerRule :: Bool -> Mod Table
+headerRule v = fieldMod (\t -> t {tableHeaderRule = v})
+
+-- | Rules between columns (default on).
+columnRules :: Bool -> Mod Table
+columnRules v = fieldMod (\t -> t {tableColumnRules = v})
+
+-- | Rules between body rows (default off).
+rowRules :: Bool -> Mod Table
+rowRules v = fieldMod (\t -> t {tableRowRules = v})
+
+-- | The first body row shown when the table has a 'maxHeight' (default
+-- 0). When the rows from there on do not fill the height, earlier rows are
+-- shown too.
+yOffset :: Int -> Mod Table
+yOffset n = fieldMod (\t -> t {tableYOffset = max 0 n})
+
+-- | Treat 'width' as a maximum: the table is as wide as its content needs,
+-- unless that is wider than 'width'.
+fitContent :: Mod Table
+fitContent = fieldMod (\t -> t {tableFitContent = True})
+
+-- | A table with a header row (none if empty) and body rows. Short rows
+-- are padded with empty cells. Its columns fit the width the table is
+-- laid out in (see t'Table').
+table :: Mod Table -> [Block] -> [[Block]] -> Block
+table m headers rows = Block $ \ctx ->
+ let (req, run) = tableLayout ctx m headers rows
+ in Measured req (\(Assign w h) -> let (stretchTo, n, _) = run w in (stretchTo h, n))
+
+-- | The first and last body rows a table shows, laid out in an available
+-- width ('Nothing' for its natural width), as for 'Lipstick.Block.layout';
+-- 'Nothing' when it shows none. All rows unless the table has a
+-- 'maxHeight'. As with 'Lipstick.Block.layout', the table is laid out on
+-- its own: inside a style that sets 'Lipstick.Mod.noWrap' or another text
+-- setting that changes its rows' heights, the rows drawn can differ.
+visibleRows :: Maybe Int -> Mod Table -> [Block] -> [[Block]] -> Maybe (Int, Int)
+visibleRows avail m headers rows = shown
+ where
+ (_, _, shown) = run (maybe (reqMax req) (takenWidth req) avail)
+ (req, run) = tableLayout defTextStyle m headers rows
+
+-- | What a table asks for, and how it lays out at a width: stretched to a
+-- height, its natural height, and the body rows it shows.
+tableLayout :: TextStyle -> Mod Table -> [Block] -> [[Block]] -> (Request, Int -> (Int -> Grid, Int, Maybe (Int, Int)))
+tableLayout ctx m headers rows
+ | ncols == 0 = (Request 0 0 0 Nothing False False, \w -> (const (Grid w 0 []), 0, Nothing))
+ | otherwise = (req, run)
+ where
+ -- A table starts from the wrapping it inherits, as a style does.
+ (t, props) = runMod m defTable {tableWrap = textWrap ctx}
+ (chars, edges) = borderEdges (tableBorder t)
+ bp = tableBorder t
+ sideAttrs side = mempty {attrFg = side (borderFgColors bp), attrBg = side (borderBgColors bp)}
+ -- Outer edges take their side's colours; inner rules take the top's.
+ ba = sideAttrs sideTop
+ Size wSet hMin weight stretch = tableSize t
+ -- At most this many lines: body rows that do not fit are left out.
+ hgt = propMaxHeight props
+
+ ncols = maximum (0 : length headers : map length rows)
+ padRow r = take ncols (r ++ repeat (textBlock mempty))
+ headerRow = [(HeaderCell, padRow headers) | not (null headers)]
+ bodyRows = [(BodyCell i, padRow r) | (i, r) <- zip [0 ..] rows]
+
+ -- Cells stretch to the height of their row. Header cells, and body
+ -- cells with noWrap (the table's or one it inherits), are cut with an
+ -- ellipsis instead of wrapped.
+ truncates pos = case pos of
+ HeaderCell _ -> True
+ BodyCell _ _ -> not (tableWrap t)
+ -- A cell that wraps does so even under an inherited noWrap, unless its
+ -- cell style says otherwise.
+ wrapping pos = if truncates pos then mempty else unsetNoWrap
+ cellNodes (mk, r) =
+ [ measureIn ctx (frame (wrapping pos <> tableCellStyle t pos <> stretchHeight <> if truncates pos then noWrap else mempty) b)
+ | (c, b) <- zip [0 ..] r
+ , let pos = mk c
+ ]
+ -- Each cell's node is made once, for measuring and for layout.
+ headerNodes = map cellNodes headerRow
+ bodyNodes = map cellNodes bodyRows
+
+ -- Column widths: the natural width, and the narrowest that breaks no
+ -- word (cells that are cut short can shrink to one column).
+ columns = transpose [[(mk c, blockRequest n) | (c, n) <- zip [0 ..] ns] | ((mk, _), ns) <- zip (headerRow ++ bodyRows) (headerNodes ++ bodyNodes)]
+ natural = [maximum (0 : [reqMax r | (_, r) <- col]) | col <- columns]
+ narrowest = [maximum (0 : [if truncates pos then min 1 (reqMax r) else reqMin r | (pos, r) <- col]) | col <- columns]
+ sideW f e = if f edges then max 1 (textWidth e) else 0
+ ruleW = if tableColumnRules t then max 1 (textWidth (leftEdge chars)) else 0
+ frameW = sideW edgeLeft (leftEdge chars) + sideW edgeRight (rightEdge chars) + ruleW * (ncols - 1)
+ smallest = sum narrowest + frameW
+ full = sum natural + frameW
+ capW x = maybe x (min x . max 0) (propMaxWidth props)
+ -- The narrowest and natural widths, before a maxWidth crop.
+ (lo, hi) = case wSet of
+ Just n
+ | tableFitContent t -> (min n smallest, min n full)
+ | otherwise -> (n, n)
+ Nothing -> (smallest, full)
+ req = Request (capW lo) (capW hi) weight (max 0 <$> propMaxWidth props) stretch False
+ -- Columns grow to a set width (unless they fit their content) or when
+ -- the table grows.
+ columnWeight = if tableFitContent t || (not (isJust wSet) && weight == 0) then 0 else 1
+
+ run w = (gridTo, gridHeight (gridTo 0), shownRange)
+ where
+ gridTo h = fitWidth w (withProps props (blended (allLines h)))
+ blended = blendBorder (borderFgStops bp) (borderFgOffset bp) edges (length (concat leftV)) (length (concat rightV))
+ tableW = cropLayoutWidth (propMaxWidth props) weight hi w
+ widths = allocate (tableW - frameW) [(colLo, colHi, columnWeight) | (colLo, colHi) <- zip narrowest natural]
+
+ -- A row's cells at their column widths, stretched to the tallest:
+ -- one layout per cell. Its natural height is the number of lines.
+ renderRow ns =
+ let results = [blockLayout n (Assign cw rowH) | (n, cw) <- zip ns widths]
+ rowH = maximum (1 : map snd results)
+ in map line (transpose [gridCells g | (g, _) <- results])
+
+ piece a txt n = fillCells a txt n
+ leftV = [piece (sideAttrs sideLeft) (leftEdge chars) (sideW edgeLeft (leftEdge chars)) | edgeLeft edges]
+ rightV = [piece (sideAttrs sideRight) (rightEdge chars) (sideW edgeRight (rightEdge chars)) | edgeRight edges]
+ colRule = [piece ba (leftEdge chars) ruleW | tableColumnRules t]
+ line cellsOf = concat (leftV ++ [intercalate (concat colRule) cellsOf] ++ rightV)
+ rule a l mid r edge =
+ concat
+ ( [piece a l (sideW edgeLeft (leftEdge chars)) | edgeLeft edges]
+ ++ [intercalate (concat [piece a mid ruleW | tableColumnRules t]) [piece a edge cw | cw <- widths]]
+ ++ [piece a r (sideW edgeRight (rightEdge chars)) | edgeRight edges]
+ )
+
+ headerLines = concatMap renderRow headerNodes
+ nBody = length rows
+ bodyLines = map renderRow bodyNodes
+ overflowRow i = renderRow (cellNodes (BodyCell i, replicate ncols (textBlock (plain (T.singleton '…')))))
+
+ middleRule = rule ba (middleLeft chars) (middle chars) (middleRight chars) (topEdge chars)
+ topLines = [rule ba (topLeftCorner chars) (middleTop chars) (topRightCorner chars) (topEdge chars) | edgeTop edges]
+ headerRuleLines = [middleRule | tableHeaderRule t, not (null headerLines), nBody > 0]
+ bottomLines = [rule (sideAttrs sideBottom) (bottomLeftCorner chars) (middleBottom chars) (bottomRightCorner chars) (bottomEdge chars) | edgeBottom edges]
+
+ -- Which body rows to show.
+ rr = if tableRowRules t then 1 else 0
+ -- Lines taken by rows before each row, and by the overflow row in
+ -- place of each row (made when first needed, then kept).
+ before = listArray (0, nBody) (scanl (+) 0 (map length bodyLines)) :: Array Int Int
+ overflowH = listArray (0, nBody) [length (overflowRow i) | i <- [0 .. nBody]] :: Array Int Int
+ -- Lines taken by rows f..l, plus an overflow row if rows remain.
+ linesFor f l =
+ before ! (l + 1) - before ! f
+ + rr * max 0 (l - f)
+ + (if l < nBody - 1 then (if l >= f then rr else 0) + overflowH ! (l + 1) else 0)
+ -- Lines left for the body under a maxHeight.
+ avail = fmap (\h -> h - length topLines - length headerLines - length headerRuleLines - length bottomLines) hgt
+ (firstV, lastV) = case avail of
+ Nothing -> (0, nBody - 1)
+ Just a ->
+ let f0 = max 0 (min (nBody - 1) (tableYOffset t))
+ l0
+ -- All the rows from f0 fit: no overflow row is needed.
+ | linesFor f0 (nBody - 1) <= a = nBody - 1
+ | otherwise = last (f0 - 1 : takeWhile (\l -> linesFor f0 l <= a) [f0 .. nBody - 1])
+ f1 =
+ if l0 == nBody - 1
+ then last (f0 : takeWhile (\f -> linesFor f l0 <= a) [f0 - 1, f0 - 2 .. 0])
+ else f0
+ in (f1, l0)
+ shownRange = if lastV >= firstV then Just (firstV, lastV) else Nothing
+ shown = take (lastV - firstV + 1) (drop firstV bodyLines)
+ -- The overflow row, if there is room for it: when there is not even
+ -- room for that, the rows are left out without it rather than
+ -- cutting off the bottom border.
+ overflow = [overflowRow (lastV + 1) | lastV < nBody - 1, maybe True (linesFor firstV lastV <=) avail]
+ body = intercalate [middleRule | tableRowRules t] shown ++ concat [[middleRule | tableRowRules t, not (null shown)] ++ o | o <- overflow]
+ -- No header rule above an empty body, as in a table without rows.
+ headerRuleShown = if null body then [] else headerRuleLines
+ -- Up to the minimum height, or the height to stretch to, lines of
+ -- empty cells after the body; never past maxHeight, so that the
+ -- bottom border stays.
+ drawn = length topLines + length headerLines + length headerRuleShown + length body + length bottomLines
+ emptyLine = take 1 (renderRow (cellNodes (BodyCell nBody, replicate ncols (textBlock mempty))))
+ tallest h = maybe id min hgt (max (fromMaybe 0 hMin) (if stretch then h else 0))
+ filler h = concat (replicate (tallest h - drawn) emptyLine)
+ allLines h = topLines ++ headerLines ++ headerRuleShown ++ body ++ filler h ++ bottomLines
diff --git a/src/Lipstick/Terminal.hs b/src/Lipstick/Terminal.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Terminal.hs
@@ -0,0 +1,232 @@
+-- | Detecting what the terminal supports, and printing blocks.
+--
+-- Printing detects the colour profile and the width on every call, which
+-- is cheap: blocks are laid out in @COLUMNS@ if it is set, even when the
+-- output is not a terminal, or else in the terminal's width, and otherwise
+-- at their natural width. The background is taken from @COLORFGBG@ when
+-- the terminal sets it, and is otherwise assumed dark. To ask the
+-- terminal itself, which is slower and reads from stdin, detect the
+-- environment once with 'detectEnvQuery' and print with 'hPutBlockWith'.
+--
+-- The output is always UTF-8, whatever the handle's encoding: terminals
+-- expect it, and a locale such as @C@ (common in containers and cron jobs)
+-- would otherwise make the handle reject box-drawing characters.
+--
+-- == Examples
+--
+-- A program printing a block:
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > import Lipstick
+-- >
+-- > main :: IO ()
+-- > main = putBlock (render (border roundedBorder <> padding 0 1) "Hello, kitty")
+--
+-- Asking the terminal for its background once, and printing several
+-- blocks for that environment:
+--
+-- > {-# LANGUAGE OverloadedStrings #-}
+-- > import Lipstick
+-- > import System.IO (stdout)
+-- >
+-- > main :: IO ()
+-- > main = do
+-- > env <- detectEnvQuery stdout
+-- > hPutBlockWith env stdout (render (fg (lightDark "#5A3FC0" "#B39DFF")) "Hello")
+-- > hPutBlockWith env stdout (render (fg (lightDark "#C02060" "#F25D94")) "kitty")
+--
+-- Printing for an environment given explicitly, here no escape sequences
+-- and 20 columns:
+--
+-- >>> import System.IO (stdout)
+-- >>> hPutBlockWith defaultRenderEnv {envProfile = NoTTY, envWidth = Just 20} stdout (render (border normalBorder) "A block laid out in twenty columns")
+-- ┌──────────────────┐
+-- │A block laid out │
+-- │in twenty columns │
+-- └──────────────────┘
+--
+-- The rules detection follows, given whether the handle is a terminal and
+-- the environment variables:
+--
+-- >>> profileFromEnv True [("TERM", "xterm-256color")]
+-- ANSI256
+-- >>> profileFromEnv True [("TERM", "xterm-256color"), ("COLORTERM", "truecolor")]
+-- TrueColor
+-- >>> profileFromEnv True [("TERM", "xterm-256color"), ("NO_COLOR", "1")]
+-- Ascii
+-- >>> profileFromEnv False [("TERM", "xterm-256color")]
+-- NoTTY
+-- >>> profileFromEnv False [("TERM", "xterm-256color"), ("CLICOLOR_FORCE", "1")]
+-- ANSI256
+-- >>> backgroundFromEnv [("COLORFGBG", "15;0")]
+-- Just True
+-- >>> backgroundFromEnv [("COLORFGBG", "0;15")]
+-- Just False
+-- >>> widthFromEnv [("COLUMNS", "100")]
+-- Just 100
+module Lipstick.Terminal
+ ( putBlock
+ , hPutBlock
+ , hPutBlockWith
+ , detectEnv
+ , detectEnvQuery
+ , detectProfile
+ , detectWidth
+ , widthFromEnv
+ , profileFromEnv
+ , backgroundFromEnv
+ , queryDarkBackground
+ ) where
+
+import Control.Exception (SomeException, try)
+import Data.Char (isDigit)
+import Data.Colour.SRGB (RGB (..))
+import Data.List (isInfixOf, isPrefixOf)
+import Data.Maybe (fromMaybe)
+import Data.Text.IO.Utf8 qualified as Utf8
+import Lipstick.Ansi
+import Lipstick.Color (ColorProfile (..))
+import Lipstick.Internal.Layout (Block)
+import System.Console.ANSI (ConsoleLayer (Background), hGetLayerColor, hNowSupportsANSI)
+import System.Console.Terminal.Size (Window (..), hSize)
+import System.Environment (getEnvironment)
+import System.IO (Handle, hIsTerminalDevice, stdin, stdout)
+import System.Info (os)
+
+-- $setup
+-- >>> import Lipstick
+-- >>> import Lipstick.Terminal
+
+-- | Print a block to standard output, followed by a newline.
+putBlock :: Block -> IO ()
+putBlock = hPutBlock stdout
+
+-- | Print a block to a handle, followed by a newline, laid out in the
+-- handle's width and with colours reduced to its profile (see
+-- 'detectEnv').
+hPutBlock :: Handle -> Block -> IO ()
+hPutBlock h b = do
+ env <- detectEnv h
+ hPutBlockWith env h b
+
+-- | Print a block to a handle, followed by a newline, for a known
+-- environment. Lines are written one at a time, so the whole output is
+-- never held as one text.
+hPutBlockWith :: RenderEnv -> Handle -> Block -> IO ()
+hPutBlockWith env h b = case toAnsiLines env b of
+ [] -> Utf8.hPutStrLn h mempty
+ ls -> mapM_ (Utf8.hPutStrLn h) ls
+
+-- | The colour profile and width of a handle, and whether the background
+-- is dark according to @COLORFGBG@ (dark if it is not set). Does not talk
+-- to the terminal.
+detectEnv :: Handle -> IO RenderEnv
+detectEnv h = do
+ profile <- detectProfile h
+ vars <- getEnvironment
+ w <- detectWidth h
+ pure defaultRenderEnv {envProfile = profile, envDarkBackground = fromMaybe True (backgroundFromEnv vars), envWidth = w}
+
+-- | The width to lay blocks out in for a handle: @COLUMNS@ if it is set to
+-- a positive number, otherwise the width of the terminal behind the handle
+-- (asked of the operating system, without escape sequences), and
+-- 'Nothing' when the handle is not a terminal.
+detectWidth :: Handle -> IO (Maybe Int)
+detectWidth h = do
+ vars <- getEnvironment
+ case widthFromEnv vars of
+ Just w -> pure (Just w)
+ Nothing -> do
+ size <- try (hSize h)
+ pure $ case size of
+ Right (Just win) | width win > 0 -> Just (width win)
+ Right _ -> Nothing
+ Left (_ :: SomeException) -> Nothing
+
+-- | The width set by @COLUMNS@, if it is a positive number.
+widthFromEnv :: [(String, String)] -> Maybe Int
+widthFromEnv vars = do
+ v <- lookup "COLUMNS" vars
+ if not (null v) && all isDigit v && length v <= 6 && read v > (0 :: Int)
+ then Just (read v)
+ else Nothing
+
+-- | Like 'detectEnv', but asks the terminal for its background colour (see
+-- 'queryDarkBackground'), falling back to @COLORFGBG@ when there is no
+-- answer. It can take half a second, so call it once and keep the result.
+detectEnvQuery :: Handle -> IO RenderEnv
+detectEnvQuery h = do
+ env <- detectEnv h
+ answer <- queryDarkBackground h
+ pure (maybe env (\dark -> env {envDarkBackground = dark}) answer)
+
+-- | The colour profile of a handle. On Windows this also switches on ANSI
+-- processing in the console, if needed.
+--
+-- @NO_COLOR@ removes colours; @CLICOLOR_FORCE@, set to anything but @0@,
+-- keeps them even when the handle is not a terminal.
+detectProfile :: Handle -> IO ColorProfile
+detectProfile h = do
+ supported <- hNowSupportsANSI h
+ vars <- getEnvironment
+ pure (profileFromEnv supported vars)
+
+-- | The rules behind 'detectProfile': whether the handle is an ANSI
+-- terminal and the environment variables.
+profileFromEnv :: Bool -> [(String, String)] -> ColorProfile
+profileFromEnv supported vars
+ | not supported && not forced = NoTTY
+ | set "NO_COLOR" = Ascii
+ -- GNU Screen, where COLORTERM comes from the terminal outside it, does
+ -- not show true colour.
+ | colorterm `elem` ["truecolor", "24bit"] && not ("screen" `isPrefixOf` term) = TrueColor
+ | set "WT_SESSION" = TrueColor
+ | any (`isInfixOf` term) ["truecolor", "24bit", "direct"] = TrueColor
+ | any (`isPrefixOf` term) trueColorTerms = TrueColor
+ | "256color" `isInfixOf` term || any (`isPrefixOf` term) ["screen", "tmux"] = ANSI256
+ | null term && os == "mingw32" = TrueColor
+ | otherwise = ANSI16
+ where
+ get k = fromMaybe "" (lookup k vars)
+ set k = not (null (get k))
+ forced = set "CLICOLOR_FORCE" && get "CLICOLOR_FORCE" /= "0"
+ term = get "TERM"
+ colorterm = get "COLORTERM"
+ trueColorTerms = ["alacritty", "contour", "foot", "kitty", "rio", "wezterm", "xterm-ghostty", "xterm-kitty"]
+
+-- | Whether the background is dark according to @COLORFGBG@, which some
+-- terminals (rxvt, Konsole, …) set to @"fg;bg"@ palette indices; 'Nothing'
+-- when it is not set or the background is not a number.
+backgroundFromEnv :: [(String, String)] -> Maybe Bool
+backgroundFromEnv vars = do
+ v <- lookup "COLORFGBG" vars
+ let bgField = reverse (takeWhile (/= ';') (reverse v))
+ if not (null bgField) && all isDigit bgField
+ then let n = read bgField :: Int in Just (n <= 6 || n == 8)
+ else Nothing
+
+-- | Whether the background of the terminal behind a handle is dark, by
+-- asking the terminal for its colour. The reply is read from stdin.
+--
+-- 'Nothing' when stdin or the handle is not a terminal, when the terminal
+-- does not answer within half a second, and on Windows, where the query
+-- does not work in Windows Terminal.
+queryDarkBackground :: Handle -> IO (Maybe Bool)
+queryDarkBackground h
+ | os == "mingw32" = pure Nothing
+ | otherwise = do
+ ttys <- (&&) <$> hIsTerminalDevice stdin <*> hIsTerminalDevice h
+ if not ttys
+ then pure Nothing
+ else do
+ answer <- try (hGetLayerColor h Background)
+ pure $ case answer of
+ Right (Just c) -> Just (isDark c)
+ Right Nothing -> Nothing
+ Left (_ :: SomeException) -> Nothing
+ where
+ isDark (RGB r g b) =
+ let hi = maximum [r, g, b]
+ lo = minimum [r, g, b]
+ lightness = (fromIntegral hi + fromIntegral lo) / (2 * 65535) :: Double
+ in lightness < 0.5
diff --git a/src/Lipstick/Width.hs b/src/Lipstick/Width.hs
new file mode 100644
--- /dev/null
+++ b/src/Lipstick/Width.hs
@@ -0,0 +1,48 @@
+-- | Display width of text in a terminal.
+--
+-- Text is split into extended grapheme clusters following UAX #29 (rules
+-- GB3–GB13, including GB9c for Indic conjuncts). A cluster is as wide as
+-- its first character with a non-zero width: two columns for East Asian
+-- Wide and Fullwidth characters, none for controls, combining marks and
+-- Hangul vowels and final consonants, one otherwise. An emoji followed by
+-- VS16 or a skin tone modifier is two columns wide, as is a skin tone
+-- modifier on its own; VS15 does not change the width. A pair of regional
+-- indicators (a flag) is two.
+--
+-- 'textWidth' adds up the widths of all the clusters, and newlines and
+-- tabs are controls, so they take no columns: the width of @"ab\\ncd"@ is
+-- 4, not the width of its widest line, and a tab is 0 here although a
+-- block shows it as spaces (see 'Lipstick.Style.tabWidth').
+--
+-- The tables are generated from the Unicode Character Database by
+-- @scripts/GenUnicodeTable.hs@; see 'unicodeVersion'.
+--
+-- == Examples
+--
+-- >>> textWidth "hello"
+-- 5
+-- >>> textWidth "こんにちは"
+-- 10
+-- >>> textWidth "🇦🇺"
+-- 2
+-- >>> textWidth "e\x301"
+-- 1
+-- >>> textWidth "ab\ncd"
+-- 4
+-- >>> map snd (clusters "a🇦🇺e\x301")
+-- [1,2,1]
+-- >>> (charWidth 'a', charWidth '你', charWidth '\x301')
+-- (1,2,0)
+-- >>> unicodeVersion
+-- "16.0.0"
+module Lipstick.Width
+ ( charWidth
+ , textWidth
+ , clusters
+ , unicodeVersion
+ ) where
+
+import Lipstick.Internal.Width
+
+-- $setup
+-- >>> import Lipstick.Width
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,1397 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Data.Char (chr)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO.Utf8 qualified as Utf8
+import Lipstick
+import Lipstick.Block qualified as B
+import Lipstick.Grid (Span (..), gridLines, lineSpans, lineWidth)
+import Lipstick.Grid qualified as G
+import Lipstick.Internal.Color (Color (..))
+import Lipstick.Internal.Layout (Assign (..), Measured (..), Request (..), allocate, allocateWithin, measure)
+import Lipstick.Mod qualified as M
+import Lipstick.Terminal (backgroundFromEnv, profileFromEnv, widthFromEnv)
+import Lipstick.Width (clusters)
+import Numeric (readHex)
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.Environment (lookupEnv, setEnv, unsetEnv)
+import System.IO (hClose, hSetEncoding, mkTextEncoding, openTempFile)
+import Test.QuickCheck
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck (testProperty)
+
+main :: IO ()
+main = do
+ graphemeCases <- readGraphemeTests "test/data/GraphemeBreakTest.txt"
+ defaultMain $
+ testGroup
+ "lipstick"
+ [ widthTests
+ , graphemeTests graphemeCases
+ , colorTests
+ , blendTests
+ , fromAnsiTests
+ , extrasTests
+ , tableTests
+ , outlineTests
+ , layerTests
+ , commonPropsTests
+ , styleParityTests
+ , textParityTests
+ , tableParityTests
+ , outlineParityTests
+ , renderTests
+ , layoutTests
+ , ansiTests
+ , profileTests
+ , allocateTests
+ , inheritanceTests
+ , deferredLayoutTests
+ , properties
+ ]
+
+plainLines :: Block -> [Text]
+plainLines = T.lines . renderPlain
+
+-- | An environment, field by field.
+renderEnv :: ColorProfile -> Bool -> Maybe Int -> RenderEnv
+renderEnv p dark w = defaultRenderEnv {envProfile = p, envDarkBackground = dark, envWidth = w}
+
+rectOf :: Rect -> (Int, Int, Int, Int)
+rectOf r = (rectX r, rectY r, rectWidth r, rectHeight r)
+
+-- | Blocks are equal when they lay out the same at their natural width.
+(@?~) :: Block -> Block -> Assertion
+a @?~ b = layout Nothing a @?= layout Nothing b
+
+infix 1 @?~
+
+-- | The plain lines of a block laid out in a width.
+plainLinesAt :: Int -> Block -> [Text]
+plainLinesAt w = T.lines . toAnsi (renderEnv NoTTY True (Just w))
+
+widthTests :: TestTree
+widthTests =
+ testGroup
+ "width"
+ [ testCase "ascii" $ textWidth "hello" @?= 5
+ , testCase "CJK is wide" $ textWidth "日本語" @?= 6
+ , testCase "combining marks are zero width" $ textWidth "e\x0301" @?= 1
+ , testCase "emoji" $ textWidth "🎨" @?= 2
+ , testCase "ZWJ sequence is one cluster" $ textWidth "👩\x200D💻" @?= 2
+ , testCase "flag is one cluster" $ textWidth "🇮🇹" @?= 2
+ , testCase "VS16 makes text emoji wide" $ textWidth "❤\xFE0F" @?= 2
+ , testCase "VS15 does not change the width" $ do
+ textWidth "⌚\xFE0E" @?= 2
+ textWidth "😀\xFE0E" @?= 2
+ textWidth "\x2764\xFE0E" @?= 1
+ -- lipgloss measures these by their first character; see the README.
+ , testCase "skin tone modifiers are wide and make an emoji wide" $ do
+ map textWidth ["\x261D\x1F3FB", "\x270C\x1F3FD", "👍\x1F3FB", "\x1F3FB", "\x1F3FB\x1F3FF"] @?= [2, 2, 2, 2, 2]
+ blockWidth (render (border normalBorder) "\x1F3FBx") @?= 5
+ , testCase "keycap" $ textWidth "1\xFE0F\x20E3" @?= 2
+ , testCase "skin tone modifier" $ textWidth "👍🏽" @?= 2
+ , testCase "family ZWJ sequence" $ textWidth "👨\x200D👩\x200D👧" @?= 2
+ , testCase "precomposed Hangul" $ textWidth "한국" @?= 4
+ , testCase "conjoining Hangul jamo" $ textWidth "\x1112\x1161\x11AB" @?= 2
+ , testCase "Devanagari conjunct is one cluster" $ length (clusters "क्ष") @?= 1
+ , testCase "zero width space" $ textWidth "a\x200B\&b" @?= 2
+ , testCase "ambiguous width is narrow" $ textWidth "±" @?= 1
+ , testCase "CJK extension B" $ textWidth "\x20000" @?= 2
+ , testCase "unicode version" $ unicodeVersion @?= "16.0.0"
+ , testCase "a cluster split across pieces is measured whole" $ do
+ blockWidth (fromInline ("\x2764" <> "\xFE0F" <> "x")) @?= 3
+ blockWidth (fromInline (styled bold "👨" <> "\x200D👩")) @?= 2
+ , testCase "a cluster split across pieces takes the first piece's style" $
+ toAnsi defaultRenderEnv (fromInline (styled bold "\x2764" <> "\xFE0F"))
+ @?= "\ESC[0;1m\x2764\xFE0F\ESC[0m"
+ , testCase "bidi embeddings, overrides and isolates are dropped" $
+ renderPlain (render (border normalBorder) "a\x202E\&b\x2067\&c\x2069\&d\x202C")
+ @?= "┌────┐\n│abcd│\n└────┘"
+ , testCase "bidi marks are kept" $
+ renderPlain (text "a\x200F\&b\x200E\&c\x061C\&d") @?= "a\x200F\&b\x200E\&c\x061C\&d"
+ , testCase "styleRanges counts a tab as four columns" $
+ toAnsi defaultRenderEnv (fromInline (styleRanges [(4, 5, bold)] "\tab"))
+ @?= " \ESC[0;1ma\ESC[0mb"
+ , testCase "styleIndices counts a split cluster once" $
+ toAnsi defaultRenderEnv (fromInline (styleIndices [1] bold mempty ("\x2764" <> "\xFE0F" <> "x")))
+ @?= "\x2764\xFE0F\ESC[0;1mx\ESC[0m"
+ ]
+
+-- | Test cases from the Unicode conformance file: the text and its
+-- expected clusters.
+readGraphemeTests :: FilePath -> IO [(Text, [Text])]
+readGraphemeTests path = do
+ contents <- Utf8.readFile path
+ pure
+ [ (T.concat cs, cs)
+ | l <- T.lines contents
+ , not (T.null l)
+ , not ("#" `T.isPrefixOf` l)
+ , let cs = map (T.pack . map hexChar . filter (/= "×") . T.words) (filter (not . T.null . T.strip) (T.splitOn "÷" l))
+ ]
+ where
+ hexChar w = case readHex (T.unpack w) of
+ [(n, "")] -> chr n
+ _ -> error ("bad code point " ++ show w)
+
+graphemeTests :: [(Text, [Text])] -> TestTree
+graphemeTests cases =
+ testGroup
+ "grapheme clusters (UAX #29 conformance)"
+ [ testCase "file has test cases" $ assertBool "no cases" (length cases > 1000)
+ , testCase "all cases" $ do
+ let failures = [(t, expected, map fst (clusters t)) | (t, expected) <- cases, map fst (clusters t) /= expected]
+ assertBool
+ (show (length failures) ++ " failures, first: " ++ show (take 3 failures))
+ (null failures)
+ ]
+
+colorTests :: TestTree
+colorTests =
+ testGroup
+ "colour"
+ [ testCase "hex literal" $ ("#ff8000" :: Color) @?= RGB 255 128 0
+ , testCase "short hex" $ hex "#f80" @?= Just (RGB 255 136 0)
+ , testCase "palette literal" $ ("201" :: Color) @?= Color256 201
+ , testCase "basic literal" $ ("5" :: Color) @?= Color16 5
+ , testCase "colours show as the functions that make them" $ do
+ show ("#7D56F4" :: Color) @?= "rgb 125 86 244"
+ show (lightDark red (ansi256 200)) @?= "lightDark (ansi 1) (ansi256 200)"
+ show (complete "#000" "16" "0") @?= "complete (rgb 0 0 0) (ansi256 16) (ansi 0)"
+ , testCase "invalid hex" $ hex "#ggg" @?= Nothing
+ , testCase "red to 256" $ resolveColor ANSI256 True "#ff0000" @?= Just (TC256 196)
+ , testCase "grey to 256" $ resolveColor ANSI256 True "#808080" @?= Just (TC256 244)
+ , testCase "black to 256" $ resolveColor ANSI256 True "#000000" @?= Just (TC256 16)
+ , testCase "red to 16" $ resolveColor ANSI16 True "#ff0000" @?= Just (TC16 9)
+ , testCase "no colour in ascii" $ resolveColor Ascii True "#ff0000" @?= Nothing
+ , testCase "light/dark" $ do
+ resolveColor TrueColor True (lightDark "1" "2") @?= Just (TC16 2)
+ resolveColor TrueColor False (lightDark "1" "2") @?= Just (TC16 1)
+ , testCase "complete" $
+ resolveColor ANSI256 True (complete "#ff0000" "100" "3") @?= Just (TC256 100)
+ ]
+
+blendTests :: TestTree
+blendTests =
+ testGroup
+ "colour manipulation"
+ [ testCase "mix keeps the variants of complete colours" $
+ mix 0.5 (complete (rgb 255 0 0) (ansi256 196) red) blue
+ @?= complete (mix 0.5 (rgb 255 0 0) blue) (mix 0.5 (ansi256 196) blue) (mix 0.5 red blue)
+ , testCase "mix keeps both kinds of adaptive colour" $
+ mix 0.25 (lightDark white black) (complete red green blue)
+ @?= lightDark
+ (complete (mix 0.25 white red) (mix 0.25 white green) (mix 0.25 white blue))
+ (complete (mix 0.25 black red) (mix 0.25 black green) (mix 0.25 black blue))
+ , testCase "blend endpoints" $
+ blend 3 ["#ff0000", "#0000ff"] @?= ["#ff0000", RGB 140 83 162, "#0000ff"]
+ , testCase "blend through three stops" $ do
+ let cs = blend 5 ["#000000", "#ffffff", "#000000"]
+ length cs @?= 5
+ cs !! 2 @?= "#ffffff"
+ last cs @?= "#000000"
+ , testCase "blend degenerate" $ do
+ blend 0 ["#ff0000", "#0000ff"] @?= []
+ blend 1 ["#ff0000", "#0000ff"] @?= ["#ff0000"]
+ blend 2 ["#123456"] @?= ["#123456", "#123456"]
+ , testCase "darken fully is black" $ darken 1 "#7D56F4" @?= "#000000"
+ , testCase "lighten fully is white" $ lighten 1 "#7D56F4" @?= "#ffffff"
+ , testCase "complementary of grey is grey" $ complementary "#808080" @?= "#808080"
+ , testCase "adaptive colours stay adaptive" $
+ darken 1 (lightDark "#ffffff" "#eeeeee") @?= lightDark "#000000" "#000000"
+ , testCase "mixing adaptive with plain" $
+ mix 0 (lightDark "#ff0000" "#00ff00") "#0000ff" @?= lightDark "#ff0000" "#00ff00"
+ , testCase "palette colours become RGB" $ mix 0 red red @?= RGB 205 0 0
+ , testProperty "OkLab round trip" $ \r g b ->
+ mix 0 (RGB r g b) (RGB r g b) === RGB r g b
+ ]
+
+fromAnsiTests :: TestTree
+fromAnsiTests =
+ testGroup
+ "fromAnsi"
+ [ testCase "plain text" $ parsed "hello" @?= "hello"
+ , testCase "SGR round trip" $
+ parsed "\ESC[1;31mred\ESC[0m plain" @?= "\ESC[0;1;31mred\ESC[0m plain"
+ , testCase "256 and RGB colours" $
+ parsed "\ESC[38;5;200;48;2;1;2;3mx" @?= "\ESC[0;38;5;200;48;2;1;2;3mx\ESC[0m"
+ , testCase "a colour cut short does not turn into attributes" $ do
+ parsed "\ESC[38;5mA" @?= "A"
+ parsed "\ESC[48;5mA" @?= "A"
+ parsed "\ESC[1;38;2;1;2mA" @?= "\ESC[0;1mA\ESC[0m"
+ parsed "\ESC[38:5mA" @?= "A"
+ , testCase "a colour out of range is ignored" $ do
+ parsed "\ESC[31;38;5;300;1mA" @?= "\ESC[0;1;31mA\ESC[0m"
+ parsed "\ESC[38;2;999;0;0mA" @?= "A"
+ parsed "\ESC[31;38:5:300mA" @?= "\ESC[0;31mA\ESC[0m"
+ parsed "\ESC[18446744073709551647mA" @?= "A"
+ , testCase "colon forms" $
+ parsed "\ESC[4:3;58:2::10:20:30;38:5:9mx" @?= "\ESC[0;4:3;91;58;2;10;20;30mx\ESC[0m"
+ , testCase "off codes unset" $
+ parsed "\ESC[1;3;31mA\ESC[22;39mB" @?= "\ESC[0;1;3;31mA\ESC[0;3mB\ESC[0m"
+ , testCase "empty SGR resets" $ parsed "\ESC[1mA\ESC[mB" @?= "\ESC[0;1mA\ESC[0mB"
+ , testCase "hyperlink with ST" $
+ parsed "\ESC]8;;http://a\ESC\\x\ESC]8;;\ESC\\y" @?= "\ESC]8;;http://a\ESC\\x\ESC]8;;\ESC\\y"
+ , testCase "hyperlink with BEL" $
+ parsed "\ESC]8;id=1;http://a\ax\ESC]8;;\a" @?= "\ESC]8;;http://a\ESC\\x\ESC]8;;\ESC\\"
+ , testCase "other sequences are dropped" $
+ parsed "\ESC[2K\ESC(Bab\ESC]0;title\acd\ESC7" @?= "abcd"
+ , testCase "private and intermediate CSI ending in m are not SGR" $ do
+ parsed "\ESC[1mA\ESC[>4;2mB" @?= "\ESC[0;1mAB\ESC[0m"
+ parsed "\ESC[1m\ESC[<5mx\ESC[?0my" @?= "\ESC[0;1mxy\ESC[0m"
+ parsed "\ESC[1m\ESC[0 mx" @?= "\ESC[0;1mx\ESC[0m"
+ , testCase "a newline cuts an escape sequence short and stays" $ do
+ plainLines (fromInline (fromAnsi "\ESC[31\nfoo")) @?= [" ", "foo"]
+ ansiHeight "a\ESC\nb" @?= 2
+ ansiHeight "a\ESC(\nb" @?= 2
+ , testCase "8-bit CSI" $ parsed "\x9B\&1mA" @?= "\ESC[0;1mA\ESC[0m"
+ , testCase "control string payloads are dropped" $
+ parsed "a\ESC_Gf=100;AAAA\ESC\\b\ESCPtmux;payload\ESC\\c\ESCXsos\ESC\\d\ESC^pm\ae" @?= "abcde"
+ , testCase "tmux passthrough is dropped" $ do
+ parsed "a\ESCPtmux;\ESC\ESC_Gf=100,a=T;iVBORw0KGgo=\ESC\ESC\\\ESC\\b" @?= "ab"
+ parsed "\ESCPtmux;\ESC\ESC]52;c;aGVsbG8=\a\ESC\\after" @?= "after"
+ , testCase "ESC ESC starts the sequence again" $
+ parsed "\ESC\ESC[31mx" @?= "\ESC[0;31mx\ESC[0m"
+ , testCase "8-bit control strings are dropped" $
+ parsed "a\x90q#0;2\x9C\&b\x9F\&apc\x9C\&c\x98sos\ESC\\d" @?= "abcd"
+ , testCase "an escape cuts a control string short" $
+ parsed "\ESC]0;title\ESC[1mA\ESCPdcs\ESC[3mB" @?= "\ESC[0;1mA\ESC[0;1;3mB\ESC[0m"
+ , testCase "hyperlink with a C1 control is escaped on output" $
+ parsed "\ESC]8;;http://a\x9B\&2J\ESC\\x" @?= "\ESC]8;;http://a%C2%9B2J\ESC\\x\ESC]8;;\ESC\\"
+ , testCase "keeps the outer style" $
+ toAnsi defaultRenderEnv (render (bg "4") (fromAnsi "\ESC[1ma\ESC[0mb"))
+ @?= "\ESC[0;1;44ma\ESC[0;44mb\ESC[0m"
+ , testCase "escapes inside a cluster do not split it" $
+ ansiWidth "\ESC[31m👩\ESC[0m\x200D💻" @?= 2
+ , testCase "width ignores escapes" $
+ blockWidth (render (border normalBorder) (fromAnsi "\ESC[31mred\ESC[0m")) @?= 5
+ , testProperty "toAnsi . fromAnsi . toAnsi = toAnsi" $ \spec (StyledText inl) ->
+ let b = render (specMod spec) inl
+ out = toAnsi defaultRenderEnv b
+ in toAnsi defaultRenderEnv (fromInline (fromAnsi out)) === out
+ ]
+ where
+ parsed = toAnsi defaultRenderEnv . fromInline . fromAnsi
+
+extrasTests :: TestTree
+extrasTests =
+ testGroup
+ "style extras"
+ [ testCase "inline ignores the box" $
+ plainLines (render (inline <> padding 1 1 <> border normalBorder <> width 20) "a\nb") @?= ["ab"]
+ , -- Quadratic versions took seconds (styleRanges) and minutes
+ -- (styleIndices) on this text.
+ localOption (mkTimeout 5000000) $ testCase "styleRanges and styleIndices take linear time" $ do
+ let long = T.replicate 40000 "word "
+ n = T.length long
+ size = T.length . renderPlain . fromInline
+ size (styleRanges [(0, n, bold)] (plain long)) @?= n
+ size (styleIndices [0, 2 .. n] bold mempty (plain long)) @?= n
+ , testCase "inline respects maxWidth" $
+ plainLines (render (inline <> maxWidth 3) "abcdef") @?= ["abc"]
+ , testCase "inline removes newlines in framed blocks, boxes kept" $
+ plainLines (frame inline (render (border asciiBorder) "a\nb")) @?= ["+--+", "|ab|", "+--+"]
+ , testCase "unsetInline keeps newlines inside an inline frame" $
+ plainLines (frame inline (render unsetInline "a\nb")) @?= ["a", "b"]
+ , testCase "inline keeps attributes" $
+ toAnsi defaultRenderEnv (render (inline <> bold) "a\nb") @?= "\ESC[0;1mab\ESC[0m"
+ , testCase "padding char" $
+ plainLines (render (padding 1 1 <> paddingChar '.') "x") @?= ["...", ".x.", "..."]
+ , testCase "margin char" $
+ plainLines (render (margin 0 2 <> marginChar '~') "x") @?= ["~~x~~"]
+ , testCase "border gradient" $ do
+ let b = render (border normalBorder <> borderFgBlend [red, blue]) "hi"
+ ls = T.lines (toAnsi defaultRenderEnv b)
+ renderPlain b @?= "┌──┐\n│hi│\n└──┘"
+ case ls of
+ [l1, l2, _] -> do
+ assertBool "top-left corner is the first stop" $
+ "\ESC[0;38;2;205;0;0m┌\ESC[" `T.isPrefixOf` l1
+ assertBool "left border of the middle row is the last stop" $
+ "\ESC[0;38;2;0;0;238m│" `T.isPrefixOf` l2
+ _ -> assertFailure (show ls)
+ , testCase "borderFg clears a gradient" $
+ render (border normalBorder <> borderFgBlend [red, blue] <> borderFg green) "x"
+ @?~ render (border normalBorder <> borderFg green) "x"
+ ]
+
+tableTests :: TestTree
+tableTests =
+ testGroup
+ "table"
+ [ testCase "defaults" $
+ plainLines (table mempty ["A", "Bb"] [["1", "2"], ["333"]])
+ @?= [ "╭───┬──╮"
+ , "│A │Bb│"
+ , "├───┼──┤"
+ , "│1 │2 │"
+ , "│333│ │"
+ , "╰───┴──╯"
+ ]
+ , testCase "row rules, no header rule, padded cells" $
+ plainLines (table (border normalBorder <> rowRules True <> headerRule False <> cellStyle (const (padding 0 1))) ["A"] [["1"], ["2"]])
+ @?= ["┌───┐", "│ A │", "│ 1 │", "├───┤", "│ 2 │", "└───┘"]
+ , testCase "no column rules" $
+ plainLines (table (border asciiBorder <> columnRules False) [] [["a", "b"]]) @?= ["+--+", "|ab|", "+--+"]
+ , testCase "markdown" $
+ plainLines (table (border markdownBorder <> borderTop False <> borderBottom False <> cellStyle (const (padding 0 1))) ["A", "B"] [["1", "2"]])
+ @?= ["| A | B |", "|---|---|", "| 1 | 2 |"]
+ , testCase "no outer border" $
+ plainLines (table (borderTop False <> borderBottom False <> borderLeft False <> borderRight False) ["A", "B"] [["1", "2"]])
+ @?= ["A│B", "─┼─", "1│2"]
+ , testCase "width grows columns" $
+ plainLines (table (width 9) ["A", "B"] [["1", "2"]])
+ @?= ["╭───┬───╮", "│A │B │", "├───┼───┤", "│1 │2 │", "╰───┴───╯"]
+ , testCase "width shrinks and wraps the widest column" $
+ plainLines (table (width 12) ["Id", "Text"] [["1", "one two three"]])
+ @?= ["╭──┬───────╮", "│Id│Text │", "├──┼───────┤", "│1 │one two│", "│ │three │", "╰──┴───────╯"]
+ , testCase "noWrap truncates" $
+ plainLines (table (width 12 <> noWrap) ["Id", "Text"] [["1", "one two three"]])
+ @?= ["╭──┬───────╮", "│Id│Text │", "├──┼───────┤", "│1 │one tw…│", "╰──┴───────╯"]
+ , testCase "header style" $
+ toAnsi defaultRenderEnv (table (border hiddenBorder <> borderTop False <> borderBottom False <> headerRule False <> columnRules False <> headerStyle bold) ["H"] [["b"]])
+ @?= " \ESC[0;1mH\ESC[0m \n b "
+ , testCase "cell positions" $ do
+ let b = table (cellStyle (\c -> if cellRow c == Just 1 && cellColumn c == 0 then fg red else mempty) <> border hiddenBorder) ["h"] [["a"], ["b"]]
+ assertBool "only the second body row is red" $
+ T.count "\ESC[0;31m" (toAnsi defaultRenderEnv b) == 1 && "\ESC[0;31mb" `T.isInfixOf` toAnsi defaultRenderEnv b
+ , testCase "border colour" $
+ T.isPrefixOf "\ESC[0;31m╭" (toAnsi defaultRenderEnv (table (borderFg red) [] [["x"]])) @? "border is red"
+ , testCase "empty table" $ blockHeight (table mempty [] []) @?= 0
+ , testCase "maxWidth crops" $ blockWidth (table (maxWidth 4) ["abcdef"] []) @?= 4
+ , testProperty "rectangular and respects width" $ \(Positive extra) (TableData hs rs) ->
+ let natural = table mempty (map fromInline hs) (map (map fromInline) rs)
+ target = blockWidth natural + extra - 3
+ b = table (width target) (map fromInline hs) (map (map fromInline) rs)
+ in blockWidth natural > 0 && target >= 2 * length (concat (hs : rs)) + 2 ==>
+ rectangular b .&&. blockWidth b === target
+ ]
+
+-- | Table contents: a header and ragged rows of short words.
+data TableData = TableData [Inline] [[Inline]]
+ deriving (Show)
+
+instance Arbitrary TableData where
+ arbitrary = do
+ let cell = elements ["a", "bb", "ccc dd", "日本", "", "longer words here"]
+ hs <- resize 4 (listOf cell)
+ rs <- resize 4 (listOf (resize 4 (listOf cell)))
+ pure (TableData hs rs)
+
+outlineTests :: TestTree
+outlineTests =
+ testGroup
+ "outline"
+ [ testCase "tree" $
+ plainLines (tree mempty (Node "." [Node "a" [], Node "b" [Node "c" [], Node "d" []], Node "e" []]))
+ @?= [". ", "├── a ", "├── b ", "│ ├── c", "│ └── d", "└── e "] `withWidth` 9
+ , testCase "multi-line items continue the branch" $
+ plainLines (tree mempty (Node "r" [Node "a\nb" [], Node "c" []]))
+ @?= ["r", "├── a", "│ b", "└── c"] `withWidth` 5
+ , testCase "rounded tree" $
+ plainLines (forest (enumerator roundedTreeEnumerator) [Node "a" [], Node "b" []]) @?= ["├── a", "╰── b"]
+ , testCase "bullet list" $ plainLines (list mempty ["a", "b"]) @?= ["• a", "• b"]
+ , testCase "numbers are right-aligned" $
+ take 2 (drop 8 (plainLines (list (enumerator arabic) (map (text . T.pack . show) [1 .. 10 :: Int]))))
+ @?= [" 9. 9 ", "10. 10"]
+ , testCase "alphabet" $
+ map (T.take 4) (plainLines (list (enumerator alphabet) (replicate 28 "x"))) !! 27 @?= "AB. "
+ , testCase "roman" $
+ map (T.takeWhile (/= '.')) (plainLines (list (enumerator roman) (replicate 14 "x"))) !! 13 @?= " XIV"
+ , testCase "nested list with an enumerator per depth" $
+ plainLines (nestedList (enumerator (byDepth (\d -> if d == 0 then arabic else dash))) [Node "a" [Node "b" []], Node "c" []])
+ @?= ["1. a ", " - b", "2. c "]
+ , testCase "item and enumerator styles" $
+ toAnsi defaultRenderEnv (list (itemStyle bold <> enumeratorStyle (fg red)) ["a"])
+ @?= "\ESC[0;31m• \ESC[0;1ma\ESC[0m"
+ , testCase "items by position" $
+ plainLines (list (itemStyleWith (\p -> if itemIndex p == 1 then paddingLeft 2 else mempty)) ["a", "b"])
+ @?= ["• a ", "• b"]
+ , testCase "root style" $
+ toAnsi defaultRenderEnv (tree (rootStyle bold) (Node "r" [])) @?= "\ESC[0;1mr\ESC[0m"
+ , testCase "a table inside a tree" $
+ plainLines (tree mempty (Node "r" [Node (table (border asciiBorder) [] [["x"]]) []]))
+ @?= ["r ", "└── +-+", " |x|", " +-+"]
+ ]
+ where
+ -- Lines are padded to the block's width.
+ withWidth ls w = [l <> T.replicate (w - textWidth l) " " | l <- ls]
+
+layerTests :: TestTree
+layerTests =
+ testGroup
+ "layers"
+ [ testCase "canvas fits all layers" $
+ plainLines (compose [layer mempty "ab", layer (offset 3 1) "cd"]) @?= ["ab ", " cd"]
+ , testCase "maxWidth crops a layer instead of wrapping it" $ do
+ plainLines (compose [layer (maxWidth 5) "hello world"]) @?= ["hello"]
+ plainLines (compose [layer (maxWidth 4) (render (border normalBorder) "ab cd")])
+ @?= ["┌───", "│ab ", "└───"]
+ , testCase "later layers are on top" $
+ plainLines (compose [layer mempty "aaaa", layer (offset 1 0) "bb"]) @?= ["abba"]
+ , testCase "z-index beats list order" $
+ plainLines (compose [layer (zIndex 1) "aaaa", layer (offset 1 0) "bb"]) @?= ["aaaa"]
+ , testCase "layers are opaque" $
+ plainLines (overlay 0 0 " " "ab") @?= [" "]
+ , testCase "transparent layers show unstyled spaces through" $
+ plainLines (compose [layer mempty "abc", layer transparent " X "]) @?= ["aXc"]
+ , testCase "styled spaces are not transparent" $
+ toAnsi defaultRenderEnv (compose [layer mempty "ab", layer transparent (render (bg red) " ")])
+ @?= "\ESC[0;41m \ESC[0mb"
+ , testCase "covering the second half of a wide character" $
+ plainLines (overlay 1 0 "x" "日本") @?= [" x本"]
+ , testCase "covering the first half of a wide character" $
+ plainLines (overlay 2 0 "x" "日本") @?= ["日x "]
+ , testCase "a wide character over narrow ones" $
+ plainLines (overlay 1 0 "日" "abcd") @?= ["a日d"]
+ , testCase "a wide character over two halves" $
+ plainLines (overlay 1 0 "本" "日日") @?= [" 本 "]
+ , testCase "left edge clipping" $
+ plainLines (overlay (-1) 0 "日b" ".....") @?= [" b..."]
+ , testCase "top edge clipping" $
+ plainLines (overlay 0 (-1) "a\nb" "..") @?= ["b."]
+ , testCase "sublayers are relative to their parent" $
+ plainLines (compose [layer (offset 2 1 <> sublayers [layer (offset 1 1) "c"]) "p"])
+ @?= [" ", " p", " c"] `withWidth'` 4
+ , testCase "sublayer z-index is relative" $
+ plainLines (compose [layer (zIndex 2) "aa", layer (zIndex 1 <> sublayers [layer (zIndex 2) "b"]) "x"])
+ @?= ["ba"]
+ , testCase "attributes survive" $
+ toAnsi defaultRenderEnv (overlay 1 0 (render bold "x") "ab") @?= "a\ESC[0;1mx\ESC[0m"
+ , testCase "zero-width clusters do not take a column" $
+ plainLines (overlay 0 0 "a\x200B\&b" "....") @?= ["ab.."]
+ , testCase "layerHit and findLayer report bounds" $ do
+ let ls = [layer (layerId "bg") (text "....\n...."), layer (offset 1 0 <> sublayers [layer (offset 1 1 <> layerId "btn") "ok"]) "x"]
+ fmap rectOf <$> layerHit Nothing 2 1 ls @?= Just ("btn", (2, 1, 2, 1))
+ fmap rectOf <$> layerHit Nothing 0 1 ls @?= Just ("bg", (0, 0, 4, 2))
+ rectOf <$> findLayer Nothing "btn" ls @?= Just (2, 1, 2, 1)
+ findLayer Nothing "nope" ls @?= Nothing
+ , testCase "layerAt finds the topmost named layer" $ do
+ let ls = [layer (layerId "bg") (text "....\n...."), layer (offset 1 1 <> layerId "btn") "ok", layer (offset 0 0) "x"]
+ layerAt Nothing 1 1 ls @?= Just "btn"
+ layerAt Nothing 3 1 ls @?= Just "bg"
+ layerAt Nothing 0 0 ls @?= Just "bg"
+ layerAt Nothing 9 9 ls @?= Nothing
+ , testProperty "compose is rectangular and fits its layers" $ \placed ->
+ let ls = [layer (offset x y <> zIndex z) (render (specMod s) "日本 text") | (s, (NonNegative x, NonNegative y, z)) <- take 4 placed]
+ b = compose ls
+ in rectangular b
+ .&&. blockWidth b === maximum (0 : [x + blockWidth (render (specMod s) "日本 text") | (s, (NonNegative x, _, _ :: Int)) <- take 4 placed])
+ ]
+ where
+ withWidth' ls w = [l <> T.replicate (w - textWidth l) " " | l <- ls]
+
+commonPropsTests :: TestTree
+commonPropsTests =
+ testGroup
+ "common properties"
+ [ testCase "the submodules export the types their functions take" $ do
+ getAlign (M.align M.center) @?= center
+ blockHeight (B.joinHorizontal B.top ["a", "b\nc"]) @?= 2
+ getAttrs (M.underlineStyle M.CurlyUnderline <> M.flag M.Bold True :: Mod Style)
+ @?= getAttrs (underlineStyle CurlyUnderline <> bold :: Mod Style)
+ G.attrBold (getAttrs (bold :: Mod Style)) @?= Just True
+ , testCase "positions show as what makes them" $
+ map show [center, position 0.25] @?= ["position 0.5", "position 0.25"]
+ , testCase "style attributes do not colour the border" $
+ toAnsi defaultRenderEnv (render (fg red <> border asciiBorder <> borderTop False <> borderBottom False) "x")
+ @?= "|\ESC[0;31mx\ESC[0m|"
+ , testCase "style background does not fill margins" $
+ toAnsi defaultRenderEnv (render (bg red <> marginLeft 1) "x") @?= " \ESC[0;41mx\ESC[0m"
+ , testCase "table attributes are the base for cells and borders" $
+ toAnsi defaultRenderEnv (table (bold <> border asciiBorder <> borderTop False <> borderBottom False) [] [["x"]])
+ @?= "\ESC[0;1m|x|\ESC[0m"
+ , testCase "cell styles and borderFg override the table's" $
+ toAnsi defaultRenderEnv (table (fg red <> borderFg blue <> cellStyle (const (fg green)) <> border asciiBorder <> borderTop False <> borderBottom False) [] [["x"]])
+ @?= "\ESC[0;34m|\ESC[0;32mx\ESC[0;34m|\ESC[0m"
+ , testCase "outline attributes are the base for items and enumerators" $
+ toAnsi defaultRenderEnv (list (fg red <> itemStyle bold) ["a"])
+ @?= "\ESC[0;31m• \ESC[0;1;31ma\ESC[0m"
+ , testCase "layer attributes are the base for its block" $
+ toAnsi defaultRenderEnv (compose [layer (bg red) (text "a" `besides` render (bg blue) "b")])
+ @?= "\ESC[0;41ma\ESC[0;44mb\ESC[0m"
+ , testCase "a layer with a background is not transparent" $
+ plainLines (compose [layer mempty "ab", layer (transparent <> bg red) " "]) @?= [" b"]
+ , testCase "place attributes colour the whitespace and the block" $
+ toAnsi defaultRenderEnv (place (width 3 <> align center <> bg red) (text "x"))
+ @?= "\ESC[0;41m x \ESC[0m"
+ , testCase "the placed block's own attributes win" $
+ toAnsi defaultRenderEnv (place (width 2 <> bg red) (render (bg blue) "x"))
+ @?= "\ESC[0;44mx\ESC[0;41m \ESC[0m"
+ , testCase "maxWidth crops tables, outlines, places and layers" $ do
+ blockWidth (table (maxWidth 3) ["abcdef"] []) @?= 3
+ blockWidth (tree (maxWidth 3) (Node "root" [Node "child" []])) @?= 3
+ blockWidth (place (width 10 <> maxWidth 4) "x") @?= 4
+ blockWidth (compose [layer (maxWidth 2) "abcd"]) @?= 2
+ , testCase "maxHeight crops outlines" $
+ blockHeight (list (maxHeight 2) ["a", "b", "c"]) @?= 2
+ , testCase "the same modifier works on every thing" $ do
+ let base :: Mod f
+ base = fg red <> bold
+ renderPlain (render base "x") @?= "x"
+ renderPlain (table base [] [["x"]]) @?= "╭─╮\n│x│\n╰─╯"
+ renderPlain (list base ["x"]) @?= "• x"
+ renderPlain (place base "x") @?= "x"
+ ]
+ where
+ besides a b = hcat [a, b]
+
+-- Features ported from lipgloss v2. lipstick does not aim to match it
+-- (README, "How lipstick differs from lipgloss"): these tests pin lipstick's
+-- rules.
+styleParityTests :: TestTree
+styleParityTests =
+ testGroup
+ "style parity"
+ [ testCase "per-side border colours" $ do
+ let ls = T.lines (toAnsi defaultRenderEnv (render (border asciiBorder <> borderTopFg red <> borderLeftFg blue <> borderRightBg green) "x"))
+ ls
+ @?= [ "\ESC[0;31m+-+\ESC[0m"
+ , "\ESC[0;34m|\ESC[0mx\ESC[0;42m|\ESC[0m"
+ , "+-+"
+ ]
+ , testCase "borderFg sets every side, a side after it overrides one" $
+ T.lines (toAnsi defaultRenderEnv (render (border asciiBorder <> borderFg red <> borderBottomFg blue) "x"))
+ @?= ["\ESC[0;31m+-+\ESC[0m", "\ESC[0;31m|\ESC[0mx\ESC[0;31m|\ESC[0m", "\ESC[0;34m+-+\ESC[0m"]
+ , testCase "gradient offset rotates clockwise" $ do
+ let colours m = [c | Just c <- map (attrFgOf . T.unpack) (take 1 (T.lines (toAnsi defaultRenderEnv (render (border asciiBorder <> m) "x"))))]
+ attrFgOf l = if take 2 l == "\ESC[" then Just (takeWhile (/= 'm') l) else Nothing
+ -- With offset 1 the top-left corner takes the colour the left side
+ -- had at the end of the clockwise walk.
+ colours (borderFgBlend [red, blue]) @?= ["\ESC[0;38;2;205;0;0"]
+ colours (borderFgBlend [red, blue] <> borderFgBlendOffset 1) @?= ["\ESC[0;38;2;0;0;238"]
+ colours (borderFgBlend [red, blue] <> borderFgBlendOffset 8) @?= colours (borderFgBlend [red, blue])
+ , testCase "colorWhitespace False keeps the background off padding" $
+ toAnsi defaultRenderEnv (render (bg red <> paddingLeft 1 <> colorWhitespace False) "x") @?= " \ESC[0;41mx\ESC[0m"
+ , testCase "reverse video covers padding" $
+ toAnsi defaultRenderEnv (render (reverseVideo <> paddingLeft 1) "x") @?= "\ESC[0;7m x\ESC[0m"
+ , testCase "underlineSpaces False" $
+ toAnsi defaultRenderEnv (render (underline <> underlineSpaces False) "a b")
+ @?= "\ESC[0;4ma\ESC[0m \ESC[0;4mb\ESC[0m"
+ , testCase "underlineSpaces True without underline" $
+ toAnsi defaultRenderEnv (render (underlineSpaces True) "a b") @?= "a\ESC[0;4m \ESC[0mb"
+ , testCase "strikethroughSpaces False" $
+ toAnsi defaultRenderEnv (render (strikethrough <> strikethroughSpaces False) "a b")
+ @?= "\ESC[0;9ma\ESC[0m \ESC[0;9mb\ESC[0m"
+ , testCase "transform" $ do
+ plainLines (render (transform T.toUpper) ("raow " <> styled bold "meow")) @?= ["RAOW MEOW"]
+ -- Text inside a framed block inherits the transform.
+ plainLines (frame (transform T.toUpper) (text "raow")) @?= ["RAOW"]
+ , testCase "unset modifiers" $ do
+ render (padding 1 1 <> unsetPadding) "x" @?~ render mempty "x"
+ render (margin 1 1 <> unsetMargins) "x" @?~ render mempty "x"
+ render (border roundedBorder <> borderFg red <> unsetBorder) "x" @?~ render mempty "x"
+ render (width 10 <> unsetWidth) "x" @?~ render mempty "x"
+ render (maxWidth 1 <> unsetMaxWidth) "xy" @?~ render mempty "xy"
+ render (width 5 <> align right <> unsetAlign) "x" @?~ render (width 5) "x"
+ render (link "u" <> underline <> unsetLink <> unsetUnderline) "x" @?~ render mempty "x"
+ render (tabWidth 1 <> unsetTabWidth) "a\tb" @?~ render mempty "a\tb"
+ render (transform T.toUpper <> unsetTransform) "x" @?~ render mempty "x"
+ , testCase "frame size" $ do
+ let m = padding 1 2 <> border normalBorder <> margin 1 1
+ frameSize m @?= (8, 6)
+ horizontalPadding m @?= 4
+ verticalBorderSize m @?= 2
+ horizontalMargins m @?= 2
+ frameSize (border normalBorder <> borderLeft False) @?= (1, 2)
+ , testCase "getters" $ do
+ let m = bold <> fg red <> width 10 <> maxWidth 8 <> border roundedBorder <> borderTop False <> align center
+ attrBold (getAttrs m) @?= Just True
+ attrFg (getAttrs m) @?= Just red
+ getWidth m @?= Just 10
+ getMaxWidth m @?= Just 8
+ getBorder m @?= Just roundedBorder
+ getBorderSides m @?= Sides False True True True
+ getAlign m @?= center
+ getBorder (mempty :: Mod Style) @?= Nothing
+ attrFg (getAttrs (fg blue :: Mod Table)) @?= Just blue
+ , testCase "table per-side border colours" $
+ T.lines (toAnsi defaultRenderEnv (table (border asciiBorder <> borderLeftFg red <> borderTop False <> borderBottom False) [] [["x"]]))
+ @?= ["\ESC[0;31m|\ESC[0mx|"]
+ ]
+
+textParityTests :: TestTree
+textParityTests =
+ testGroup
+ "text and colour parity"
+ [ testCase "wrap breaks after break characters" $
+ plainLinesAt 10 (render (breakAfter "-") "long-winded words") @?= ["long- ", "winded ", "words "]
+ , testCase "wrap without break characters" $
+ plainLinesAt 10 (render mempty "long-winded words") @?= ["long-winde", "d words "]
+ , testCase "styleRanges" $
+ toAnsi defaultRenderEnv (fromInline (styleRanges [(0, 3, bold)] "foobar"))
+ @?= "\ESC[0;1mfoo\ESC[0mbar"
+ , testCase "styleRanges counts display columns" $
+ toAnsi defaultRenderEnv (fromInline (styleRanges [(2, 4, bold)] "日本語"))
+ @?= "日\ESC[0;1m本\ESC[0m語"
+ , testCase "styleRanges keeps the text's own attributes" $
+ toAnsi defaultRenderEnv (fromInline (styleRanges [(1, 2, bold)] (styled (fg red) "abc")))
+ @?= "\ESC[0;31ma\ESC[0;1;31mb\ESC[0;31mc\ESC[0m"
+ , testCase "styleRanges across lines" $
+ toAnsi defaultRenderEnv (fromInline (styleRanges [(1, 3, bold)] "ab\ncd"))
+ @?= "a\ESC[0;1mb\ESC[0m\n\ESC[0;1mc\ESC[0md"
+ , testCase "styleIndices" $
+ toAnsi defaultRenderEnv (fromInline (styleIndices [0, 3] underline faint "foobar"))
+ @?= "\ESC[0;4mf\ESC[0;2moo\ESC[0;4mb\ESC[0;2mar\ESC[0m"
+ , testCase "ansiWidth and ansiHeight" $ do
+ ansiWidth "\ESC[31m日本\ESC[0m\nab" @?= 4
+ ansiHeight "\ESC[31m日本\ESC[0m\nab" @?= 2
+ ansiWidth (toAnsi defaultRenderEnv (render (border roundedBorder <> padding 0 1) "hi")) @?= 6
+ , testCase "blend2D shape" $ do
+ let g = blend2D 4 3 45 [red, blue]
+ length g @?= 3
+ map length g @?= [4, 4, 4]
+ blend2D 2 2 0 [green] @?= [[green, green], [green, green]]
+ blend2D 2 2 0 [] @?= []
+ , testCase "blend2D directions" $ do
+ let rowsOf a = blend2D 5 3 a [red, blue]
+ all (\r -> all (== take 1 r) [[c] | c <- r]) (rowsOf 90) @? "rows are uniform at 90 degrees"
+ rowsOf 270 @?= reverse (rowsOf 90)
+ map reverse (rowsOf 180) @?= rowsOf 0
+ take 1 (rowsOf 90) /= drop 2 (rowsOf 90) @? "top and bottom differ"
+ ]
+
+tableParityTests :: TestTree
+tableParityTests =
+ testGroup
+ "table parity"
+ [ testCase "maxHeight shows an overflow row" $
+ plainLines (table (maxHeight 7) ["N", "What"] numbered)
+ @?= ["╭─┬────╮", "│N│What│", "├─┼────┤", "│0│row │", "│1│row │", "│…│… │", "╰─┴────╯"]
+ , testCase "yOffset scrolls" $ do
+ take 2 (drop 3 (plainLines (table (maxHeight 7 <> yOffset 4) ["N", "What"] numbered))) @?= ["│4│row │", "│5│row │"]
+ visibleRows Nothing (maxHeight 7 <> yOffset 4) ["N", "What"] numbered @?= Just (4, 5)
+ , testCase "scrolled to the end, earlier rows fill the space" $ do
+ visibleRows Nothing (maxHeight 7 <> yOffset 9) ["N", "What"] numbered @?= Just (7, 9)
+ visibleRows Nothing (maxHeight 7 <> yOffset 99) ["N", "What"] numbered @?= Just (7, 9)
+ , testCase "all rows without a maxHeight" $
+ visibleRows Nothing mempty ["N"] numbered @?= Just (0, 9)
+ , testCase "an empty table shows no rows" $
+ visibleRows Nothing mempty ["N"] [] @?= Nothing
+ , testCase "row rules count towards the maxHeight" $
+ plainLines (table (maxHeight 8 <> rowRules True <> border asciiBorder) [] numbered)
+ -- maxHeight 8 leaves 6 lines inside the border. Two rows, their
+ -- rules and the overflow row take 5; a third row would need 7.
+ @?= ["+-+---+", "|0|row|", "+-+---+", "|1|row|", "+-+---+", "|…|… |", "+-+---+"]
+ , testCase "too small for any row" $ do
+ visibleRows Nothing (maxHeight 3) ["N"] numbered @?= Nothing
+ blockHeight (table (maxHeight 3) ["N"] numbered) @?= 3
+ , testCase "the overflow row only where it fits, keeping the bottom border" $ do
+ plainLines (table (maxHeight 5) ["a"] [["1"], ["2"]]) @?= ["╭─╮", "│a│", "├─┤", "│…│", "╰─╯"]
+ plainLines (table (maxHeight 4) ["a"] [["1"], ["2"]]) @?= ["╭─╮", "│a│", "╰─╯"]
+ , testCase "fitContent does not stretch" $
+ plainLines (table (width 30 <> fitContent) ["N", "What"] [["0", "row"]])
+ @?= ["╭─┬────╮", "│N│What│", "├─┼────┤", "│0│row │", "╰─┴────╯"]
+ , testCase "fitContent still shrinks to the width" $
+ blockWidth (table (width 8 <> fitContent) ["Number", "What"] [["0", "row"]]) @?= 8
+ , testCase "headers are cut, not wrapped" $
+ plainLines (table (width 8) ["Header text", "H"] [["a", "b"]])
+ @?= ["╭────┬─╮", "│Hea…│H│", "├────┼─┤", "│a │b│", "╰────┴─╯"]
+ , testCase "height is a minimum, filled with empty rows" $
+ plainLines (table (height 6) ["N"] [["0"]]) @?= ["╭─╮", "│N│", "├─┤", "│0│", "│ │", "╰─╯"]
+ , testCase "height and maxHeight together fix the height" $ do
+ blockHeight (table (height 7 <> maxHeight 7) ["N", "What"] numbered) @?= 7
+ blockHeight (table (height 7 <> maxHeight 7) ["N", "What"] (take 1 numbered)) @?= 7
+ , testProperty "a table never exceeds its maxHeight" $ \(Positive h) (TableData hs rs) ->
+ blockHeight (table (maxHeight h) (map fromInline hs) (map (map fromInline) rs)) <= h
+ ]
+ where
+ numbered = [[text (T.pack (show i)), "row"] | i <- [0 .. 9 :: Int]]
+
+outlineParityTests :: TestTree
+outlineParityTests =
+ testGroup
+ "outline parity"
+ [ testCase "custom indenter" $
+ plainLines (forest (indenter (const ": ")) [Node "a\nb" [Node "c" []]])
+ @?= ["└── a ", ": b ", ": └── c"]
+ , testCase "an indenter wider than the enumerator widens it" $ do
+ plainLines (list (indenter (const ">>>>>>")) ["one\ntwo", "three"])
+ @?= ["• one ", ">>>>>>two ", "• three"]
+ plainLines (forest (indenter (const "::::::")) [Node "a" [Node "b\nc" []]])
+ @?= ["└── a ", "::::::└── b", "::::::::::::c"]
+ , testCase "indentation uses the enumerator style by default" $
+ toAnsi defaultRenderEnv (forest (enumeratorStyle (fg red)) [Node "a\nb" []])
+ @?= "\ESC[0;31m└── \ESC[0ma\n\ESC[0;31m \ESC[0mb"
+ , testCase "enumerators and indenters see the item's position" $ do
+ let lastOnly = markers (\p -> if isLast p then "> " else "- ")
+ plainLines (list (enumerator lastOnly) ["a", "b", "c"]) @?= ["- a", "- b", "> c"]
+ plainLines (forest (indenter (\p -> T.pack (show (itemDepth p)) <> " ")) [Node "a\nb" [Node "c" []]])
+ @?= ["└── a ", "0 b ", "0 └── c"]
+ , testCase "default indentation is as wide as a padded enumerator" $ do
+ plainLines (nestedList (enumeratorStyle (paddingRight 1)) [Node "first\nsecond" [Node "child" []], Node "c" []])
+ @?= ["• first ", " second ", " • child", "• c "]
+ plainLines (list (enumeratorStyle (marginRight 2)) ["a\nb"]) @?= ["• a", " b"]
+ plainLines (list (enumeratorStyle (paddingLeft 1) <> indenterStyle (paddingRight 2)) ["a\nb"])
+ @?= [" • a", " b"]
+ , testCase "indenter style replaces it" $
+ toAnsi defaultRenderEnv (forest (enumeratorStyle (fg red) <> indenterStyle (fg blue)) [Node "a\nb" []])
+ @?= "\ESC[0;31m└── \ESC[0ma\n\ESC[0;34m \ESC[0mb"
+ , testCase "width pads with the item's background" $
+ toAnsi defaultRenderEnv (list (width 5 <> itemStyle (bg red)) ["a"]) @?= "• \ESC[0;41ma \ESC[0m"
+ , testCase "height pads with blank lines" $
+ plainLines (list (height 3) ["a"]) @?= ["• a", " ", " "]
+ , testCase "itemOffset skips items at both ends" $
+ plainLines (list (enumerator arabic <> itemOffset 1 1) ["a", "b", "c", "d"]) @?= ["1. b", "2. c"]
+ , testCase "itemOffset only affects the top level" $
+ plainLines (nestedList (itemOffset 1 0) [Node "a" [], Node "b" [Node "c" [], Node "d" []]])
+ @?= ["• b ", " • c", " • d"]
+ , testCase "marker alignment keeps the enumerator's background" $
+ take 1 (T.lines (toAnsi defaultRenderEnv (list (enumerator arabic <> enumeratorStyle (bg red)) (replicate 10 "x"))))
+ @?= ["\ESC[0;41m 1. \ESC[0mx"]
+ ]
+
+renderTests :: TestTree
+renderTests =
+ testGroup
+ "render"
+ [ testCase "plain" $ plainLines (render mempty "a\nbcd") @?= ["a ", "bcd"]
+ , testCase "padding" $
+ plainLines (render (padding 1 2) "hi") @?= [" ", " hi ", " "]
+ , testCase "rounded border" $
+ plainLines (render (border roundedBorder) "hi") @?= ["╭──╮", "│hi│", "╰──╯"]
+ , testCase "border with some sides off" $
+ plainLines (render (border normalBorder <> borderLeft False <> borderRight False) "hi")
+ @?= ["──", "hi", "──"]
+ , testCase "width includes padding and border" $ do
+ let b = render (width 10 <> padding 0 1 <> border normalBorder) "hi"
+ blockWidth b @?= 10
+ plainLines b @?= ["┌────────┐", "│ hi │", "└────────┘"]
+ , testCase "width wraps words" $
+ plainLines (render (width 10) "the quick brown fox")
+ @?= ["the quick ", "brown fox "]
+ , testCase "long words are broken" $
+ plainLines (render (width 4) "abcdefghij") @?= ["abcd", "efgh", "ij "]
+ , testCase "centre alignment" $
+ plainLines (render (width 7 <> align center) "abc") @?= [" abc "]
+ , testCase "right alignment" $
+ plainLines (render (width 5 <> align right) "ab\nabc") @?= [" ab", " abc"]
+ , testCase "height and vertical alignment" $
+ plainLines (render (height 3 <> valign bottom) "x") @?= [" ", " ", "x"]
+ , testCase "margins" $
+ plainLines (render (margin 1 1) "x") @?= [" ", " x ", " "]
+ , testCase "maxWidth crops" $
+ plainLines (render (maxWidth 3) "abcdef") @?= ["abc"]
+ , testCase "maxWidth replaces a cut wide character" $
+ plainLines (render (maxWidth 3) "日本") @?= ["日 "]
+ , testCase "tabs" $ plainLines (render (tabWidth 2) "a\tb") @?= ["a b"]
+ , testCase "frame does not rewrap" $
+ plainLines (frame (border asciiBorder) (text "a b c"))
+ @?= ["+-----+", "|a b c|", "+-----+"]
+ , testCase "noWrap truncates with an ellipsis" $
+ plainLines (render (width 5 <> noWrap) "abcdefgh\nabc") @?= ["abcd…", "abc "]
+ , testCase "noWrap does not cut a wide character in half" $
+ plainLines (render (width 4 <> noWrap) "日本語") @?= ["日 …"]
+ , testCase "negative padding and margins count as 0" $ do
+ render (border normalBorder <> padding 0 (-1)) "hello" @?~ render (border normalBorder) "hello"
+ render (border normalBorder <> margin (-1) (-2)) "hello" @?~ render (border normalBorder) "hello"
+ getPadding (paddingLeft (-3)) @?= Sides 0 0 0 0
+ , testCase "negative widths and heights count as 0" $ do
+ render (width (-5)) "hello" @?~ render (width 0) "hello"
+ render (height (-5)) "hello" @?~ render (height 0) "hello"
+ render (maxWidth (-1) <> maxHeight (-1)) "hello" @?~ render (maxWidth 0 <> maxHeight 0) "hello"
+ blockWidth (frame (border normalBorder) (render (width (-5)) "a")) @?= 2
+ blockWidth (table (width (-4)) ["a", "b"] [["abc", "def"]]) @?= blockWidth (table (width 0) ["a", "b"] [["abc", "def"]])
+ , testCase "inherit leaves out padding and margins" $
+ plainLines (render (paddingLeft 1 <> inherit (paddingLeft 5 <> marginLeft 3 <> bold)) "x") @?= [" x"]
+ , testCase "settings after inherit win" $ do
+ let parent = fg "4" <> width 20 <> border doubleBorder <> paddingLeft 5
+ s = inherit parent <> fg "1" <> width 10
+ (attrFg (getAttrs s), getWidth s, getBorder s == Just doubleBorder, getPadding s)
+ @?= (Just "1", Just 10, True, Sides 0 0 0 0)
+ , testCase "inherit keeps the margin colour" $
+ getMarginBg (inherit (marginBg "4" <> marginLeft 2)) @?= Just "4"
+ ]
+
+layoutTests :: TestTree
+layoutTests =
+ testGroup
+ "layout"
+ [ testCase "joinHorizontal top" $
+ plainLines (hcat [text "a\nb", text "c"]) @?= ["ac", "b "]
+ , testCase "joinHorizontal bottom" $
+ plainLines (joinHorizontal bottom [text "a\nb", text "c"]) @?= ["a ", "bc"]
+ , testCase "joinVertical center" $
+ plainLines (joinVertical center [text "abcde", text "x"]) @?= ["abcde", " x "]
+ , testCase "place" $
+ plainLines (place (width 5 <> height 3 <> align center <> valign center) "x")
+ @?= [" ", " x ", " "]
+ , testCase "place with whitespace chars" $
+ plainLines (place (width 5 <> align right <> whitespaceChars "ab") "x") @?= ["abab" <> "x"]
+ , testCase "empty block" $ do
+ blockWidth emptyBlock @?= 0
+ blockHeight emptyBlock @?= 0
+ plainLines (hcat [emptyBlock, text "x"]) @?= ["x"]
+ ]
+
+ansiTests :: TestTree
+ansiTests =
+ testGroup
+ "ansi"
+ [ testCase "bold and colour" $
+ toAnsi defaultRenderEnv (render (bold <> fg "#ff0000") "hi")
+ @?= "\ESC[0;1;38;2;255;0;0mhi\ESC[0m"
+ , testCase "downsampled to 256" $
+ toAnsi (renderEnv ANSI256 True Nothing) (render (fg "#ff0000") "hi")
+ @?= "\ESC[0;38;5;196mhi\ESC[0m"
+ , testCase "basic colours" $
+ toAnsi (renderEnv ANSI16 True Nothing) (render (fg red <> bg brightBlue) "hi")
+ @?= "\ESC[0;31;104mhi\ESC[0m"
+ , testCase "ascii keeps attributes, drops colours" $
+ toAnsi (renderEnv Ascii True Nothing) (render (bold <> fg red) "hi")
+ @?= "\ESC[0;1mhi\ESC[0m"
+ , testCase "NoTTY is plain" $
+ toAnsi (renderEnv NoTTY True Nothing) (render (bold <> fg red <> link "x") "hi") @?= "hi"
+ , testCase "nested style keeps outer background" $
+ toAnsi defaultRenderEnv (render (bg "1") (styled bold "a" <> "b"))
+ @?= "\ESC[0;1;41ma\ESC[0;41mb\ESC[0m"
+ , testCase "padding gets only the background" $
+ toAnsi defaultRenderEnv (render (underline <> bg "1" <> paddingLeft 1) "a")
+ @?= "\ESC[0;41m \ESC[0;4;41ma\ESC[0m"
+ , testCase "curly underline downgraded below true colour" $
+ toAnsi (renderEnv ANSI256 True Nothing) (render (underlineStyle CurlyUnderline) "a")
+ @?= "\ESC[0;4ma\ESC[0m"
+ , testCase "hyperlink" $
+ toAnsi defaultRenderEnv (render (link "https://x.y") "a")
+ @?= "\ESC]8;;https://x.y\ESC\\a\ESC]8;;\ESC\\"
+ , testCase "hyperlink controls and non-ASCII are percent-encoded" $
+ toAnsi defaultRenderEnv (render (link "http://x\ESC]0;t\a y/\233") "a")
+ @?= "\ESC]8;;http://x%1B]0;t%07%20y/%C3%A9\ESC\\a\ESC]8;;\ESC\\"
+ , testProperty "escaped URIs are printable ASCII, and escaping is idempotent" $ \s ->
+ let u = escapeUri (T.pack s)
+ in T.all (\c -> c > ' ' && c < '\DEL') u .&&. escapeUri u === u
+ , testCase "every line resets attributes and closes links" $
+ toAnsiLines defaultRenderEnv (render (link "u" <> bold) "a\nb")
+ @?= [ "\ESC]8;;u\ESC\\\ESC[0;1ma\ESC[0m\ESC]8;;\ESC\\"
+ , "\ESC]8;;u\ESC\\\ESC[0;1mb\ESC[0m\ESC]8;;\ESC\\"
+ ]
+ , testCase "output is UTF-8 whatever the handle's encoding" $ do
+ dir <- getTemporaryDirectory
+ (path, h) <- openTempFile dir "lipstick.txt"
+ hSetEncoding h =<< mkTextEncoding "ASCII"
+ let b = render (border roundedBorder) "héllo"
+ hPutBlockWith (renderEnv NoTTY True Nothing) h b
+ hClose h
+ out <- Utf8.readFile path
+ removeFile path
+ out @?= renderPlain b <> "\n"
+ , testCase "light/dark resolved at output" $ do
+ let b = render (fg (lightDark "1" "2")) "a"
+ toAnsi (renderEnv TrueColor True Nothing) b @?= "\ESC[0;32ma\ESC[0m"
+ toAnsi (renderEnv TrueColor False Nothing) b @?= "\ESC[0;31ma\ESC[0m"
+ ]
+
+profileTests :: TestTree
+profileTests =
+ testGroup
+ "profile detection"
+ [ testCase "not a terminal" $ profileFromEnv False [("TERM", "xterm-256color")] @?= NoTTY
+ , testCase "forced" $ profileFromEnv False [("CLICOLOR_FORCE", "1"), ("TERM", "xterm-256color")] @?= ANSI256
+ , testCase "force=0 is not forced" $ profileFromEnv False [("CLICOLOR_FORCE", "0")] @?= NoTTY
+ , testCase "NO_COLOR" $ profileFromEnv True [("NO_COLOR", "1"), ("COLORTERM", "truecolor")] @?= Ascii
+ , testCase "COLORTERM" $ profileFromEnv True [("COLORTERM", "truecolor"), ("TERM", "xterm")] @?= TrueColor
+ , testCase "256 colours" $ profileFromEnv True [("TERM", "screen-256color")] @?= ANSI256
+ , testCase "screen ignores COLORTERM, and screen and tmux show 256 colours" $ do
+ profileFromEnv True [("TERM", "screen"), ("COLORTERM", "truecolor")] @?= ANSI256
+ profileFromEnv True [("TERM", "screen.xterm-256color"), ("COLORTERM", "24bit")] @?= ANSI256
+ profileFromEnv True [("TERM", "tmux"), ("COLORTERM", "truecolor")] @?= TrueColor
+ profileFromEnv True [("TERM", "tmux")] @?= ANSI256
+ , testCase "kitty" $ profileFromEnv True [("TERM", "xterm-kitty")] @?= TrueColor
+ , testCase "ghostty" $ profileFromEnv True [("TERM", "xterm-ghostty")] @?= TrueColor
+ , testCase "plain xterm" $ profileFromEnv True [("TERM", "xterm")] @?= ANSI16
+ , testCase "COLORFGBG dark" $ backgroundFromEnv [("COLORFGBG", "15;0")] @?= Just True
+ , testCase "COLORFGBG light" $ backgroundFromEnv [("COLORFGBG", "0;15")] @?= Just False
+ , testCase "COLORFGBG with default" $ backgroundFromEnv [("COLORFGBG", "0;default;7")] @?= Just False
+ , testCase "COLORFGBG bright black is dark" $ backgroundFromEnv [("COLORFGBG", "7;8")] @?= Just True
+ , testCase "COLORFGBG unparsable" $ backgroundFromEnv [("COLORFGBG", "default;default")] @?= Nothing
+ , testCase "COLORFGBG unset" $ backgroundFromEnv [] @?= Nothing
+ , testCase "COLUMNS" $ do
+ widthFromEnv [("COLUMNS", "120")] @?= Just 120
+ widthFromEnv [("COLUMNS", "0")] @?= Nothing
+ widthFromEnv [("COLUMNS", "wide")] @?= Nothing
+ widthFromEnv [("COLUMNS", "")] @?= Nothing
+ widthFromEnv [] @?= Nothing
+ , testCase "a file has no width, unless COLUMNS sets one" $ do
+ saved <- lookupEnv "COLUMNS"
+ dir <- getTemporaryDirectory
+ (path, h) <- openTempFile dir "lipstick-width.txt"
+ unsetEnv "COLUMNS"
+ none <- detectWidth h
+ setEnv "COLUMNS" "33"
+ set <- detectWidth h
+ maybe (unsetEnv "COLUMNS") (setEnv "COLUMNS") saved
+ hClose h
+ removeFile path
+ (none, set) @?= (Nothing, Just 33)
+ ]
+
+-- Properties ------------------------------------------------------------------
+
+newtype Words = Words Text
+ deriving (Show)
+
+instance Arbitrary Words where
+ arbitrary = do
+ ws <- listOf (elements ["a", "bb", "ccc", "日本", "🎨", "e\x0301", "longerword", " ", "\n", "x\ty"])
+ pure (Words (T.concat ws))
+
+data StyleSpec = StyleSpec
+ { specWidth :: Maybe Int
+ , specPadding :: (Int, Int)
+ , specMargin :: (Int, Int)
+ , specBorder :: Bool
+ }
+ deriving (Show)
+
+instance Arbitrary StyleSpec where
+ arbitrary =
+ StyleSpec
+ <$> oneof [pure Nothing, Just <$> chooseInt (6, 30)]
+ <*> ((,) <$> chooseInt (0, 2) <*> chooseInt (0, 2))
+ <*> ((,) <$> chooseInt (0, 2) <*> chooseInt (0, 2))
+ <*> arbitrary
+
+-- | Inline text made of segments with random attributes.
+newtype StyledText = StyledText Inline
+ deriving (Show)
+
+instance Arbitrary StyledText where
+ arbitrary = do
+ segs <- listOf $ do
+ Words t <- arbitrary
+ m <- mconcat <$> sublistOf attrMods
+ pure (styled m t)
+ pure (StyledText (mconcat segs))
+ where
+ attrMods =
+ [ bold, italic, faint, strikethrough, reverseVideo, underline
+ , underlineStyle CurlyUnderline, underlineColor "#00ff00"
+ , fg "#ff8000", fg "200", fg red, bg "#102030", bg brightCyan
+ , link "https://example.com"
+ ]
+
+specMod :: StyleSpec -> Mod Style
+specMod (StyleSpec w (pv, ph) (mv, mh) b) =
+ maybe mempty width w
+ <> padding pv ph
+ <> margin mv mh
+ <> (if b then border roundedBorder else mempty)
+
+-- | Every line of the plain output is exactly as wide as the block says.
+rectangular :: Block -> Property
+rectangular b =
+ -- Split on newlines exactly: T.lines would drop a trailing empty line,
+ -- and an empty block still renders as one (empty) line of text.
+ let ls = T.splitOn "\n" (renderPlain b)
+ in counterexample (show ls) $
+ conjoin
+ [ length ls === max 1 (blockHeight b)
+ , conjoin [textWidth l === blockWidth b | l <- ls]
+ ]
+
+-- | Text made of pieces that combine into clusters: emoji with variation
+-- selectors and ZWJs, flags, combining marks, Hangul jamo.
+trickyText :: Gen Text
+trickyText =
+ T.concat
+ <$> listOf
+ ( elements
+ [ "a", " ", "e", "\x301", "\x2764", "\xFE0F", "\xFE0E", "\x200D", "👨", "👩"
+ , "🇮", "🇹", "日", "\x1100", "\x1161", "#", "\x20E3"
+ ]
+ )
+
+-- | A text cut into pieces at random characters, each with random styles.
+styledPieces :: Text -> Gen Inline
+styledPieces t = do
+ cuts <- sublistOf [1 .. T.length t - 1]
+ let bounds = zip (0 : cuts) (cuts ++ [T.length t])
+ pieces = [T.take (e - s) (T.drop s t) | (s, e) <- bounds]
+ mconcat <$> mapM (\p -> elements [plain p, styled bold p, styled (fg red) p]) pieces
+
+stripAnsi :: Text -> Text
+stripAnsi t = case T.breakOn "\ESC" t of
+ (before, rest)
+ | T.null rest -> before
+ | "\ESC]" `T.isPrefixOf` rest ->
+ before <> stripAnsi (T.drop 2 (snd (T.breakOn "\ESC\\" (T.drop 2 rest))))
+ | otherwise -> before <> stripAnsi (T.drop 1 (T.dropWhile (/= 'm') rest))
+
+-- | A description of a block, to generate block trees.
+data Shape
+ = ShapeText Text
+ | ShapeRender StyleSpec Bool Bool Text
+ -- ^ style, grows, stretches
+ | ShapeFrame StyleSpec Bool Bool Shape
+ | ShapeRow Int [Shape]
+ | ShapeColumn Int [Shape]
+ | ShapePlace (Maybe Int) Bool Shape
+ -- ^ width, stretches
+ | ShapeTable (Maybe Int) Bool [[Text]]
+ -- ^ width, grows
+ | ShapeList Bool [Shape]
+ | ShapeTree Shape [Shape]
+ | ShapeLayers [((Int, Int), Shape)]
+ | ShapeEmpty
+ deriving (Show)
+
+instance Arbitrary Shape where
+ arbitrary = sized go
+ where
+ go n
+ | n <= 1 = leaf
+ | otherwise =
+ frequency
+ [ (3, leaf)
+ , (2, ShapeFrame <$> arbitrary <*> arbitrary <*> arbitrary <*> go (n `div` 2))
+ , (2, ShapeRow <$> chooseInt (0, 2) <*> children n)
+ , (2, ShapeColumn <$> chooseInt (0, 2) <*> children n)
+ , (1, ShapePlace <$> oneof [pure Nothing, Just <$> chooseInt (0, 30)] <*> arbitrary <*> go (n `div` 2))
+ , (1, ShapeList <$> arbitrary <*> children n)
+ , (1, ShapeTree <$> go (n `div` 2) <*> children n)
+ , (1, ShapeLayers <$> (zip <$> vectorOf 3 ((,) <$> chooseInt (-2, 8) <*> chooseInt (0, 3)) <*> children n))
+ ]
+ children n = do
+ k <- chooseInt (0, 3)
+ vectorOf k (go (n `div` (k + 1)))
+ leaf =
+ frequency
+ [ (2, (\(Words t) -> ShapeText t) <$> arbitrary)
+ , (3, (\spec g st (Words t) -> ShapeRender spec g st t) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)
+ , (1, ShapeTable <$> oneof [pure Nothing, Just <$> chooseInt (0, 30)] <*> arbitrary <*> vectorOf 2 (vectorOf 2 ((\(Words t) -> t) <$> arbitrary)))
+ , (1, pure ShapeEmpty)
+ ]
+
+toBlock :: Shape -> Block
+toBlock = \case
+ ShapeText t -> text t
+ ShapeRender spec g st t -> render (specMod spec <> flags g st) (plain t)
+ ShapeFrame spec g st sh -> frame (specMod spec <> flags g st) (toBlock sh)
+ ShapeRow p shs -> joinHorizontal ([top, center, bottom] !! p) (map toBlock shs)
+ ShapeColumn p shs -> joinVertical ([left, center, right] !! p) (map toBlock shs)
+ ShapePlace w st sh -> place (maybe mempty width w <> (if st then stretchHeight else mempty) <> align center) (toBlock sh)
+ ShapeTable w g rows -> table (maybe mempty width w <> (if g then fillWidth else mempty)) ["a", "b"] (map (map text) rows)
+ ShapeList g shs -> list (if g then fillWidth else mempty) (map toBlock shs)
+ ShapeTree root shs -> tree mempty (Node (toBlock root) [Node (toBlock sh) [] | sh <- shs])
+ ShapeLayers ls -> compose [layer (offset x y) (toBlock sh) | ((x, y), sh) <- ls]
+ ShapeEmpty -> emptyBlock
+ where
+ flags g st = (if g then fillWidth else mempty) <> (if st then stretchHeight else mempty)
+
+-- | Every line is as wide as the grid, and so is its text on a terminal.
+gridIsRectangular :: Grid -> Property
+gridIsRectangular g =
+ counterexample (show g) $
+ length (gridLines g) === gridHeight g
+ .&&. conjoin [lineWidth l === gridWidth g | l <- gridLines g]
+ .&&. conjoin [textWidth (T.concat (map spanText (lineSpans l))) === gridWidth g | l <- gridLines g]
+
+deferredLayoutTests :: TestTree
+deferredLayoutTests =
+ testGroup
+ "deferred layout"
+ [ testProperty "a block is exactly as wide as the width it is given" $ \sh ->
+ let b = toBlock sh
+ in forAll (chooseInt (0, blockWidth b + 10)) $ \w ->
+ let g = fst (blockLayout (measure b) (Assign w 0))
+ in gridWidth g === w .&&. gridIsRectangular g
+ , testProperty "the natural height is the height of the grid" $ \sh ->
+ let b = toBlock sh
+ in forAll (chooseInt (0, blockWidth b + 10)) $ \w ->
+ let (g, n) = blockLayout (measure b) (Assign w 0)
+ in gridHeight g === n
+ , testProperty "the natural height does not depend on the height to stretch to" $ \sh ->
+ let b = toBlock sh
+ in forAll (chooseInt (0, blockWidth b + 10)) $ \w ->
+ snd (blockLayout (measure b) (Assign w (error "the target height was forced")))
+ === snd (blockLayout (measure b) (Assign w 0))
+ , testProperty "only blocks that stretch grow to the height they are asked for" $ \sh (NonNegative extra) ->
+ let b = toBlock sh
+ w = blockWidth b
+ n = blockHeight b
+ g = fst (blockLayout (measure b) (Assign w (n + extra)))
+ in gridHeight g === (if reqStretch (blockRequest (measure b)) then n + extra else n)
+ , testProperty "the smallest width is at most the natural width" $ \sh ->
+ let b = toBlock sh in blockMinWidth b <= blockWidth b
+ , testProperty "with no limit, a block is laid out at its natural width" $ \sh ->
+ let b = toBlock sh
+ g = layout Nothing b
+ in gridWidth g === blockWidth b .&&. gridHeight g === blockHeight b
+ , testCase "text wraps to the width" $
+ plainLinesAt 10 (text "the quick brown fox") @?= ["the quick ", "brown fox "]
+ , testCase "indentation is dropped when the first word does not fit after it" $ do
+ plainLinesAt 10 (text " indented word") @?= ["indented ", "word "]
+ plainLinesAt 3 (text " abc") @?= ["abc"]
+ plainLinesAt 3 (text "\tfoo") @?= ["foo"]
+ plainLinesAt 10 (text " indented word") @?= [" indented", "word "]
+ plainLinesAt 4 (text " abcdef") @?= [" ab", "cdef"]
+ , testProperty "text laid out at its smallest width breaks no word" $
+ forAll (chooseInt (0, 6)) $ \n ->
+ forAll (listOf1 (T.pack <$> listOf1 (elements "ab"))) $ \ws ->
+ let t = T.replicate n " " <> T.unwords ws
+ b = text t
+ in T.words (T.unlines (plainLinesAt (blockMinWidth b) b)) === ws
+ , testCase "text with no room is cut, not wrapped" $ do
+ gridHeight (layout (Just 0) (text "hello world\nagain")) @?= 2
+ plainLinesAt 4 (hcat [render (border normalBorder) "hello", render (border normalBorder) "world"])
+ @?= ["┌┐┌┐", "││││", "└┘└┘"]
+ , testCase "a box wraps its text inside the border" $
+ plainLinesAt 12 (render (border normalBorder <> padding 0 1) "the quick brown fox")
+ @?= ["┌──────────┐", "│ the │", "│ quick │", "│ brown │", "│ fox │", "└──────────┘"]
+ , testCase "a frame lays its block out in the width left inside" $
+ plainLinesAt 7 (frame (border normalBorder) (text "aaa bbb ccc"))
+ @?= ["┌─────┐", "│aaa │", "│bbb │", "│ccc │", "└─────┘"]
+ , testCase "a block narrower than the space keeps its natural width" $
+ plainLinesAt 40 (render (border normalBorder) "hi") @?= ["┌──┐", "│hi│", "└──┘"]
+ , testCase "tables and outlines stretch to the height of a row" $ do
+ let row b = map (T.drop 1) (plainLines (hcat [render (height 6) "x", b]))
+ row (table stretchHeight ["a"] [["1"]]) @?= ["╭─╮", "│a│", "├─┤", "│1│", "│ │", "╰─╯"]
+ row (list (stretchHeight <> itemStyle (bg red)) ["q"]) @?= ["• q", " ", " ", " ", " ", " "]
+ blockHeight (table stretchHeight ["a"] [["1"]]) @?= 5
+ , testCase "a table under an inherited noWrap shrinks as with its own" $ do
+ let t m = table m ["name"] [["a long cell", "x"]]
+ blockMinWidth (frame noWrap (t mempty)) @?= blockMinWidth (t noWrap)
+ plainLinesAt 30 (hcat [frame noWrap (t mempty), render (border normalBorder) "aaa bbb ccc"])
+ @?= plainLinesAt 30 (hcat [t noWrap, render (border normalBorder) "aaa bbb ccc"])
+ , testCase "borderFgBlend colours a table's border as a style's" $ do
+ let colours b = [c | l <- gridLines (layout Nothing b), sp <- lineSpans l, Just c <- [attrFg (spanAttrs sp)]]
+ tableColours = colours (table (borderFgBlend [red, blue] <> borderFgBlendOffset 1) ["a"] [["1"]])
+ tableColours @?= colours (render (border roundedBorder <> borderFgBlend [red, blue] <> borderFgBlendOffset 1) "a\n─\n1")
+ length tableColours @?= 12
+ , testCase "a table does not stretch past maxHeight, and keeps its bottom border" $ do
+ last (plainLines (table (maxHeight 9 <> height 12) ["n"] [["1"], ["2"], ["3"]])) @?= "╰─╯"
+ plainLines (hcat [render (height 8) "x", table (stretchHeight <> maxHeight 6) ["a"] [["1"]]]) !! 5 @?= " ╰─╯"
+ , testCase "fillWidth takes the spare columns of a row" $
+ plainLinesAt 12 (hcat [render (width 4) "ab", render (fillWidth <> bg red) "cd", "!"])
+ @?= ["ab cd !"]
+ , testCase "spare columns are shared by weight" $
+ map T.length (plainLinesAt 12 (hcat [render (grow 1) "a", render (grow 2) "b"])) @?= [12]
+ , testCase "fillWidth fills the output's width" $
+ plainLinesAt 6 (render (fillWidth <> align right) "ab") @?= [" ab"]
+ , testCase "what a block cannot use goes to the others" $
+ plainLinesAt 12 (hcat [render (fillWidth <> maxWidth 4 <> bg red) "a", render fillWidth "b"])
+ @?= ["a b "]
+ , testCase "fillWidth with maxWidth fills up to the crop" $
+ plainLinesAt 20 (render (fillWidth <> maxWidth 5 <> align right) "ab") @?= [" ab"]
+ , testCase "maxWidth crops instead of wrapping" $
+ plainLinesAt 20 (render (maxWidth 3) "abc def") @?= ["abc"]
+ , testCase "the widest block shrinks first" $
+ plainLinesAt 10 (hcat [text "aaa bbb ccc", text "|", text "dd"])
+ @?= ["aaa bbb|dd", "ccc "]
+ , testCase "stretchHeight grows a box to the tallest in its row" $
+ plainLines (hcat [render (border normalBorder <> stretchHeight) "a", text "1\n2\n3\n4"])
+ @?= ["┌─┐1", "│a│2", "│ │3", "└─┘4"]
+ , testCase "stretched frames pass the height on to stretching content" $
+ plainLines (hcat [frame (border normalBorder <> stretchHeight) (render (bg red <> stretchHeight) "a"), text "1\n2\n3\n4"])
+ @?= ["┌─┐1", "│a│2", "│ │3", "└─┘4"]
+ , testCase "place without a width fills the space" $
+ plainLinesAt 5 (place (align center) "x") @?= [" x "]
+ , testCase "place keeps its natural width when there is no limit" $
+ plainLines (place (align center) "x") @?= ["x"]
+ , testCase "a place's width is its width, as a style's" $ do
+ plainLines (place (width 5) "hello world") @?= ["hello", "world"]
+ blockWidth (place (width 5) "hi") @?= 5
+ plainLinesAt 3 (place (width 5) "hi") @?= ["hi "]
+ , testCase "an outline's width is its width, as a style's" $ do
+ plainLines (list (width 8) ["one two three"]) @?= ["• one ", " two ", " three "]
+ blockWidth (list (width 8) ["a"]) @?= 8
+ gridWidth (layout (Just 4) (list (width 8) ["a b"])) @?= 4
+ , testCase "a table fits the width it is given, wrapping its cells" $
+ -- Even the longest words (8 and 9) do not fit side by side in 14
+ -- columns, so the columns shrink widest first below them.
+ plainLinesAt 17 (table mempty ["Name", "Notes"] [["lipstick", "styled text for terminals"]])
+ @?= [ "╭───────┬───────╮"
+ , "│Name │Notes │"
+ , "├───────┼───────┤"
+ , "│lipstic│styled │"
+ , "│k │text │"
+ , "│ │for │"
+ , "│ │termina│"
+ , "│ │ls │"
+ , "╰───────┴───────╯"
+ ]
+ , testCase "columns do not break a word while another column can wrap" $
+ plainLinesAt 15 (table mempty ["Name", "Notes"] [["lipstick", "ab cd ef gh ij kl"]])
+ @?= [ "╭────────┬────╮"
+ , "│Name │Not…│"
+ , "├────────┼────┤"
+ , "│lipstick│ab │"
+ , "│ │cd │"
+ , "│ │ef │"
+ , "│ │gh │"
+ , "│ │ij │"
+ , "│ │kl │"
+ , "╰────────┴────╯"
+ ]
+ , testCase "a long header is cut rather than holding its column wide" $
+ plainLinesAt 15 (table mempty ["A very long header", "B"] [["x", "y"]])
+ @?= ["╭───────────┬─╮", "│A very lon…│B│", "├───────────┼─┤", "│x │y│", "╰───────────┴─╯"]
+ , testCase "a table with fillWidth grows its columns to fill the width" $
+ plainLinesAt 13 (table fillWidth ["a", "b"] [["1", "2"]])
+ @?= ["╭─────┬─────╮", "│a │b │", "├─────┼─────┤", "│1 │2 │", "╰─────┴─────╯"]
+ , testCase "which rows a table shows depends on its width" $ do
+ let rows = [[text (T.pack (show i)), "a few words"] | i <- [0 .. 9 :: Int]]
+ visibleRows Nothing (maxHeight 8) ["N", "What"] rows @?= Just (0, 2)
+ visibleRows (Just 9) (maxHeight 8) ["N", "What"] rows @?= Just (0, 0)
+ , testCase "list items wrap after their enumerator" $
+ plainLinesAt 10 (list mempty ["one two three", "four"])
+ @?= ["• one two ", " three ", "• four "]
+ , testCase "tree items wrap inside their branch" $
+ plainLinesAt 12 (tree mempty (Node "root" [Node "alpha beta gamma" [], Node "delta" []]))
+ @?= ["root ", "├── alpha ", "│ beta ", "│ gamma ", "└── delta "]
+ , testCase "an outline with fillWidth pads to the width" $
+ plainLinesAt 8 (list (fillWidth <> bg red) ["a"]) @?= ["• a "]
+ , testCase "a layer reflows in a narrow canvas" $ do
+ let ls = [layer mempty (text "aaaa bbbb"), layer (offset 2 0 <> layerId "top") "x"]
+ plainLinesAt 6 (compose ls) @?= ["aaxa ", "bbbb "]
+ rectOf <$> findLayer (Just 6) "top" ls @?= Just (2, 0, 1, 1)
+ , testCase "a column aligns blocks that do not grow" $
+ plainLinesAt 8 (joinVertical right [render fillWidth "abc", "d"])
+ @?= ["abc ", " d"]
+ ]
+
+inheritanceTests :: TestTree
+inheritanceTests =
+ testGroup
+ "inherited text settings"
+ [ testCase "a frame aligns the lines of text inside it" $
+ plainLines (frame (align center <> width 9) (text "aa bbbbbbb c"))
+ @?= [" aa ", "bbbbbbb c"]
+ , testCase "render is frame of inline text" $
+ render (align right <> width 8 <> border normalBorder) "ab cd ef"
+ @?~ frame (align right <> width 8 <> border normalBorder) (fromInline "ab cd ef")
+ , testCase "a frame aligns a row as a whole" $
+ plainLines (frame (align center <> width 8) (hcat ["ab", "cd"])) @?= [" abcd "]
+ , testCase "noWrap is inherited" $
+ plainLines (frame (noWrap <> width 6) (frame mempty (text "abcdefgh"))) @?= ["abcde…"]
+ , testCase "unsetNoWrap wraps again inside a noWrap frame" $ do
+ plainLines (frame (noWrap <> width 6) (frame unsetNoWrap (text "abc def"))) @?= ["abc ", "def "]
+ let t m = table (m <> border asciiBorder) [] [["abc def"]]
+ plainLinesAt 5 (frame noWrap (t unsetNoWrap)) @?= plainLinesAt 5 (t mempty)
+ plainLinesAt 5 (frame noWrap (t mempty)) @?= plainLinesAt 5 (t noWrap)
+ , testCase "the nearer setting wins" $
+ plainLines (frame (align right <> width 6) (frame (align left <> width 6) (text "ab"))) @?= ["ab "]
+ , testCase "settings not set are inherited through nested frames" $
+ plainLines (frame (align right <> width 6) (frame (border normalBorder <> width 6) (text "ab")))
+ @?= ["┌────┐", "│ ab│", "└────┘"]
+ , testCase "alignment space gets only the background" $
+ toAnsi defaultRenderEnv (frame (underline <> bg red <> align right <> width 4) (text "ab"))
+ @?= "\ESC[0;41m \ESC[0;4;41mab\ESC[0m"
+ , testCase "underlineSpaces leaves alignment space alone" $
+ toAnsi defaultRenderEnv (frame (underlineSpaces True <> align right <> width 4) (text "a b"))
+ @?= " a\ESC[0;4m \ESC[0mb"
+ , testCase "table cells can hold any block" $
+ plainLines (table (border asciiBorder) ["Name", "Items"] [["fruit", list mempty ["apple", "pear"]]])
+ @?= ["+-----+-------+", "|Name |Items |", "+-----+-------+", "|fruit|• apple|", "| |• pear |", "+-----+-------+"]
+ , testCase "a centred cell centres each of its lines" $
+ plainLinesAt 12 (table (border asciiBorder <> cellStyle (const (align center))) ["x"] [["aa bbbbbbbb"]])
+ @?= ["+----------+", "| x |", "+----------+", "| aa |", "| bbbbbbbb |", "+----------+"]
+ ]
+
+-- | (min, max, weight) for a child of a row.
+newtype Child = Child (Int, Int, Int)
+ deriving (Show)
+
+instance Arbitrary Child where
+ arbitrary = do
+ lo <- chooseInt (0, 12)
+ hi <- (lo +) <$> chooseInt (0, 20)
+ k <- frequency [(2, pure 0), (1, chooseInt (1, 3))]
+ pure (Child (lo, hi, k))
+
+allocateTests :: TestTree
+allocateTests =
+ testGroup
+ "allocate"
+ [ testProperty "matches the table's widest-first fitting" $ \(NonNegative target) ns ->
+ let natural = map getNonNegative ns
+ in allocate target [(min 1 n, n, 1) | n <- natural] === widestFirst target natural
+ , testProperty "spare space goes by weight" $ \cs ->
+ let children = [c | Child c <- cs]
+ his = [hi | (_, hi, _) <- children]
+ in forAll (chooseInt (sum his, sum his + 50)) $ \w ->
+ let ws = allocate w children
+ in conjoin [a >= hi | (a, hi) <- zip ws his]
+ .&&. conjoin [a === hi | (a, (_, hi, 0)) <- zip ws children]
+ .&&. (if any (\(_, _, k) -> k > 0) children then sum ws === w else ws === his)
+ , testProperty "shrinking stays within the bounds and fills the space" $ \cs ->
+ let children = [c | Child c <- cs]
+ los = [lo | (lo, _, _) <- children]
+ his = [hi | (_, hi, _) <- children]
+ in forAll (chooseInt (sum los, sum his)) $ \w ->
+ let ws = allocate w children
+ in sum ws === w .&&. conjoin [lo <= a .&&. a <= hi | (a, lo, hi) <- zip3 ws los his]
+ , testProperty "below the smallest widths, nothing goes under one column" $ \cs ->
+ let children = [c | Child c <- cs]
+ los = [lo | (lo, _, _) <- children]
+ in forAll (chooseInt (0, max 0 (sum los - 1))) $ \w ->
+ let ws = allocate w children
+ in sum ws === max w (sum (map (min 1) los))
+ .&&. conjoin [min 1 lo <= a .&&. a <= lo | (a, lo) <- zip ws los]
+ , testProperty "growing children stay within their limits" $ \cs ->
+ forAll (vectorOf (length cs) (oneof [pure Nothing, Just <$> chooseInt (0, 40)])) $ \limits ->
+ let children = [(lo, hi, k, l) | (Child (lo, hi, k), l) <- zip cs limits]
+ his = [hi | (_, hi, _, _) <- children]
+ room = sum [if k > 0 then maybe 1000 (\lim -> max 0 (lim - hi)) l else 0 | (_, hi, k, l) <- children]
+ in forAll (chooseInt (sum his, sum his + 50)) $ \w ->
+ let ws = allocateWithin w children
+ in conjoin [maybe True (\lim -> a <= max hi lim) l | (a, (_, hi, _, l)) <- zip ws children]
+ .&&. sum ws === min w (sum his + room)
+ , testCase "shrinks the widest first" $ allocate 10 [(1, 8, 0), (1, 3, 0), (1, 6, 0)] @?= [3, 3, 4]
+ , testCase "spare space by weight, left first" $ allocate 10 [(1, 2, 1), (1, 2, 0), (1, 2, 2)] @?= [4, 2, 4]
+ ]
+ where
+ -- How tables fitted their columns before 'allocate': shrink the widest
+ -- column (the leftmost of equals) one step at a time, down to one
+ -- column, or share out spare space evenly from the left.
+ widestFirst target ws
+ | tot > target && any (> 1) ws = widestFirst target (decrementWidest ws)
+ | tot < target && not (null ws) =
+ let (q, r) = (target - tot) `divMod` length ws
+ in [x + q + (if i < r then 1 else 0) | (i, x) <- zip [0 :: Int ..] ws]
+ | otherwise = ws
+ where
+ tot = sum ws
+ decrementWidest xs = case break (== maximum xs) xs of
+ (a, x : b) -> a ++ (x - 1) : b
+ (a, []) -> a
+
+properties :: TestTree
+properties =
+ testGroup
+ "properties"
+ [ testProperty "render is rectangular" $ \spec (Words t) ->
+ rectangular (render (specMod spec) (plain t))
+ , testProperty "width is respected" $ \spec (Words t) ->
+ let b = render (specMod spec) (plain t)
+ (_, ph) = specPadding spec
+ (_, mh) = specMargin spec
+ frameW = 2 * ph + (if specBorder spec then 2 else 0)
+ in case specWidth spec of
+ -- Room for at least one wide character inside the frame.
+ Just w | w - frameW >= 2 -> blockWidth b === w + 2 * mh
+ _ -> property True
+ , testProperty "joinHorizontal is rectangular and adds widths" $ \specs ->
+ let bs = [render (specMod s) "some text" | s <- take 4 specs]
+ j = hcat bs
+ in rectangular j .&&. blockWidth j === sum (map blockWidth bs)
+ , testProperty "joinVertical is rectangular and adds heights" $ \specs ->
+ let bs = [render (specMod s) "some text" | s <- take 4 specs]
+ j = vcat bs
+ in rectangular j .&&. blockHeight j === sum (map blockHeight bs)
+ , testProperty "stripping ANSI gives the plain text" $ \spec (Words t) ->
+ let b = render (specMod spec <> bold <> fg "#123456" <> bg "200" <> link "u") (plain t)
+ in stripAnsi (toAnsi defaultRenderEnv b) === renderPlain b
+ , testProperty "styling pieces of a text does not change its width" $
+ forAll trickyText $ \t -> forAll (styledPieces t) $ \inl ->
+ blockWidth (fromInline inl) === textWidth t
+ .&&. rectangular (render (border roundedBorder <> padding 0 1) inl)
+ , testProperty "maxWidth bounds the width" $ \spec (Words t) (Positive n) ->
+ let b = render (specMod spec <> maxWidth n) (plain t)
+ in rectangular b .&&. blockWidth b <= n
+ ]
diff --git a/test/data/GraphemeBreakTest.txt b/test/data/GraphemeBreakTest.txt
new file mode 100644
--- /dev/null
+++ b/test/data/GraphemeBreakTest.txt
@@ -0,0 +1,1104 @@
+# GraphemeBreakTest-16.0.0.txt
+# Date: 2024-05-02, 15:02:48 GMT
+# © 2024 Unicode®, Inc.
+# Unicode and the Unicode Logo are registered trademarks of Unicode, Inc. in the U.S. and other countries.
+# For terms of use and license, see https://www.unicode.org/terms_of_use.html
+#
+# Unicode Character Database
+# For documentation, see https://www.unicode.org/reports/tr44/
+#
+# Comments after each test line have been removed.
+
+÷ 0020 ÷ 0020 ÷
+÷ 0020 × 0308 ÷ 0020 ÷
+÷ 0020 ÷ 000D ÷
+÷ 0020 × 0308 ÷ 000D ÷
+÷ 0020 ÷ 000A ÷
+÷ 0020 × 0308 ÷ 000A ÷
+÷ 0020 ÷ 0001 ÷
+÷ 0020 × 0308 ÷ 0001 ÷
+÷ 0020 × 200C ÷
+÷ 0020 × 0308 × 200C ÷
+÷ 0020 ÷ 1F1E6 ÷
+÷ 0020 × 0308 ÷ 1F1E6 ÷
+÷ 0020 ÷ 0600 ÷
+÷ 0020 × 0308 ÷ 0600 ÷
+÷ 0020 × 0A03 ÷
+÷ 0020 × 0308 × 0A03 ÷
+÷ 0020 ÷ 1100 ÷
+÷ 0020 × 0308 ÷ 1100 ÷
+÷ 0020 ÷ 1160 ÷
+÷ 0020 × 0308 ÷ 1160 ÷
+÷ 0020 ÷ 11A8 ÷
+÷ 0020 × 0308 ÷ 11A8 ÷
+÷ 0020 ÷ AC00 ÷
+÷ 0020 × 0308 ÷ AC00 ÷
+÷ 0020 ÷ AC01 ÷
+÷ 0020 × 0308 ÷ AC01 ÷
+÷ 0020 × 0903 ÷
+÷ 0020 × 0308 × 0903 ÷
+÷ 0020 ÷ 0904 ÷
+÷ 0020 × 0308 ÷ 0904 ÷
+÷ 0020 ÷ 0D4E ÷
+÷ 0020 × 0308 ÷ 0D4E ÷
+÷ 0020 ÷ 0915 ÷
+÷ 0020 × 0308 ÷ 0915 ÷
+÷ 0020 ÷ 231A ÷
+÷ 0020 × 0308 ÷ 231A ÷
+÷ 0020 × 0300 ÷
+÷ 0020 × 0308 × 0300 ÷
+÷ 0020 × 0900 ÷
+÷ 0020 × 0308 × 0900 ÷
+÷ 0020 × 094D ÷
+÷ 0020 × 0308 × 094D ÷
+÷ 0020 × 200D ÷
+÷ 0020 × 0308 × 200D ÷
+÷ 0020 ÷ 0378 ÷
+÷ 0020 × 0308 ÷ 0378 ÷
+÷ 000D ÷ 0020 ÷
+÷ 000D ÷ 0308 ÷ 0020 ÷
+÷ 000D ÷ 000D ÷
+÷ 000D ÷ 0308 ÷ 000D ÷
+÷ 000D × 000A ÷
+÷ 000D ÷ 0308 ÷ 000A ÷
+÷ 000D ÷ 0001 ÷
+÷ 000D ÷ 0308 ÷ 0001 ÷
+÷ 000D ÷ 200C ÷
+÷ 000D ÷ 0308 × 200C ÷
+÷ 000D ÷ 1F1E6 ÷
+÷ 000D ÷ 0308 ÷ 1F1E6 ÷
+÷ 000D ÷ 0600 ÷
+÷ 000D ÷ 0308 ÷ 0600 ÷
+÷ 000D ÷ 0A03 ÷
+÷ 000D ÷ 0308 × 0A03 ÷
+÷ 000D ÷ 1100 ÷
+÷ 000D ÷ 0308 ÷ 1100 ÷
+÷ 000D ÷ 1160 ÷
+÷ 000D ÷ 0308 ÷ 1160 ÷
+÷ 000D ÷ 11A8 ÷
+÷ 000D ÷ 0308 ÷ 11A8 ÷
+÷ 000D ÷ AC00 ÷
+÷ 000D ÷ 0308 ÷ AC00 ÷
+÷ 000D ÷ AC01 ÷
+÷ 000D ÷ 0308 ÷ AC01 ÷
+÷ 000D ÷ 0903 ÷
+÷ 000D ÷ 0308 × 0903 ÷
+÷ 000D ÷ 0904 ÷
+÷ 000D ÷ 0308 ÷ 0904 ÷
+÷ 000D ÷ 0D4E ÷
+÷ 000D ÷ 0308 ÷ 0D4E ÷
+÷ 000D ÷ 0915 ÷
+÷ 000D ÷ 0308 ÷ 0915 ÷
+÷ 000D ÷ 231A ÷
+÷ 000D ÷ 0308 ÷ 231A ÷
+÷ 000D ÷ 0300 ÷
+÷ 000D ÷ 0308 × 0300 ÷
+÷ 000D ÷ 0900 ÷
+÷ 000D ÷ 0308 × 0900 ÷
+÷ 000D ÷ 094D ÷
+÷ 000D ÷ 0308 × 094D ÷
+÷ 000D ÷ 200D ÷
+÷ 000D ÷ 0308 × 200D ÷
+÷ 000D ÷ 0378 ÷
+÷ 000D ÷ 0308 ÷ 0378 ÷
+÷ 000A ÷ 0020 ÷
+÷ 000A ÷ 0308 ÷ 0020 ÷
+÷ 000A ÷ 000D ÷
+÷ 000A ÷ 0308 ÷ 000D ÷
+÷ 000A ÷ 000A ÷
+÷ 000A ÷ 0308 ÷ 000A ÷
+÷ 000A ÷ 0001 ÷
+÷ 000A ÷ 0308 ÷ 0001 ÷
+÷ 000A ÷ 200C ÷
+÷ 000A ÷ 0308 × 200C ÷
+÷ 000A ÷ 1F1E6 ÷
+÷ 000A ÷ 0308 ÷ 1F1E6 ÷
+÷ 000A ÷ 0600 ÷
+÷ 000A ÷ 0308 ÷ 0600 ÷
+÷ 000A ÷ 0A03 ÷
+÷ 000A ÷ 0308 × 0A03 ÷
+÷ 000A ÷ 1100 ÷
+÷ 000A ÷ 0308 ÷ 1100 ÷
+÷ 000A ÷ 1160 ÷
+÷ 000A ÷ 0308 ÷ 1160 ÷
+÷ 000A ÷ 11A8 ÷
+÷ 000A ÷ 0308 ÷ 11A8 ÷
+÷ 000A ÷ AC00 ÷
+÷ 000A ÷ 0308 ÷ AC00 ÷
+÷ 000A ÷ AC01 ÷
+÷ 000A ÷ 0308 ÷ AC01 ÷
+÷ 000A ÷ 0903 ÷
+÷ 000A ÷ 0308 × 0903 ÷
+÷ 000A ÷ 0904 ÷
+÷ 000A ÷ 0308 ÷ 0904 ÷
+÷ 000A ÷ 0D4E ÷
+÷ 000A ÷ 0308 ÷ 0D4E ÷
+÷ 000A ÷ 0915 ÷
+÷ 000A ÷ 0308 ÷ 0915 ÷
+÷ 000A ÷ 231A ÷
+÷ 000A ÷ 0308 ÷ 231A ÷
+÷ 000A ÷ 0300 ÷
+÷ 000A ÷ 0308 × 0300 ÷
+÷ 000A ÷ 0900 ÷
+÷ 000A ÷ 0308 × 0900 ÷
+÷ 000A ÷ 094D ÷
+÷ 000A ÷ 0308 × 094D ÷
+÷ 000A ÷ 200D ÷
+÷ 000A ÷ 0308 × 200D ÷
+÷ 000A ÷ 0378 ÷
+÷ 000A ÷ 0308 ÷ 0378 ÷
+÷ 0001 ÷ 0020 ÷
+÷ 0001 ÷ 0308 ÷ 0020 ÷
+÷ 0001 ÷ 000D ÷
+÷ 0001 ÷ 0308 ÷ 000D ÷
+÷ 0001 ÷ 000A ÷
+÷ 0001 ÷ 0308 ÷ 000A ÷
+÷ 0001 ÷ 0001 ÷
+÷ 0001 ÷ 0308 ÷ 0001 ÷
+÷ 0001 ÷ 200C ÷
+÷ 0001 ÷ 0308 × 200C ÷
+÷ 0001 ÷ 1F1E6 ÷
+÷ 0001 ÷ 0308 ÷ 1F1E6 ÷
+÷ 0001 ÷ 0600 ÷
+÷ 0001 ÷ 0308 ÷ 0600 ÷
+÷ 0001 ÷ 0A03 ÷
+÷ 0001 ÷ 0308 × 0A03 ÷
+÷ 0001 ÷ 1100 ÷
+÷ 0001 ÷ 0308 ÷ 1100 ÷
+÷ 0001 ÷ 1160 ÷
+÷ 0001 ÷ 0308 ÷ 1160 ÷
+÷ 0001 ÷ 11A8 ÷
+÷ 0001 ÷ 0308 ÷ 11A8 ÷
+÷ 0001 ÷ AC00 ÷
+÷ 0001 ÷ 0308 ÷ AC00 ÷
+÷ 0001 ÷ AC01 ÷
+÷ 0001 ÷ 0308 ÷ AC01 ÷
+÷ 0001 ÷ 0903 ÷
+÷ 0001 ÷ 0308 × 0903 ÷
+÷ 0001 ÷ 0904 ÷
+÷ 0001 ÷ 0308 ÷ 0904 ÷
+÷ 0001 ÷ 0D4E ÷
+÷ 0001 ÷ 0308 ÷ 0D4E ÷
+÷ 0001 ÷ 0915 ÷
+÷ 0001 ÷ 0308 ÷ 0915 ÷
+÷ 0001 ÷ 231A ÷
+÷ 0001 ÷ 0308 ÷ 231A ÷
+÷ 0001 ÷ 0300 ÷
+÷ 0001 ÷ 0308 × 0300 ÷
+÷ 0001 ÷ 0900 ÷
+÷ 0001 ÷ 0308 × 0900 ÷
+÷ 0001 ÷ 094D ÷
+÷ 0001 ÷ 0308 × 094D ÷
+÷ 0001 ÷ 200D ÷
+÷ 0001 ÷ 0308 × 200D ÷
+÷ 0001 ÷ 0378 ÷
+÷ 0001 ÷ 0308 ÷ 0378 ÷
+÷ 200C ÷ 0020 ÷
+÷ 200C × 0308 ÷ 0020 ÷
+÷ 200C ÷ 000D ÷
+÷ 200C × 0308 ÷ 000D ÷
+÷ 200C ÷ 000A ÷
+÷ 200C × 0308 ÷ 000A ÷
+÷ 200C ÷ 0001 ÷
+÷ 200C × 0308 ÷ 0001 ÷
+÷ 200C × 200C ÷
+÷ 200C × 0308 × 200C ÷
+÷ 200C ÷ 1F1E6 ÷
+÷ 200C × 0308 ÷ 1F1E6 ÷
+÷ 200C ÷ 0600 ÷
+÷ 200C × 0308 ÷ 0600 ÷
+÷ 200C × 0A03 ÷
+÷ 200C × 0308 × 0A03 ÷
+÷ 200C ÷ 1100 ÷
+÷ 200C × 0308 ÷ 1100 ÷
+÷ 200C ÷ 1160 ÷
+÷ 200C × 0308 ÷ 1160 ÷
+÷ 200C ÷ 11A8 ÷
+÷ 200C × 0308 ÷ 11A8 ÷
+÷ 200C ÷ AC00 ÷
+÷ 200C × 0308 ÷ AC00 ÷
+÷ 200C ÷ AC01 ÷
+÷ 200C × 0308 ÷ AC01 ÷
+÷ 200C × 0903 ÷
+÷ 200C × 0308 × 0903 ÷
+÷ 200C ÷ 0904 ÷
+÷ 200C × 0308 ÷ 0904 ÷
+÷ 200C ÷ 0D4E ÷
+÷ 200C × 0308 ÷ 0D4E ÷
+÷ 200C ÷ 0915 ÷
+÷ 200C × 0308 ÷ 0915 ÷
+÷ 200C ÷ 231A ÷
+÷ 200C × 0308 ÷ 231A ÷
+÷ 200C × 0300 ÷
+÷ 200C × 0308 × 0300 ÷
+÷ 200C × 0900 ÷
+÷ 200C × 0308 × 0900 ÷
+÷ 200C × 094D ÷
+÷ 200C × 0308 × 094D ÷
+÷ 200C × 200D ÷
+÷ 200C × 0308 × 200D ÷
+÷ 200C ÷ 0378 ÷
+÷ 200C × 0308 ÷ 0378 ÷
+÷ 1F1E6 ÷ 0020 ÷
+÷ 1F1E6 × 0308 ÷ 0020 ÷
+÷ 1F1E6 ÷ 000D ÷
+÷ 1F1E6 × 0308 ÷ 000D ÷
+÷ 1F1E6 ÷ 000A ÷
+÷ 1F1E6 × 0308 ÷ 000A ÷
+÷ 1F1E6 ÷ 0001 ÷
+÷ 1F1E6 × 0308 ÷ 0001 ÷
+÷ 1F1E6 × 200C ÷
+÷ 1F1E6 × 0308 × 200C ÷
+÷ 1F1E6 × 1F1E6 ÷
+÷ 1F1E6 × 0308 ÷ 1F1E6 ÷
+÷ 1F1E6 ÷ 0600 ÷
+÷ 1F1E6 × 0308 ÷ 0600 ÷
+÷ 1F1E6 × 0A03 ÷
+÷ 1F1E6 × 0308 × 0A03 ÷
+÷ 1F1E6 ÷ 1100 ÷
+÷ 1F1E6 × 0308 ÷ 1100 ÷
+÷ 1F1E6 ÷ 1160 ÷
+÷ 1F1E6 × 0308 ÷ 1160 ÷
+÷ 1F1E6 ÷ 11A8 ÷
+÷ 1F1E6 × 0308 ÷ 11A8 ÷
+÷ 1F1E6 ÷ AC00 ÷
+÷ 1F1E6 × 0308 ÷ AC00 ÷
+÷ 1F1E6 ÷ AC01 ÷
+÷ 1F1E6 × 0308 ÷ AC01 ÷
+÷ 1F1E6 × 0903 ÷
+÷ 1F1E6 × 0308 × 0903 ÷
+÷ 1F1E6 ÷ 0904 ÷
+÷ 1F1E6 × 0308 ÷ 0904 ÷
+÷ 1F1E6 ÷ 0D4E ÷
+÷ 1F1E6 × 0308 ÷ 0D4E ÷
+÷ 1F1E6 ÷ 0915 ÷
+÷ 1F1E6 × 0308 ÷ 0915 ÷
+÷ 1F1E6 ÷ 231A ÷
+÷ 1F1E6 × 0308 ÷ 231A ÷
+÷ 1F1E6 × 0300 ÷
+÷ 1F1E6 × 0308 × 0300 ÷
+÷ 1F1E6 × 0900 ÷
+÷ 1F1E6 × 0308 × 0900 ÷
+÷ 1F1E6 × 094D ÷
+÷ 1F1E6 × 0308 × 094D ÷
+÷ 1F1E6 × 200D ÷
+÷ 1F1E6 × 0308 × 200D ÷
+÷ 1F1E6 ÷ 0378 ÷
+÷ 1F1E6 × 0308 ÷ 0378 ÷
+÷ 0600 × 0020 ÷
+÷ 0600 × 0308 ÷ 0020 ÷
+÷ 0600 ÷ 000D ÷
+÷ 0600 × 0308 ÷ 000D ÷
+÷ 0600 ÷ 000A ÷
+÷ 0600 × 0308 ÷ 000A ÷
+÷ 0600 ÷ 0001 ÷
+÷ 0600 × 0308 ÷ 0001 ÷
+÷ 0600 × 200C ÷
+÷ 0600 × 0308 × 200C ÷
+÷ 0600 × 1F1E6 ÷
+÷ 0600 × 0308 ÷ 1F1E6 ÷
+÷ 0600 × 0600 ÷
+÷ 0600 × 0308 ÷ 0600 ÷
+÷ 0600 × 0A03 ÷
+÷ 0600 × 0308 × 0A03 ÷
+÷ 0600 × 1100 ÷
+÷ 0600 × 0308 ÷ 1100 ÷
+÷ 0600 × 1160 ÷
+÷ 0600 × 0308 ÷ 1160 ÷
+÷ 0600 × 11A8 ÷
+÷ 0600 × 0308 ÷ 11A8 ÷
+÷ 0600 × AC00 ÷
+÷ 0600 × 0308 ÷ AC00 ÷
+÷ 0600 × AC01 ÷
+÷ 0600 × 0308 ÷ AC01 ÷
+÷ 0600 × 0903 ÷
+÷ 0600 × 0308 × 0903 ÷
+÷ 0600 × 0904 ÷
+÷ 0600 × 0308 ÷ 0904 ÷
+÷ 0600 × 0D4E ÷
+÷ 0600 × 0308 ÷ 0D4E ÷
+÷ 0600 × 0915 ÷
+÷ 0600 × 0308 ÷ 0915 ÷
+÷ 0600 × 231A ÷
+÷ 0600 × 0308 ÷ 231A ÷
+÷ 0600 × 0300 ÷
+÷ 0600 × 0308 × 0300 ÷
+÷ 0600 × 0900 ÷
+÷ 0600 × 0308 × 0900 ÷
+÷ 0600 × 094D ÷
+÷ 0600 × 0308 × 094D ÷
+÷ 0600 × 200D ÷
+÷ 0600 × 0308 × 200D ÷
+÷ 0600 × 0378 ÷
+÷ 0600 × 0308 ÷ 0378 ÷
+÷ 0A03 ÷ 0020 ÷
+÷ 0A03 × 0308 ÷ 0020 ÷
+÷ 0A03 ÷ 000D ÷
+÷ 0A03 × 0308 ÷ 000D ÷
+÷ 0A03 ÷ 000A ÷
+÷ 0A03 × 0308 ÷ 000A ÷
+÷ 0A03 ÷ 0001 ÷
+÷ 0A03 × 0308 ÷ 0001 ÷
+÷ 0A03 × 200C ÷
+÷ 0A03 × 0308 × 200C ÷
+÷ 0A03 ÷ 1F1E6 ÷
+÷ 0A03 × 0308 ÷ 1F1E6 ÷
+÷ 0A03 ÷ 0600 ÷
+÷ 0A03 × 0308 ÷ 0600 ÷
+÷ 0A03 × 0A03 ÷
+÷ 0A03 × 0308 × 0A03 ÷
+÷ 0A03 ÷ 1100 ÷
+÷ 0A03 × 0308 ÷ 1100 ÷
+÷ 0A03 ÷ 1160 ÷
+÷ 0A03 × 0308 ÷ 1160 ÷
+÷ 0A03 ÷ 11A8 ÷
+÷ 0A03 × 0308 ÷ 11A8 ÷
+÷ 0A03 ÷ AC00 ÷
+÷ 0A03 × 0308 ÷ AC00 ÷
+÷ 0A03 ÷ AC01 ÷
+÷ 0A03 × 0308 ÷ AC01 ÷
+÷ 0A03 × 0903 ÷
+÷ 0A03 × 0308 × 0903 ÷
+÷ 0A03 ÷ 0904 ÷
+÷ 0A03 × 0308 ÷ 0904 ÷
+÷ 0A03 ÷ 0D4E ÷
+÷ 0A03 × 0308 ÷ 0D4E ÷
+÷ 0A03 ÷ 0915 ÷
+÷ 0A03 × 0308 ÷ 0915 ÷
+÷ 0A03 ÷ 231A ÷
+÷ 0A03 × 0308 ÷ 231A ÷
+÷ 0A03 × 0300 ÷
+÷ 0A03 × 0308 × 0300 ÷
+÷ 0A03 × 0900 ÷
+÷ 0A03 × 0308 × 0900 ÷
+÷ 0A03 × 094D ÷
+÷ 0A03 × 0308 × 094D ÷
+÷ 0A03 × 200D ÷
+÷ 0A03 × 0308 × 200D ÷
+÷ 0A03 ÷ 0378 ÷
+÷ 0A03 × 0308 ÷ 0378 ÷
+÷ 1100 ÷ 0020 ÷
+÷ 1100 × 0308 ÷ 0020 ÷
+÷ 1100 ÷ 000D ÷
+÷ 1100 × 0308 ÷ 000D ÷
+÷ 1100 ÷ 000A ÷
+÷ 1100 × 0308 ÷ 000A ÷
+÷ 1100 ÷ 0001 ÷
+÷ 1100 × 0308 ÷ 0001 ÷
+÷ 1100 × 200C ÷
+÷ 1100 × 0308 × 200C ÷
+÷ 1100 ÷ 1F1E6 ÷
+÷ 1100 × 0308 ÷ 1F1E6 ÷
+÷ 1100 ÷ 0600 ÷
+÷ 1100 × 0308 ÷ 0600 ÷
+÷ 1100 × 0A03 ÷
+÷ 1100 × 0308 × 0A03 ÷
+÷ 1100 × 1100 ÷
+÷ 1100 × 0308 ÷ 1100 ÷
+÷ 1100 × 1160 ÷
+÷ 1100 × 0308 ÷ 1160 ÷
+÷ 1100 ÷ 11A8 ÷
+÷ 1100 × 0308 ÷ 11A8 ÷
+÷ 1100 × AC00 ÷
+÷ 1100 × 0308 ÷ AC00 ÷
+÷ 1100 × AC01 ÷
+÷ 1100 × 0308 ÷ AC01 ÷
+÷ 1100 × 0903 ÷
+÷ 1100 × 0308 × 0903 ÷
+÷ 1100 ÷ 0904 ÷
+÷ 1100 × 0308 ÷ 0904 ÷
+÷ 1100 ÷ 0D4E ÷
+÷ 1100 × 0308 ÷ 0D4E ÷
+÷ 1100 ÷ 0915 ÷
+÷ 1100 × 0308 ÷ 0915 ÷
+÷ 1100 ÷ 231A ÷
+÷ 1100 × 0308 ÷ 231A ÷
+÷ 1100 × 0300 ÷
+÷ 1100 × 0308 × 0300 ÷
+÷ 1100 × 0900 ÷
+÷ 1100 × 0308 × 0900 ÷
+÷ 1100 × 094D ÷
+÷ 1100 × 0308 × 094D ÷
+÷ 1100 × 200D ÷
+÷ 1100 × 0308 × 200D ÷
+÷ 1100 ÷ 0378 ÷
+÷ 1100 × 0308 ÷ 0378 ÷
+÷ 1160 ÷ 0020 ÷
+÷ 1160 × 0308 ÷ 0020 ÷
+÷ 1160 ÷ 000D ÷
+÷ 1160 × 0308 ÷ 000D ÷
+÷ 1160 ÷ 000A ÷
+÷ 1160 × 0308 ÷ 000A ÷
+÷ 1160 ÷ 0001 ÷
+÷ 1160 × 0308 ÷ 0001 ÷
+÷ 1160 × 200C ÷
+÷ 1160 × 0308 × 200C ÷
+÷ 1160 ÷ 1F1E6 ÷
+÷ 1160 × 0308 ÷ 1F1E6 ÷
+÷ 1160 ÷ 0600 ÷
+÷ 1160 × 0308 ÷ 0600 ÷
+÷ 1160 × 0A03 ÷
+÷ 1160 × 0308 × 0A03 ÷
+÷ 1160 ÷ 1100 ÷
+÷ 1160 × 0308 ÷ 1100 ÷
+÷ 1160 × 1160 ÷
+÷ 1160 × 0308 ÷ 1160 ÷
+÷ 1160 × 11A8 ÷
+÷ 1160 × 0308 ÷ 11A8 ÷
+÷ 1160 ÷ AC00 ÷
+÷ 1160 × 0308 ÷ AC00 ÷
+÷ 1160 ÷ AC01 ÷
+÷ 1160 × 0308 ÷ AC01 ÷
+÷ 1160 × 0903 ÷
+÷ 1160 × 0308 × 0903 ÷
+÷ 1160 ÷ 0904 ÷
+÷ 1160 × 0308 ÷ 0904 ÷
+÷ 1160 ÷ 0D4E ÷
+÷ 1160 × 0308 ÷ 0D4E ÷
+÷ 1160 ÷ 0915 ÷
+÷ 1160 × 0308 ÷ 0915 ÷
+÷ 1160 ÷ 231A ÷
+÷ 1160 × 0308 ÷ 231A ÷
+÷ 1160 × 0300 ÷
+÷ 1160 × 0308 × 0300 ÷
+÷ 1160 × 0900 ÷
+÷ 1160 × 0308 × 0900 ÷
+÷ 1160 × 094D ÷
+÷ 1160 × 0308 × 094D ÷
+÷ 1160 × 200D ÷
+÷ 1160 × 0308 × 200D ÷
+÷ 1160 ÷ 0378 ÷
+÷ 1160 × 0308 ÷ 0378 ÷
+÷ 11A8 ÷ 0020 ÷
+÷ 11A8 × 0308 ÷ 0020 ÷
+÷ 11A8 ÷ 000D ÷
+÷ 11A8 × 0308 ÷ 000D ÷
+÷ 11A8 ÷ 000A ÷
+÷ 11A8 × 0308 ÷ 000A ÷
+÷ 11A8 ÷ 0001 ÷
+÷ 11A8 × 0308 ÷ 0001 ÷
+÷ 11A8 × 200C ÷
+÷ 11A8 × 0308 × 200C ÷
+÷ 11A8 ÷ 1F1E6 ÷
+÷ 11A8 × 0308 ÷ 1F1E6 ÷
+÷ 11A8 ÷ 0600 ÷
+÷ 11A8 × 0308 ÷ 0600 ÷
+÷ 11A8 × 0A03 ÷
+÷ 11A8 × 0308 × 0A03 ÷
+÷ 11A8 ÷ 1100 ÷
+÷ 11A8 × 0308 ÷ 1100 ÷
+÷ 11A8 ÷ 1160 ÷
+÷ 11A8 × 0308 ÷ 1160 ÷
+÷ 11A8 × 11A8 ÷
+÷ 11A8 × 0308 ÷ 11A8 ÷
+÷ 11A8 ÷ AC00 ÷
+÷ 11A8 × 0308 ÷ AC00 ÷
+÷ 11A8 ÷ AC01 ÷
+÷ 11A8 × 0308 ÷ AC01 ÷
+÷ 11A8 × 0903 ÷
+÷ 11A8 × 0308 × 0903 ÷
+÷ 11A8 ÷ 0904 ÷
+÷ 11A8 × 0308 ÷ 0904 ÷
+÷ 11A8 ÷ 0D4E ÷
+÷ 11A8 × 0308 ÷ 0D4E ÷
+÷ 11A8 ÷ 0915 ÷
+÷ 11A8 × 0308 ÷ 0915 ÷
+÷ 11A8 ÷ 231A ÷
+÷ 11A8 × 0308 ÷ 231A ÷
+÷ 11A8 × 0300 ÷
+÷ 11A8 × 0308 × 0300 ÷
+÷ 11A8 × 0900 ÷
+÷ 11A8 × 0308 × 0900 ÷
+÷ 11A8 × 094D ÷
+÷ 11A8 × 0308 × 094D ÷
+÷ 11A8 × 200D ÷
+÷ 11A8 × 0308 × 200D ÷
+÷ 11A8 ÷ 0378 ÷
+÷ 11A8 × 0308 ÷ 0378 ÷
+÷ AC00 ÷ 0020 ÷
+÷ AC00 × 0308 ÷ 0020 ÷
+÷ AC00 ÷ 000D ÷
+÷ AC00 × 0308 ÷ 000D ÷
+÷ AC00 ÷ 000A ÷
+÷ AC00 × 0308 ÷ 000A ÷
+÷ AC00 ÷ 0001 ÷
+÷ AC00 × 0308 ÷ 0001 ÷
+÷ AC00 × 200C ÷
+÷ AC00 × 0308 × 200C ÷
+÷ AC00 ÷ 1F1E6 ÷
+÷ AC00 × 0308 ÷ 1F1E6 ÷
+÷ AC00 ÷ 0600 ÷
+÷ AC00 × 0308 ÷ 0600 ÷
+÷ AC00 × 0A03 ÷
+÷ AC00 × 0308 × 0A03 ÷
+÷ AC00 ÷ 1100 ÷
+÷ AC00 × 0308 ÷ 1100 ÷
+÷ AC00 × 1160 ÷
+÷ AC00 × 0308 ÷ 1160 ÷
+÷ AC00 × 11A8 ÷
+÷ AC00 × 0308 ÷ 11A8 ÷
+÷ AC00 ÷ AC00 ÷
+÷ AC00 × 0308 ÷ AC00 ÷
+÷ AC00 ÷ AC01 ÷
+÷ AC00 × 0308 ÷ AC01 ÷
+÷ AC00 × 0903 ÷
+÷ AC00 × 0308 × 0903 ÷
+÷ AC00 ÷ 0904 ÷
+÷ AC00 × 0308 ÷ 0904 ÷
+÷ AC00 ÷ 0D4E ÷
+÷ AC00 × 0308 ÷ 0D4E ÷
+÷ AC00 ÷ 0915 ÷
+÷ AC00 × 0308 ÷ 0915 ÷
+÷ AC00 ÷ 231A ÷
+÷ AC00 × 0308 ÷ 231A ÷
+÷ AC00 × 0300 ÷
+÷ AC00 × 0308 × 0300 ÷
+÷ AC00 × 0900 ÷
+÷ AC00 × 0308 × 0900 ÷
+÷ AC00 × 094D ÷
+÷ AC00 × 0308 × 094D ÷
+÷ AC00 × 200D ÷
+÷ AC00 × 0308 × 200D ÷
+÷ AC00 ÷ 0378 ÷
+÷ AC00 × 0308 ÷ 0378 ÷
+÷ AC01 ÷ 0020 ÷
+÷ AC01 × 0308 ÷ 0020 ÷
+÷ AC01 ÷ 000D ÷
+÷ AC01 × 0308 ÷ 000D ÷
+÷ AC01 ÷ 000A ÷
+÷ AC01 × 0308 ÷ 000A ÷
+÷ AC01 ÷ 0001 ÷
+÷ AC01 × 0308 ÷ 0001 ÷
+÷ AC01 × 200C ÷
+÷ AC01 × 0308 × 200C ÷
+÷ AC01 ÷ 1F1E6 ÷
+÷ AC01 × 0308 ÷ 1F1E6 ÷
+÷ AC01 ÷ 0600 ÷
+÷ AC01 × 0308 ÷ 0600 ÷
+÷ AC01 × 0A03 ÷
+÷ AC01 × 0308 × 0A03 ÷
+÷ AC01 ÷ 1100 ÷
+÷ AC01 × 0308 ÷ 1100 ÷
+÷ AC01 ÷ 1160 ÷
+÷ AC01 × 0308 ÷ 1160 ÷
+÷ AC01 × 11A8 ÷
+÷ AC01 × 0308 ÷ 11A8 ÷
+÷ AC01 ÷ AC00 ÷
+÷ AC01 × 0308 ÷ AC00 ÷
+÷ AC01 ÷ AC01 ÷
+÷ AC01 × 0308 ÷ AC01 ÷
+÷ AC01 × 0903 ÷
+÷ AC01 × 0308 × 0903 ÷
+÷ AC01 ÷ 0904 ÷
+÷ AC01 × 0308 ÷ 0904 ÷
+÷ AC01 ÷ 0D4E ÷
+÷ AC01 × 0308 ÷ 0D4E ÷
+÷ AC01 ÷ 0915 ÷
+÷ AC01 × 0308 ÷ 0915 ÷
+÷ AC01 ÷ 231A ÷
+÷ AC01 × 0308 ÷ 231A ÷
+÷ AC01 × 0300 ÷
+÷ AC01 × 0308 × 0300 ÷
+÷ AC01 × 0900 ÷
+÷ AC01 × 0308 × 0900 ÷
+÷ AC01 × 094D ÷
+÷ AC01 × 0308 × 094D ÷
+÷ AC01 × 200D ÷
+÷ AC01 × 0308 × 200D ÷
+÷ AC01 ÷ 0378 ÷
+÷ AC01 × 0308 ÷ 0378 ÷
+÷ 0903 ÷ 0020 ÷
+÷ 0903 × 0308 ÷ 0020 ÷
+÷ 0903 ÷ 000D ÷
+÷ 0903 × 0308 ÷ 000D ÷
+÷ 0903 ÷ 000A ÷
+÷ 0903 × 0308 ÷ 000A ÷
+÷ 0903 ÷ 0001 ÷
+÷ 0903 × 0308 ÷ 0001 ÷
+÷ 0903 × 200C ÷
+÷ 0903 × 0308 × 200C ÷
+÷ 0903 ÷ 1F1E6 ÷
+÷ 0903 × 0308 ÷ 1F1E6 ÷
+÷ 0903 ÷ 0600 ÷
+÷ 0903 × 0308 ÷ 0600 ÷
+÷ 0903 × 0A03 ÷
+÷ 0903 × 0308 × 0A03 ÷
+÷ 0903 ÷ 1100 ÷
+÷ 0903 × 0308 ÷ 1100 ÷
+÷ 0903 ÷ 1160 ÷
+÷ 0903 × 0308 ÷ 1160 ÷
+÷ 0903 ÷ 11A8 ÷
+÷ 0903 × 0308 ÷ 11A8 ÷
+÷ 0903 ÷ AC00 ÷
+÷ 0903 × 0308 ÷ AC00 ÷
+÷ 0903 ÷ AC01 ÷
+÷ 0903 × 0308 ÷ AC01 ÷
+÷ 0903 × 0903 ÷
+÷ 0903 × 0308 × 0903 ÷
+÷ 0903 ÷ 0904 ÷
+÷ 0903 × 0308 ÷ 0904 ÷
+÷ 0903 ÷ 0D4E ÷
+÷ 0903 × 0308 ÷ 0D4E ÷
+÷ 0903 ÷ 0915 ÷
+÷ 0903 × 0308 ÷ 0915 ÷
+÷ 0903 ÷ 231A ÷
+÷ 0903 × 0308 ÷ 231A ÷
+÷ 0903 × 0300 ÷
+÷ 0903 × 0308 × 0300 ÷
+÷ 0903 × 0900 ÷
+÷ 0903 × 0308 × 0900 ÷
+÷ 0903 × 094D ÷
+÷ 0903 × 0308 × 094D ÷
+÷ 0903 × 200D ÷
+÷ 0903 × 0308 × 200D ÷
+÷ 0903 ÷ 0378 ÷
+÷ 0903 × 0308 ÷ 0378 ÷
+÷ 0904 ÷ 0020 ÷
+÷ 0904 × 0308 ÷ 0020 ÷
+÷ 0904 ÷ 000D ÷
+÷ 0904 × 0308 ÷ 000D ÷
+÷ 0904 ÷ 000A ÷
+÷ 0904 × 0308 ÷ 000A ÷
+÷ 0904 ÷ 0001 ÷
+÷ 0904 × 0308 ÷ 0001 ÷
+÷ 0904 × 200C ÷
+÷ 0904 × 0308 × 200C ÷
+÷ 0904 ÷ 1F1E6 ÷
+÷ 0904 × 0308 ÷ 1F1E6 ÷
+÷ 0904 ÷ 0600 ÷
+÷ 0904 × 0308 ÷ 0600 ÷
+÷ 0904 × 0A03 ÷
+÷ 0904 × 0308 × 0A03 ÷
+÷ 0904 ÷ 1100 ÷
+÷ 0904 × 0308 ÷ 1100 ÷
+÷ 0904 ÷ 1160 ÷
+÷ 0904 × 0308 ÷ 1160 ÷
+÷ 0904 ÷ 11A8 ÷
+÷ 0904 × 0308 ÷ 11A8 ÷
+÷ 0904 ÷ AC00 ÷
+÷ 0904 × 0308 ÷ AC00 ÷
+÷ 0904 ÷ AC01 ÷
+÷ 0904 × 0308 ÷ AC01 ÷
+÷ 0904 × 0903 ÷
+÷ 0904 × 0308 × 0903 ÷
+÷ 0904 ÷ 0904 ÷
+÷ 0904 × 0308 ÷ 0904 ÷
+÷ 0904 ÷ 0D4E ÷
+÷ 0904 × 0308 ÷ 0D4E ÷
+÷ 0904 ÷ 0915 ÷
+÷ 0904 × 0308 ÷ 0915 ÷
+÷ 0904 ÷ 231A ÷
+÷ 0904 × 0308 ÷ 231A ÷
+÷ 0904 × 0300 ÷
+÷ 0904 × 0308 × 0300 ÷
+÷ 0904 × 0900 ÷
+÷ 0904 × 0308 × 0900 ÷
+÷ 0904 × 094D ÷
+÷ 0904 × 0308 × 094D ÷
+÷ 0904 × 200D ÷
+÷ 0904 × 0308 × 200D ÷
+÷ 0904 ÷ 0378 ÷
+÷ 0904 × 0308 ÷ 0378 ÷
+÷ 0D4E × 0020 ÷
+÷ 0D4E × 0308 ÷ 0020 ÷
+÷ 0D4E ÷ 000D ÷
+÷ 0D4E × 0308 ÷ 000D ÷
+÷ 0D4E ÷ 000A ÷
+÷ 0D4E × 0308 ÷ 000A ÷
+÷ 0D4E ÷ 0001 ÷
+÷ 0D4E × 0308 ÷ 0001 ÷
+÷ 0D4E × 200C ÷
+÷ 0D4E × 0308 × 200C ÷
+÷ 0D4E × 1F1E6 ÷
+÷ 0D4E × 0308 ÷ 1F1E6 ÷
+÷ 0D4E × 0600 ÷
+÷ 0D4E × 0308 ÷ 0600 ÷
+÷ 0D4E × 0A03 ÷
+÷ 0D4E × 0308 × 0A03 ÷
+÷ 0D4E × 1100 ÷
+÷ 0D4E × 0308 ÷ 1100 ÷
+÷ 0D4E × 1160 ÷
+÷ 0D4E × 0308 ÷ 1160 ÷
+÷ 0D4E × 11A8 ÷
+÷ 0D4E × 0308 ÷ 11A8 ÷
+÷ 0D4E × AC00 ÷
+÷ 0D4E × 0308 ÷ AC00 ÷
+÷ 0D4E × AC01 ÷
+÷ 0D4E × 0308 ÷ AC01 ÷
+÷ 0D4E × 0903 ÷
+÷ 0D4E × 0308 × 0903 ÷
+÷ 0D4E × 0904 ÷
+÷ 0D4E × 0308 ÷ 0904 ÷
+÷ 0D4E × 0D4E ÷
+÷ 0D4E × 0308 ÷ 0D4E ÷
+÷ 0D4E × 0915 ÷
+÷ 0D4E × 0308 ÷ 0915 ÷
+÷ 0D4E × 231A ÷
+÷ 0D4E × 0308 ÷ 231A ÷
+÷ 0D4E × 0300 ÷
+÷ 0D4E × 0308 × 0300 ÷
+÷ 0D4E × 0900 ÷
+÷ 0D4E × 0308 × 0900 ÷
+÷ 0D4E × 094D ÷
+÷ 0D4E × 0308 × 094D ÷
+÷ 0D4E × 200D ÷
+÷ 0D4E × 0308 × 200D ÷
+÷ 0D4E × 0378 ÷
+÷ 0D4E × 0308 ÷ 0378 ÷
+÷ 0915 ÷ 0020 ÷
+÷ 0915 × 0308 ÷ 0020 ÷
+÷ 0915 ÷ 000D ÷
+÷ 0915 × 0308 ÷ 000D ÷
+÷ 0915 ÷ 000A ÷
+÷ 0915 × 0308 ÷ 000A ÷
+÷ 0915 ÷ 0001 ÷
+÷ 0915 × 0308 ÷ 0001 ÷
+÷ 0915 × 200C ÷
+÷ 0915 × 0308 × 200C ÷
+÷ 0915 ÷ 1F1E6 ÷
+÷ 0915 × 0308 ÷ 1F1E6 ÷
+÷ 0915 ÷ 0600 ÷
+÷ 0915 × 0308 ÷ 0600 ÷
+÷ 0915 × 0A03 ÷
+÷ 0915 × 0308 × 0A03 ÷
+÷ 0915 ÷ 1100 ÷
+÷ 0915 × 0308 ÷ 1100 ÷
+÷ 0915 ÷ 1160 ÷
+÷ 0915 × 0308 ÷ 1160 ÷
+÷ 0915 ÷ 11A8 ÷
+÷ 0915 × 0308 ÷ 11A8 ÷
+÷ 0915 ÷ AC00 ÷
+÷ 0915 × 0308 ÷ AC00 ÷
+÷ 0915 ÷ AC01 ÷
+÷ 0915 × 0308 ÷ AC01 ÷
+÷ 0915 × 0903 ÷
+÷ 0915 × 0308 × 0903 ÷
+÷ 0915 ÷ 0904 ÷
+÷ 0915 × 0308 ÷ 0904 ÷
+÷ 0915 ÷ 0D4E ÷
+÷ 0915 × 0308 ÷ 0D4E ÷
+÷ 0915 ÷ 0915 ÷
+÷ 0915 × 0308 ÷ 0915 ÷
+÷ 0915 ÷ 231A ÷
+÷ 0915 × 0308 ÷ 231A ÷
+÷ 0915 × 0300 ÷
+÷ 0915 × 0308 × 0300 ÷
+÷ 0915 × 0900 ÷
+÷ 0915 × 0308 × 0900 ÷
+÷ 0915 × 094D ÷
+÷ 0915 × 0308 × 094D ÷
+÷ 0915 × 200D ÷
+÷ 0915 × 0308 × 200D ÷
+÷ 0915 ÷ 0378 ÷
+÷ 0915 × 0308 ÷ 0378 ÷
+÷ 231A ÷ 0020 ÷
+÷ 231A × 0308 ÷ 0020 ÷
+÷ 231A ÷ 000D ÷
+÷ 231A × 0308 ÷ 000D ÷
+÷ 231A ÷ 000A ÷
+÷ 231A × 0308 ÷ 000A ÷
+÷ 231A ÷ 0001 ÷
+÷ 231A × 0308 ÷ 0001 ÷
+÷ 231A × 200C ÷
+÷ 231A × 0308 × 200C ÷
+÷ 231A ÷ 1F1E6 ÷
+÷ 231A × 0308 ÷ 1F1E6 ÷
+÷ 231A ÷ 0600 ÷
+÷ 231A × 0308 ÷ 0600 ÷
+÷ 231A × 0A03 ÷
+÷ 231A × 0308 × 0A03 ÷
+÷ 231A ÷ 1100 ÷
+÷ 231A × 0308 ÷ 1100 ÷
+÷ 231A ÷ 1160 ÷
+÷ 231A × 0308 ÷ 1160 ÷
+÷ 231A ÷ 11A8 ÷
+÷ 231A × 0308 ÷ 11A8 ÷
+÷ 231A ÷ AC00 ÷
+÷ 231A × 0308 ÷ AC00 ÷
+÷ 231A ÷ AC01 ÷
+÷ 231A × 0308 ÷ AC01 ÷
+÷ 231A × 0903 ÷
+÷ 231A × 0308 × 0903 ÷
+÷ 231A ÷ 0904 ÷
+÷ 231A × 0308 ÷ 0904 ÷
+÷ 231A ÷ 0D4E ÷
+÷ 231A × 0308 ÷ 0D4E ÷
+÷ 231A ÷ 0915 ÷
+÷ 231A × 0308 ÷ 0915 ÷
+÷ 231A ÷ 231A ÷
+÷ 231A × 0308 ÷ 231A ÷
+÷ 231A × 0300 ÷
+÷ 231A × 0308 × 0300 ÷
+÷ 231A × 0900 ÷
+÷ 231A × 0308 × 0900 ÷
+÷ 231A × 094D ÷
+÷ 231A × 0308 × 094D ÷
+÷ 231A × 200D ÷
+÷ 231A × 0308 × 200D ÷
+÷ 231A ÷ 0378 ÷
+÷ 231A × 0308 ÷ 0378 ÷
+÷ 0300 ÷ 0020 ÷
+÷ 0300 × 0308 ÷ 0020 ÷
+÷ 0300 ÷ 000D ÷
+÷ 0300 × 0308 ÷ 000D ÷
+÷ 0300 ÷ 000A ÷
+÷ 0300 × 0308 ÷ 000A ÷
+÷ 0300 ÷ 0001 ÷
+÷ 0300 × 0308 ÷ 0001 ÷
+÷ 0300 × 200C ÷
+÷ 0300 × 0308 × 200C ÷
+÷ 0300 ÷ 1F1E6 ÷
+÷ 0300 × 0308 ÷ 1F1E6 ÷
+÷ 0300 ÷ 0600 ÷
+÷ 0300 × 0308 ÷ 0600 ÷
+÷ 0300 × 0A03 ÷
+÷ 0300 × 0308 × 0A03 ÷
+÷ 0300 ÷ 1100 ÷
+÷ 0300 × 0308 ÷ 1100 ÷
+÷ 0300 ÷ 1160 ÷
+÷ 0300 × 0308 ÷ 1160 ÷
+÷ 0300 ÷ 11A8 ÷
+÷ 0300 × 0308 ÷ 11A8 ÷
+÷ 0300 ÷ AC00 ÷
+÷ 0300 × 0308 ÷ AC00 ÷
+÷ 0300 ÷ AC01 ÷
+÷ 0300 × 0308 ÷ AC01 ÷
+÷ 0300 × 0903 ÷
+÷ 0300 × 0308 × 0903 ÷
+÷ 0300 ÷ 0904 ÷
+÷ 0300 × 0308 ÷ 0904 ÷
+÷ 0300 ÷ 0D4E ÷
+÷ 0300 × 0308 ÷ 0D4E ÷
+÷ 0300 ÷ 0915 ÷
+÷ 0300 × 0308 ÷ 0915 ÷
+÷ 0300 ÷ 231A ÷
+÷ 0300 × 0308 ÷ 231A ÷
+÷ 0300 × 0300 ÷
+÷ 0300 × 0308 × 0300 ÷
+÷ 0300 × 0900 ÷
+÷ 0300 × 0308 × 0900 ÷
+÷ 0300 × 094D ÷
+÷ 0300 × 0308 × 094D ÷
+÷ 0300 × 200D ÷
+÷ 0300 × 0308 × 200D ÷
+÷ 0300 ÷ 0378 ÷
+÷ 0300 × 0308 ÷ 0378 ÷
+÷ 0900 ÷ 0020 ÷
+÷ 0900 × 0308 ÷ 0020 ÷
+÷ 0900 ÷ 000D ÷
+÷ 0900 × 0308 ÷ 000D ÷
+÷ 0900 ÷ 000A ÷
+÷ 0900 × 0308 ÷ 000A ÷
+÷ 0900 ÷ 0001 ÷
+÷ 0900 × 0308 ÷ 0001 ÷
+÷ 0900 × 200C ÷
+÷ 0900 × 0308 × 200C ÷
+÷ 0900 ÷ 1F1E6 ÷
+÷ 0900 × 0308 ÷ 1F1E6 ÷
+÷ 0900 ÷ 0600 ÷
+÷ 0900 × 0308 ÷ 0600 ÷
+÷ 0900 × 0A03 ÷
+÷ 0900 × 0308 × 0A03 ÷
+÷ 0900 ÷ 1100 ÷
+÷ 0900 × 0308 ÷ 1100 ÷
+÷ 0900 ÷ 1160 ÷
+÷ 0900 × 0308 ÷ 1160 ÷
+÷ 0900 ÷ 11A8 ÷
+÷ 0900 × 0308 ÷ 11A8 ÷
+÷ 0900 ÷ AC00 ÷
+÷ 0900 × 0308 ÷ AC00 ÷
+÷ 0900 ÷ AC01 ÷
+÷ 0900 × 0308 ÷ AC01 ÷
+÷ 0900 × 0903 ÷
+÷ 0900 × 0308 × 0903 ÷
+÷ 0900 ÷ 0904 ÷
+÷ 0900 × 0308 ÷ 0904 ÷
+÷ 0900 ÷ 0D4E ÷
+÷ 0900 × 0308 ÷ 0D4E ÷
+÷ 0900 ÷ 0915 ÷
+÷ 0900 × 0308 ÷ 0915 ÷
+÷ 0900 ÷ 231A ÷
+÷ 0900 × 0308 ÷ 231A ÷
+÷ 0900 × 0300 ÷
+÷ 0900 × 0308 × 0300 ÷
+÷ 0900 × 0900 ÷
+÷ 0900 × 0308 × 0900 ÷
+÷ 0900 × 094D ÷
+÷ 0900 × 0308 × 094D ÷
+÷ 0900 × 200D ÷
+÷ 0900 × 0308 × 200D ÷
+÷ 0900 ÷ 0378 ÷
+÷ 0900 × 0308 ÷ 0378 ÷
+÷ 094D ÷ 0020 ÷
+÷ 094D × 0308 ÷ 0020 ÷
+÷ 094D ÷ 000D ÷
+÷ 094D × 0308 ÷ 000D ÷
+÷ 094D ÷ 000A ÷
+÷ 094D × 0308 ÷ 000A ÷
+÷ 094D ÷ 0001 ÷
+÷ 094D × 0308 ÷ 0001 ÷
+÷ 094D × 200C ÷
+÷ 094D × 0308 × 200C ÷
+÷ 094D ÷ 1F1E6 ÷
+÷ 094D × 0308 ÷ 1F1E6 ÷
+÷ 094D ÷ 0600 ÷
+÷ 094D × 0308 ÷ 0600 ÷
+÷ 094D × 0A03 ÷
+÷ 094D × 0308 × 0A03 ÷
+÷ 094D ÷ 1100 ÷
+÷ 094D × 0308 ÷ 1100 ÷
+÷ 094D ÷ 1160 ÷
+÷ 094D × 0308 ÷ 1160 ÷
+÷ 094D ÷ 11A8 ÷
+÷ 094D × 0308 ÷ 11A8 ÷
+÷ 094D ÷ AC00 ÷
+÷ 094D × 0308 ÷ AC00 ÷
+÷ 094D ÷ AC01 ÷
+÷ 094D × 0308 ÷ AC01 ÷
+÷ 094D × 0903 ÷
+÷ 094D × 0308 × 0903 ÷
+÷ 094D ÷ 0904 ÷
+÷ 094D × 0308 ÷ 0904 ÷
+÷ 094D ÷ 0D4E ÷
+÷ 094D × 0308 ÷ 0D4E ÷
+÷ 094D ÷ 0915 ÷
+÷ 094D × 0308 ÷ 0915 ÷
+÷ 094D ÷ 231A ÷
+÷ 094D × 0308 ÷ 231A ÷
+÷ 094D × 0300 ÷
+÷ 094D × 0308 × 0300 ÷
+÷ 094D × 0900 ÷
+÷ 094D × 0308 × 0900 ÷
+÷ 094D × 094D ÷
+÷ 094D × 0308 × 094D ÷
+÷ 094D × 200D ÷
+÷ 094D × 0308 × 200D ÷
+÷ 094D ÷ 0378 ÷
+÷ 094D × 0308 ÷ 0378 ÷
+÷ 200D ÷ 0020 ÷
+÷ 200D × 0308 ÷ 0020 ÷
+÷ 200D ÷ 000D ÷
+÷ 200D × 0308 ÷ 000D ÷
+÷ 200D ÷ 000A ÷
+÷ 200D × 0308 ÷ 000A ÷
+÷ 200D ÷ 0001 ÷
+÷ 200D × 0308 ÷ 0001 ÷
+÷ 200D × 200C ÷
+÷ 200D × 0308 × 200C ÷
+÷ 200D ÷ 1F1E6 ÷
+÷ 200D × 0308 ÷ 1F1E6 ÷
+÷ 200D ÷ 0600 ÷
+÷ 200D × 0308 ÷ 0600 ÷
+÷ 200D × 0A03 ÷
+÷ 200D × 0308 × 0A03 ÷
+÷ 200D ÷ 1100 ÷
+÷ 200D × 0308 ÷ 1100 ÷
+÷ 200D ÷ 1160 ÷
+÷ 200D × 0308 ÷ 1160 ÷
+÷ 200D ÷ 11A8 ÷
+÷ 200D × 0308 ÷ 11A8 ÷
+÷ 200D ÷ AC00 ÷
+÷ 200D × 0308 ÷ AC00 ÷
+÷ 200D ÷ AC01 ÷
+÷ 200D × 0308 ÷ AC01 ÷
+÷ 200D × 0903 ÷
+÷ 200D × 0308 × 0903 ÷
+÷ 200D ÷ 0904 ÷
+÷ 200D × 0308 ÷ 0904 ÷
+÷ 200D ÷ 0D4E ÷
+÷ 200D × 0308 ÷ 0D4E ÷
+÷ 200D ÷ 0915 ÷
+÷ 200D × 0308 ÷ 0915 ÷
+÷ 200D ÷ 231A ÷
+÷ 200D × 0308 ÷ 231A ÷
+÷ 200D × 0300 ÷
+÷ 200D × 0308 × 0300 ÷
+÷ 200D × 0900 ÷
+÷ 200D × 0308 × 0900 ÷
+÷ 200D × 094D ÷
+÷ 200D × 0308 × 094D ÷
+÷ 200D × 200D ÷
+÷ 200D × 0308 × 200D ÷
+÷ 200D ÷ 0378 ÷
+÷ 200D × 0308 ÷ 0378 ÷
+÷ 0378 ÷ 0020 ÷
+÷ 0378 × 0308 ÷ 0020 ÷
+÷ 0378 ÷ 000D ÷
+÷ 0378 × 0308 ÷ 000D ÷
+÷ 0378 ÷ 000A ÷
+÷ 0378 × 0308 ÷ 000A ÷
+÷ 0378 ÷ 0001 ÷
+÷ 0378 × 0308 ÷ 0001 ÷
+÷ 0378 × 200C ÷
+÷ 0378 × 0308 × 200C ÷
+÷ 0378 ÷ 1F1E6 ÷
+÷ 0378 × 0308 ÷ 1F1E6 ÷
+÷ 0378 ÷ 0600 ÷
+÷ 0378 × 0308 ÷ 0600 ÷
+÷ 0378 × 0A03 ÷
+÷ 0378 × 0308 × 0A03 ÷
+÷ 0378 ÷ 1100 ÷
+÷ 0378 × 0308 ÷ 1100 ÷
+÷ 0378 ÷ 1160 ÷
+÷ 0378 × 0308 ÷ 1160 ÷
+÷ 0378 ÷ 11A8 ÷
+÷ 0378 × 0308 ÷ 11A8 ÷
+÷ 0378 ÷ AC00 ÷
+÷ 0378 × 0308 ÷ AC00 ÷
+÷ 0378 ÷ AC01 ÷
+÷ 0378 × 0308 ÷ AC01 ÷
+÷ 0378 × 0903 ÷
+÷ 0378 × 0308 × 0903 ÷
+÷ 0378 ÷ 0904 ÷
+÷ 0378 × 0308 ÷ 0904 ÷
+÷ 0378 ÷ 0D4E ÷
+÷ 0378 × 0308 ÷ 0D4E ÷
+÷ 0378 ÷ 0915 ÷
+÷ 0378 × 0308 ÷ 0915 ÷
+÷ 0378 ÷ 231A ÷
+÷ 0378 × 0308 ÷ 231A ÷
+÷ 0378 × 0300 ÷
+÷ 0378 × 0308 × 0300 ÷
+÷ 0378 × 0900 ÷
+÷ 0378 × 0308 × 0900 ÷
+÷ 0378 × 094D ÷
+÷ 0378 × 0308 × 094D ÷
+÷ 0378 × 200D ÷
+÷ 0378 × 0308 × 200D ÷
+÷ 0378 ÷ 0378 ÷
+÷ 0378 × 0308 ÷ 0378 ÷
+÷ 000D × 000A ÷ 0061 ÷ 000A ÷ 0308 ÷
+÷ 0061 × 0308 ÷
+÷ 0020 × 200D ÷ 0646 ÷
+÷ 0646 × 200D ÷ 0020 ÷
+÷ 1100 × 1100 ÷
+÷ AC00 × 11A8 ÷ 1100 ÷
+÷ AC01 × 11A8 ÷ 1100 ÷
+÷ 1F1E6 × 1F1E7 ÷ 1F1E8 ÷ 0062 ÷
+÷ 0061 ÷ 1F1E6 × 1F1E7 ÷ 1F1E8 ÷ 0062 ÷
+÷ 0061 ÷ 1F1E6 × 1F1E7 × 200D ÷ 1F1E8 ÷ 0062 ÷
+÷ 0061 ÷ 1F1E6 × 200D ÷ 1F1E7 × 1F1E8 ÷ 0062 ÷
+÷ 0061 ÷ 1F1E6 × 1F1E7 ÷ 1F1E8 × 1F1E9 ÷ 0062 ÷
+÷ 0061 × 200D ÷
+÷ 0061 × 0308 ÷ 0062 ÷
+÷ 0061 × 0903 ÷ 0062 ÷
+÷ 0061 ÷ 0600 × 0062 ÷
+÷ 1F476 × 1F3FF ÷ 1F476 ÷
+÷ 0061 × 1F3FF ÷ 1F476 ÷
+÷ 0061 × 1F3FF ÷ 1F476 × 200D × 1F6D1 ÷
+÷ 1F476 × 1F3FF × 0308 × 200D × 1F476 × 1F3FF ÷
+÷ 1F6D1 × 200D × 1F6D1 ÷
+÷ 0061 × 200D ÷ 1F6D1 ÷
+÷ 2701 × 200D × 2701 ÷
+÷ 0061 × 200D ÷ 2701 ÷
+÷ 0915 ÷ 0924 ÷
+÷ 0915 × 094D × 0924 ÷
+÷ 0915 × 094D × 094D × 0924 ÷
+÷ 0915 × 094D × 200D × 0924 ÷
+÷ 0915 × 093C × 200D × 094D × 0924 ÷
+÷ 0915 × 093C × 094D × 200D × 0924 ÷
+÷ 0915 × 094D × 0924 × 094D × 092F ÷
+÷ 0915 × 094D ÷ 0061 ÷
+÷ 0061 × 094D ÷ 0924 ÷
+÷ 003F × 094D ÷ 0924 ÷
+÷ 0915 × 094D × 094D × 0924 ÷