lipstick (empty) → 0.1.0.0
raw patch · 33 files changed
+10044/−0 lines, 33 filesdep +QuickCheckdep +ansi-terminaldep +array
Dependencies added: QuickCheck, ansi-terminal, array, base, bytestring, colour, containers, directory, filepath, lipstick, tasty, tasty-hunit, tasty-quickcheck, terminal-size, text
Files
- CHANGELOG.md +35/−0
- LICENSE +21/−0
- LICENSE.Unicode +49/−0
- README.md +363/−0
- examples/Main.hs +138/−0
- examples/Screenshots.hs +126/−0
- examples/Svg.hs +288/−0
- internal/Lipstick/Internal/Border.hs +81/−0
- internal/Lipstick/Internal/Color.hs +448/−0
- internal/Lipstick/Internal/Grid.hs +329/−0
- internal/Lipstick/Internal/Layout.hs +298/−0
- internal/Lipstick/Internal/Mod.hs +673/−0
- internal/Lipstick/Internal/Types.hs +158/−0
- internal/Lipstick/Internal/UnicodeTable.hs +301/−0
- internal/Lipstick/Internal/Width.hs +200/−0
- lipstick.cabal +156/−0
- scripts/GenUnicodeTable.hs +186/−0
- src/Lipstick.hs +531/−0
- src/Lipstick/Ansi.hs +374/−0
- src/Lipstick/Block.hs +268/−0
- src/Lipstick/Border.hs +53/−0
- src/Lipstick/Color.hs +89/−0
- src/Lipstick/Grid.hs +94/−0
- src/Lipstick/Layer.hs +315/−0
- src/Lipstick/Mod.hs +210/−0
- src/Lipstick/Outline.hs +425/−0
- src/Lipstick/Place.hs +106/−0
- src/Lipstick/Style.hs +554/−0
- src/Lipstick/Table.hs +394/−0
- src/Lipstick/Terminal.hs +232/−0
- src/Lipstick/Width.hs +48/−0
- test/Main.hs +1397/−0
- test/data/GraphemeBreakTest.txt +1104/−0
+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ LICENSE.Unicode view
@@ -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.
+ README.md view
@@ -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+<https://andreabedini.github.io/lipstick/>.++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).
+ examples/Main.hs view
@@ -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"
+ examples/Screenshots.hs view
@@ -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) ++ ")")
+ examples/Svg.hs view
@@ -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 $+ [ "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"" <> num totalW <> "\" height=\"" <> num totalH <> "\" viewBox=\"0 0 " <> num totalW <> " " <> num totalH <> "\">"+ , "<defs><filter id=\"shadow\" x=\"-20%\" y=\"-20%\" width=\"140%\" height=\"150%\"><feDropShadow dx=\"0\" dy=\"6\" stdDeviation=\"8\" flood-color=\"#000\" flood-opacity=\"0.45\"/></filter></defs>"+ , "<rect x=\"" <> num margin <> "\" y=\"" <> num margin <> "\" width=\"" <> num winW <> "\" height=\"" <> num winH <> "\" rx=\"10\" fill=\"" <> windowBg <> "\" filter=\"url(#shadow)\"/>"+ , circle 0 "#FF5F57"+ , circle 1 "#FEBC2E"+ , circle 2 "#28C840"+ , "<g font-family=\"'JetBrains Mono', 'SF Mono', Menlo, Consolas, 'DejaVu Sans Mono', 'Noto Sans Mono CJK SC', monospace\" font-size=\"" <> num fontSize <> "\">"+ ]+ ++ concat [backgrounds row cells | (row, cells) <- rows]+ ++ concat [foregrounds row cells | (row, cells) <- rows]+ ++ ["</g>", "</svg>"]+ 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 =+ "<circle cx=\"" <> 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 =+ [ "<rect x=\"" <> 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 ->+ [ "<text x=\"" <> num x <> "\" y=\"" <> num (y + cellH * 0.76) <> "\" textLength=\"" <> num w <> "\" lengthAdjust=\"spacingAndGlyphs\" fill=\"" <> ink <> "\"" <> opacity <> weight a <> style a <> ">" <> escape (cellText c) <> "</text>"+ ]+ ++ decorations++ wrapG ink opacity inner = "<g stroke=\"" <> ink <> "\" fill=\"" <> ink <> "\"" <> opacity <> ">" <> inner <> "</g>"+ 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 ["<path d=\"M " <> 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 = "<line x1=\"" <> 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 =+ ["<line x1=\"" <> 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 =+ "<line x1=\"" <> 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 "<path d=\"M "+ <> 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+ [ "<rect x=\"" <> 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+ ]
+ internal/Lipstick/Internal/Border.hs view
@@ -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 "-" "-" "|" "|" "|" "|" "|" "|" "|" "|" "|" "|" "|"
+ internal/Lipstick/Internal/Color.hs view
@@ -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+-- <https://bottosson.github.io/posts/oklab/>.+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))
+ internal/Lipstick/Internal/Grid.hs view
@@ -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+ [] -> []
+ internal/Lipstick/Internal/Layout.hs view
@@ -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+ [] -> []
+ internal/Lipstick/Internal/Mod.hs view
@@ -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))
+ internal/Lipstick/Internal/Types.hs view
@@ -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)
+ internal/Lipstick/Internal/UnicodeTable.hs view
@@ -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+ ]
+ internal/Lipstick/Internal/Width.hs view
@@ -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
+ lipstick.cabal view
@@ -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
+ scripts/GenUnicodeTable.hs view
@@ -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
+ src/Lipstick.hs view
@@ -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
+ src/Lipstick/Ansi.hs view
@@ -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
+ src/Lipstick/Block.hs view
@@ -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 [] = []
+ src/Lipstick/Border.hs view
@@ -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
+ src/Lipstick/Color.hs view
@@ -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
+ src/Lipstick/Grid.hs view
@@ -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
+ src/Lipstick/Layer.hs view
@@ -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]
+ src/Lipstick/Mod.hs view
@@ -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
+ src/Lipstick/Outline.hs view
@@ -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")+ ]
+ src/Lipstick/Place.hs view
@@ -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)
+ src/Lipstick/Style.hs view
@@ -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)
+ src/Lipstick/Table.hs view
@@ -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
+ src/Lipstick/Terminal.hs view
@@ -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
+ src/Lipstick/Width.hs view
@@ -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
+ test/Main.hs view
@@ -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+ ]
+ test/data/GraphemeBreakTest.txt view
@@ -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 ÷