layoutz 0.3.4.0 → 0.4.0.0
raw patch · 10 files changed
+4075/−2073 lines, 10 filesdep +containersdep +directorynew-component:exe:ask-demonew-component:exe:raymarcherbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, directory
API changes (from Hackage documentation)
+ Layoutz: KeyEnd :: Key
+ Layoutz: KeyHome :: Key
+ Layoutz: KeyPageDown :: Key
+ Layoutz: KeyPageUp :: Key
+ Layoutz: KittyImage :: [Word8] -> Int -> Int -> Int -> Int -> Int -> String -> Maybe Int -> KittyImage
+ Layoutz: LoaderStyle :: Char -> Char -> String -> String -> String -> Bool -> SpinnerStyle -> Color -> LoaderStyle
+ Layoutz: SpinnerArrow :: SpinnerStyle
+ Layoutz: SpinnerEarth :: SpinnerStyle
+ Layoutz: SpinnerGrow :: SpinnerStyle
+ Layoutz: SpinnerMoon :: SpinnerStyle
+ Layoutz: [kiAlt] :: KittyImage -> String
+ Layoutz: [kiCols] :: KittyImage -> Int
+ Layoutz: [kiFormat] :: KittyImage -> Int
+ Layoutz: [kiIdOverride] :: KittyImage -> Maybe Int
+ Layoutz: [kiPayload] :: KittyImage -> [Word8]
+ Layoutz: [kiPxH] :: KittyImage -> Int
+ Layoutz: [kiPxW] :: KittyImage -> Int
+ Layoutz: [kiRows] :: KittyImage -> Int
+ Layoutz: [lsClose] :: LoaderStyle -> String
+ Layoutz: [lsColor] :: LoaderStyle -> Color
+ Layoutz: [lsEmpty] :: LoaderStyle -> Char
+ Layoutz: [lsFill] :: LoaderStyle -> Char
+ Layoutz: [lsHead] :: LoaderStyle -> String
+ Layoutz: [lsOpen] :: LoaderStyle -> String
+ Layoutz: [lsSmooth] :: LoaderStyle -> Bool
+ Layoutz: [lsSpinner] :: LoaderStyle -> SpinnerStyle
+ Layoutz: askChoose :: String -> [a] -> (a -> String) -> IO (Maybe a)
+ Layoutz: askChooseMany :: String -> [a] -> Int -> (a -> String) -> IO (Maybe [a])
+ Layoutz: askConfirm :: String -> Bool -> String -> String -> IO Bool
+ Layoutz: askFile :: String -> Int -> IO (Maybe String)
+ Layoutz: askFilter :: String -> [a] -> Int -> (a -> String) -> IO (Maybe a)
+ Layoutz: askInput :: String -> String -> String -> IO (Maybe String)
+ Layoutz: askPager :: String -> Int -> Bool -> IO ()
+ Layoutz: askSpin :: String -> SpinnerStyle -> IO a -> IO a
+ Layoutz: askWrite :: String -> String -> String -> String -> IO (Maybe String)
+ Layoutz: banner :: [L] -> L
+ Layoutz: columns :: [L] -> L
+ Layoutz: columns' :: Int -> [L] -> L
+ Layoutz: data KittyImage
+ Layoutz: data LoaderStyle
+ Layoutz: instance Layoutz.Element Layoutz.Columns
+ Layoutz: instance Layoutz.Element Layoutz.KittyImage
+ Layoutz: instance Layoutz.Element Layoutz.Truncated
+ Layoutz: kittyImage :: [Word8] -> Int -> Int -> L
+ Layoutz: kittyImageFile :: FilePath -> Int -> Int -> IO L
+ Layoutz: kittyRGB :: [Word8] -> Int -> Int -> Int -> Int -> L
+ Layoutz: kittyRGBA :: [Word8] -> Int -> Int -> Int -> Int -> L
+ Layoutz: loader :: String -> [a] -> (a -> IO b) -> IO [b]
+ Layoutz: loaderStream :: String -> [a] -> (a -> IO b) -> IO [b]
+ Layoutz: loaderStreamStyled :: LoaderStyle -> String -> [a] -> (a -> IO b) -> IO [b]
+ Layoutz: loaderStyled :: LoaderStyle -> String -> [a] -> (a -> IO b) -> IO [b]
+ Layoutz: loaderStyles :: [LoaderStyle]
+ Layoutz: styleAscii :: LoaderStyle
+ Layoutz: styleBar :: LoaderStyle
+ Layoutz: styleBlocks :: LoaderStyle
+ Layoutz: styleDots :: LoaderStyle
+ Layoutz: styleLine :: LoaderStyle
+ Layoutz: stylePipes :: LoaderStyle
+ Layoutz: truncate' :: Element a => Int -> a -> L
+ Layoutz: truncate'' :: Element a => Int -> String -> a -> L
Files
- CHANGELOG.md +7/−0
- Layoutz.hs +2904/−1826
- README.md +481/−203
- examples/AskDemo.hs +57/−0
- examples/RayMarcher.hs +324/−0
- examples/ShowcaseApp.hs +260/−43
- layoutz.cabal +19/−1
- pix/haskell-kitty-1.png binary
- pix/haskell-kitty-2.png binary
- test/Test.hs +23/−0
CHANGELOG.md view
@@ -4,6 +4,13 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/). +## [0.4.0.0] - 2026-07-12++### Added+- Inline raster images via the kitty graphics protocol: `kittyImage`, `kittyImageFile`, `kittyRGB`, `kittyRGBA`. Images measure exactly `cols`×`rows` cells, so they compose with boxes, rows, tables, etc.+- One-shot `ask*` prompts that collapse to a single line once answered+- Progress `loader`s for wrapping work in build scripts and batch jobs: `loader`, `loaderStream`, and their `*Styled` variants+ ## [0.3.4.0] - 2026-03-31 ### Added
Layoutz.hs view
@@ -7,1830 +7,2908 @@ {- | Module : Layoutz Description : Friendly, expressive print-layout DSL for Haskell-Copyright : (c) 2025 Matthieu Court-License : Apache-2.0--A simple Haskell port of the layoutz library for creating structured terminal layouts.--}--module Layoutz- ( -- * Core Types- Element(..)- , Border(..)- , HasBorder(..)- , Color(..)- , Style(..)- , L- , Tree(..)- -- * Basic Elements- , layout- , text- , br- -- * Layout Functions- , center, center'- , row, tightRow- , underline, underline', underlineColored- , alignLeft, alignRight, alignCenter, justify, wrap- -- * Containers- , box- , statusCard- -- * Widgets- , ul- , ol- , inlineBar- , table- , section, section', section''- , kv- , tree, leaf, branch- -- * Visual Elements- , margin- , hr, hr', hr''- , vr, vr', vr''- , pad- , chart- -- * Spinners- , spinner- , SpinnerStyle(..)- -- * Visualizations- , plotSparkline- , Series(..), plotLine- , Slice(..), plotPie- , BarItem(..), plotBar- , StackedBarGroup(..), plotStackedBar- , HeatmapData(..), plotHeatmap, plotHeatmap'- -- * Border utilities- , withBorder- -- * Color utilities- , withColor- -- * Style utilities- , withStyle- -- * Rendering- , render- , renderText- -- * TUI Runtime- , LayoutzApp(..)- , Key(..)- , Cmd(..)- , cmdFire- , cmdTask- , cmdAfterMs- , executeCmd- , cmdIsExit- , Sub(..)- , AppOptions(..)- , defaultAppOptions- , AppAlignment(..)- , runApp- , runAppFinal- , runAppWith- , runAppWithFinal- , runInline- -- * Subscriptions- , subKeyPress- , subEveryMs- , subBatch- ) where--import Data.List (intercalate, transpose, nub)-import qualified Data.Text-import qualified Data.Text as T-import Data.Bits ((.|.))-import Data.String (IsString(..))-import Data.Char (ord, chr)-import Text.Printf (printf)-import System.IO-import Control.Exception (catch, AsyncException(..))-import System.Timeout (timeout)-import Control.Monad (when, forever)-import Control.Concurrent (forkIO, threadDelay, killThread, newChan, writeChan, readChan)-import Data.IORef (newIORef, readIORef, writeIORef, atomicModifyIORef')---- | Strip ANSI escape codes from a string for accurate width calculation-stripAnsi :: String -> String-stripAnsi [] = []-stripAnsi ('\ESC':'[':rest) = stripAnsi (dropAfterM rest)- where- dropAfterM [] = []- dropAfterM ('m':xs) = xs- dropAfterM (_:xs) = dropAfterM xs-stripAnsi (c:rest) = c : stripAnsi rest---- | Returns width of a character in a monospace terminal: 0 for combining--- characters, 1 for regular characters, 2 for East Asian wide and emoji.-charWidth :: Char -> Int-charWidth c- | c < '\x0300' = 1 -- Fast path for ASCII and common Latin- | c >= '\x0300' && c < '\x0370' = 0 -- Combining diacriticals- | c >= '\x1100' && c < '\x1200' = 2 -- Hangul Jamo- | c >= '\x2E80' && c < '\x9FFF' = 2 -- CJK- | c >= '\xAC00' && c < '\xD7A4' = 2 -- Hangul Syllables- | c >= '\xF900' && c < '\xFB00' = 2 -- CJK Compatibility Ideographs- | c >= '\xFE10' && c < '\xFE20' = 2 -- Vertical forms- | c >= '\xFE30' && c < '\xFE70' = 2 -- CJK Compatibility Forms- | c >= '\xFF00' && c < '\xFF61' = 2 -- Fullwidth Forms- | c >= '\xFFE0' && c < '\xFFE7' = 2 -- Fullwidth symbols- | c >= '\x1F000' = 2 -- Emoji, symbols, supplementary ideographs- | c >= '\x20000' && c < '\x2FFFF' = 2 -- Supplementary ideographs- | c >= '\x30000' && c < '\x3FFFF' = 2 -- Tertiary ideographs- | otherwise = 1---- | Calculate visible width of string (handles ANSI codes, emoji, CJK)-visibleLength :: String -> Int-visibleLength = sum . map charWidth . stripAnsi---- | Apply a function to each line, preserving trailing newlines-mapLines :: (String -> String) -> String -> String-mapLines f str- | null str = str- | otherwise = let ls = lines str- hasTrailingNewline = last str == '\n'- in if hasTrailingNewline- then unlines (map f ls)- else intercalate "\n" (map f ls)---- | Helper: pad a string to a target width on the right (ANSI-aware)-padRight :: Int -> String -> String-padRight targetWidth str = str ++ replicate (max 0 (targetWidth - visibleLength str)) ' '---- | Helper: pad a string to a target width on the left (ANSI-aware)-padLeft :: Int -> String -> String-padLeft targetWidth str = replicate (max 0 (targetWidth - visibleLength str)) ' ' ++ str---- | Helper: center a string within a target width (ANSI-aware)-centerString :: Int -> String -> String-centerString targetWidth str- | len >= targetWidth = str- | otherwise = leftPad ++ str ++ rightPad- where- len = visibleLength str- totalPadding = targetWidth - len- leftPad = replicate (totalPadding `div` 2) ' '- rightPad = replicate (totalPadding - length leftPad) ' '---- | Helper: justify text (spread words evenly to fill width)-justifyString :: Int -> String -> String-justifyString targetWidth str- | len >= targetWidth = str- | length ws <= 1 = str -- Can't justify single word- | otherwise = intercalate "" $ zipWith (++) ws spaces- where- ws = words str- len = length str- wordLengths = sum (map length ws)- totalSpaces = targetWidth - wordLengths- gaps = length ws - 1- baseSpaces = totalSpaces `div` gaps- extraSpaces = totalSpaces `mod` gaps- spaces = replicate extraSpaces (replicate (baseSpaces + 1) ' ')- ++ replicate (gaps - extraSpaces) (replicate baseSpaces ' ')- ++ [""] -- No space after last word---- | Core Element typeclass-class Element a where- renderElement :: a -> String-- -- | Calculate element width (longest line)- width :: a -> Int- width element =- let rendered = renderElement element- renderedLines = lines rendered- in if null renderedLines then 0- else maximum $ 0 : map visibleLength renderedLines-- -- | Calculate element height (number of lines)- height :: a -> Int- height element =- let rendered = renderElement element- in if null rendered then 1- else length (lines rendered)--render :: Element a => a -> String-render = renderElement--renderText :: Element a => a -> Data.Text.Text-renderText = T.pack . renderElement---- | L is the universal layout element type - a type-erased wrapper for the DSL.------ This allows mixing different element types in layouts while providing a common interface.--- Uses existential quantification to store any Element type inside L.------ Constructors:------ * @L a@ - Wraps any Element (Text, Box, Table, etc.)--- * @UL [L]@ - Special case for unordered lists (allows nesting)--- * @AutoCenter L@ - Smart centering that adapts to layout context width--- * @LBox@, @LStatusCard@, @LTable@ - Specialized constructors for bordered elements------ Example usage:------ @--- 'layout' ['text' "title", 'box' "content" [...], 'center' ('text' "footer")]--- @------ All different types unified as L, so they can be composed together.-data L = forall a. Element a => L a- | UL [L]- | OL [L]- | AutoCenter L- | Colored Color L- | Styled Style L- | LBox String [L] Border- | LStatusCard String String Border- | LTable [String] [[L]] Border--instance Element L where- renderElement (L x) = render x- renderElement (UL items) = render (UnorderedList items)- renderElement (OL items) = render (OrderedList items)- renderElement (AutoCenter element) = render element -- Will be handled by Layout- renderElement (Colored color element) = mapLines (wrapAnsi color) (render element)- renderElement (Styled style element) = mapLines (wrapStyle style) (render element)- renderElement (LBox title elements border) = render (Box title elements border)- renderElement (LStatusCard label content border) = render (StatusCard label content border)- renderElement (LTable headers rows border) = render (Table headers rows border)-- width (L x) = width x- width (UL items) = width (UnorderedList items)- width (OL items) = width (OrderedList items)- width (AutoCenter element) = width element- width (Colored _ element) = width element -- Width ignores color- width (Styled _ element) = width element -- Width ignores style- width (LBox title elements border) = width (Box title elements border)- width (LStatusCard label content border) = width (StatusCard label content border)- width (LTable headers rows border) = width (Table headers rows border)-- height (L x) = height x- height (UL items) = height (UnorderedList items)- height (OL items) = height (OrderedList items)- height (AutoCenter element) = height element- height (Colored _ element) = height element -- Height ignores color- height (Styled _ element) = height element -- Height ignores style- height (LBox title elements border) = height (Box title elements border)- height (LStatusCard label content border) = height (StatusCard label content border)- height (LTable headers rows border) = height (Table headers rows border)--instance Show L where- show = render---- | Enable string literals to be used directly as elements with OverloadedStrings------ With OverloadedStrings enabled, you can write @layout [\"Hello\", \"World\"]@--- instead of @layout [text \"Hello\", text \"World\"]@.-instance IsString L where- fromString = text---- | Border styles-data Border- = BorderNormal- | BorderDouble- | BorderThick- | BorderRound- | BorderAscii- | BorderBlock- | BorderDashed- | BorderDotted- | BorderInnerHalfBlock- | BorderOuterHalfBlock- | BorderMarkdown- | BorderCustom String String String -- ^ corner, horizontal, vertical- | BorderNone- deriving (Show, Eq)---- | Typeclass for elements that support customizable borders-class HasBorder a where- -- | Set the border style for an element- setBorder :: Border -> a -> a--instance HasBorder L where- setBorder border (LBox title elements _) = LBox title elements border- setBorder border (LStatusCard label content _) = LStatusCard label content border- setBorder border (LTable headers rows _) = LTable headers rows border- setBorder border (Colored color element) = Colored color (setBorder border element)- setBorder border (Styled style element) = Styled style (setBorder border element)- setBorder _ other = other -- Non-bordered elements remain unchanged---- | Color support with ANSI codes-data Color = ColorDefault | ColorBlack | ColorRed | ColorGreen | ColorYellow- | ColorBlue | ColorMagenta | ColorCyan | ColorWhite- | ColorBrightBlack | ColorBrightRed | ColorBrightGreen | ColorBrightYellow- | ColorBrightBlue | ColorBrightMagenta | ColorBrightCyan | ColorBrightWhite- | ColorFull Int -- ^ 256-color palette (0-255)- | ColorTrue Int Int Int -- ^ 24-bit RGB true color (r, g, b)- deriving (Show, Eq)---- | Get ANSI foreground color code-colorCode :: Color -> String-colorCode ColorDefault = ""-colorCode ColorBlack = "30"-colorCode ColorRed = "31"-colorCode ColorGreen = "32"-colorCode ColorYellow = "33"-colorCode ColorBlue = "34"-colorCode ColorMagenta = "35"-colorCode ColorCyan = "36"-colorCode ColorWhite = "37"-colorCode ColorBrightBlack = "90"-colorCode ColorBrightRed = "91"-colorCode ColorBrightGreen = "92"-colorCode ColorBrightYellow = "93"-colorCode ColorBrightBlue = "94"-colorCode ColorBrightMagenta = "95"-colorCode ColorBrightCyan = "96"-colorCode ColorBrightWhite = "97"-colorCode (ColorFull n) = "38;5;" ++ show (clamp n)-colorCode (ColorTrue r g b) = "38;2;" ++ show (clamp r) ++ ";" ++ show (clamp g) ++ ";" ++ show (clamp b)---- | Clamp value to 0-255 range for color codes-clamp :: Int -> Int-clamp = max 0 . min 255---- | Wrap text with ANSI color codes-wrapAnsi :: Color -> String -> String-wrapAnsi color str- | null (colorCode color) = str- | otherwise = "\ESC[" ++ colorCode color ++ "m" ++ str ++ "\ESC[0m"---- | Style support with ANSI codes-data Style = StyleDefault | StyleBold | StyleDim | StyleItalic | StyleUnderline- | StyleBlink | StyleReverse | StyleHidden | StyleStrikethrough- | StyleCombined [Style] -- ^ Combine multiple styles- deriving (Show, Eq)---- | Combine styles using @<>@-instance Semigroup Style where- StyleDefault <> other = other- other <> StyleDefault = other- StyleCombined styles1 <> StyleCombined styles2 = StyleCombined (styles1 ++ styles2)- StyleCombined styles <> style = StyleCombined (styles ++ [style])- style <> StyleCombined styles = StyleCombined (style : styles)- style1 <> style2 = StyleCombined [style1, style2]--instance Monoid Style where- mempty = StyleDefault---- | Get ANSI style code-styleCode :: Style -> String-styleCode StyleDefault = ""-styleCode StyleBold = "1"-styleCode StyleDim = "2"-styleCode StyleItalic = "3"-styleCode StyleUnderline = "4"-styleCode StyleBlink = "5"-styleCode StyleReverse = "7"-styleCode StyleHidden = "8"-styleCode StyleStrikethrough = "9"-styleCode (StyleCombined styles) =- let codes = filter (not . null) (map styleCode styles)- in if null codes then "" else intercalate ";" codes---- | Wrap text with ANSI style codes-wrapStyle :: Style -> String -> String-wrapStyle style str- | null (styleCode style) = str- | otherwise = "\ESC[" ++ styleCode style ++ "m" ++ str ++ "\ESC[0m"---- | Border character set supporting asymmetric borders (e.g. half-block styles)-data BorderChars = BorderChars- { bcTL, bcTR, bcBL, bcBR :: String -- corners- , bcHTop, bcHBottom :: String -- horizontal (top vs bottom)- , bcVLeft, bcVRight :: String -- vertical (left vs right)- , bcLeftTee, bcRightTee, bcCross :: String -- separator connectors- , bcTopTee, bcBottomTee :: String -- top/bottom column connectors- }---- | Helper for symmetric borders (hTop == hBottom, vLeft == vRight)-mkSymmetric :: String -> String -> String -> String -> String -> String- -> String -> String -> String -> String -> String -> BorderChars-mkSymmetric tl tr bl br' h v lt rt cross tt bt = BorderChars- { bcTL = tl, bcTR = tr, bcBL = bl, bcBR = br'- , bcHTop = h, bcHBottom = h- , bcVLeft = v, bcVRight = v- , bcLeftTee = lt, bcRightTee = rt, bcCross = cross- , bcTopTee = tt, bcBottomTee = bt- }--borderChars :: Border -> BorderChars-borderChars BorderNormal = mkSymmetric "┌" "┐" "└" "┘" "─" "│" "├" "┤" "┼" "┬" "┴"-borderChars BorderDouble = mkSymmetric "╔" "╗" "╚" "╝" "═" "║" "╠" "╣" "╬" "╦" "╩"-borderChars BorderThick = mkSymmetric "┏" "┓" "┗" "┛" "━" "┃" "┣" "┫" "╋" "┳" "┻"-borderChars BorderRound = mkSymmetric "╭" "╮" "╰" "╯" "─" "│" "├" "┤" "┼" "┬" "┴"-borderChars BorderAscii = mkSymmetric "+" "+" "+" "+" "-" "|" "+" "+" "+" "+" "+"-borderChars BorderBlock = mkSymmetric "█" "█" "█" "█" "█" "█" "█" "█" "█" "█" "█"-borderChars BorderDashed = mkSymmetric "┌" "┐" "└" "┘" "╌" "╎" "├" "┤" "┼" "┬" "┴"-borderChars BorderDotted = mkSymmetric "┌" "┐" "└" "┘" "┈" "┊" "├" "┤" "┼" "┬" "┴"-borderChars BorderInnerHalfBlock = BorderChars- { bcTL = "▗", bcTR = "▖", bcBL = "▝", bcBR = "▘"- , bcHTop = "▄", bcHBottom = "▀"- , bcVLeft = "▐", bcVRight = "▌"- , bcLeftTee = "▐", bcRightTee = "▌", bcCross = "▄"- , bcTopTee = "▄", bcBottomTee = "▀"- }-borderChars BorderOuterHalfBlock = BorderChars- { bcTL = "▛", bcTR = "▜", bcBL = "▙", bcBR = "▟"- , bcHTop = "▀", bcHBottom = "▄"- , bcVLeft = "▌", bcVRight = "▐"- , bcLeftTee = "▌", bcRightTee = "▐", bcCross = "▀"- , bcTopTee = "▀", bcBottomTee = "▄"- }-borderChars BorderMarkdown = mkSymmetric "|" "|" "|" "|" "-" "|" "|" "|" "|" "|" "|"-borderChars (BorderCustom corner h v) = mkSymmetric corner corner corner corner h v corner corner corner corner corner-borderChars BorderNone = mkSymmetric " " " " " " " " " " " " " " " " " " " " " "---- Elements-newtype Text = Text String-instance Element Text where renderElement (Text s) = s--data LineBreak = LineBreak-instance Element LineBreak where renderElement _ = ""--data Layout = Layout [L]-instance Element Layout where- renderElement (Layout elements) =- let -- Calculate max width of all non-AutoCenter elements- nonAutoCenterElements = [e | e <- elements, not (isAutoCenter e)]- maxWidth = if null nonAutoCenterElements- then 80 -- fallback- else maximum (0 : map width nonAutoCenterElements)-- -- Render elements, providing context width to AutoCenter elements- renderedElements = map (renderWithContext maxWidth) elements- in intercalate "\n" renderedElements- where- isAutoCenter (AutoCenter _) = True- isAutoCenter _ = False-- renderWithContext contextWidth (AutoCenter element) =- render (Centered (render element) contextWidth)- renderWithContext _ element = render element---- | Centered element with custom width-data Centered = Centered String Int -- content, target_width-instance Element Centered where- renderElement (Centered content targetWidth) =- intercalate "\n" $ map (centerString targetWidth) (lines content)---- | Underlined element with custom character-data Underlined = Underlined String String (Maybe Color) -- content, underline_char, optional color-instance Element Underlined where- renderElement (Underlined content underlineChar maybeColor) =- let contentLines = lines content- maxWidth = if null contentLines then 0- else maximum (map visibleLength contentLines)- repeats = maxWidth `div` length underlineChar- remainder = maxWidth `mod` length underlineChar- underlinePart = concat (replicate repeats underlineChar) ++ take remainder underlineChar- coloredUnderline = maybe underlinePart (`wrapAnsi` underlinePart) maybeColor- in content ++ "\n" ++ coloredUnderline--data Row = Row [L] Bool -- elements, tight (no spacing)-instance Element Row where- renderElement (Row elements tight)- | null elements = ""- | otherwise = intercalate "\n" $ map (intercalate separator) (transpose paddedElements)- where- separator = if tight then "" else " "- elementStrings = map render elements- elementLines = map lines elementStrings- maxHeight = maximum (map length elementLines)- elementWidths = map (maximum . map visibleLength) elementLines- paddedElements = zipWith padElement elementWidths elementLines-- padElement :: Int -> [String] -> [String]- padElement cellWidth linesList =- let currentLines = linesList ++ replicate (maxHeight - length linesList) ""- in map (padRight cellWidth) currentLines---- | Text alignment options-data Alignment = AlignLeft | AlignRight | AlignCenter | Justify- deriving (Show, Eq)---- | Aligned text with specified width and alignment-data AlignedText = AlignedText String Int Alignment -- content, width, alignment-instance Element AlignedText where- renderElement (AlignedText content targetWidth alignment) =- let alignFn = case alignment of- AlignLeft -> padRight targetWidth- AlignRight -> padLeft targetWidth- AlignCenter -> centerString targetWidth- Justify -> justifyString targetWidth- in intercalate "\n" $ map alignFn (lines content)--data Box = Box String [L] Border--instance HasBorder Box where- setBorder border (Box title elements _) = Box title elements border--instance Element Box where- renderElement (Box title elements border) =- let elementStrings = map render elements- content = intercalate "\n" elementStrings- contentLines = if null content then [""] else lines content- contentWidth = maximum (0 : map visibleLength contentLines)- titleWidth = if null title then 0 else visibleLength title + 2- innerWidth = max contentWidth titleWidth- totalWidth = innerWidth + 4- BorderChars{..} = borderChars border- hTopChar = head bcHTop- hBottomChar = head bcHBottom-- topBorder- | null title = bcTL ++ replicate (totalWidth - 2) hTopChar ++ bcTR- | otherwise = let titlePadding = totalWidth - visibleLength title - 2- leftPad = titlePadding `div` 2- rightPad = titlePadding - leftPad- in bcTL ++ replicate leftPad hTopChar ++ title ++ replicate rightPad hTopChar ++ bcTR-- bottomBorder = bcBL ++ replicate (totalWidth - 2) hBottomChar ++ bcBR- paddedContent = map (\line -> bcVLeft ++ " " ++ padRight innerWidth line ++ " " ++ bcVRight) contentLines-- in intercalate "\n" (topBorder : paddedContent ++ [bottomBorder])--data StatusCard = StatusCard String String Border--instance HasBorder StatusCard where- setBorder border (StatusCard label content _) = StatusCard label content border--instance Element StatusCard where- renderElement (StatusCard label content border) =- let labelLines = lines label- contentLines = lines content- allLines = labelLines ++ contentLines- maxWidth = maximum (0 : map visibleLength allLines)- contentWidth = maxWidth + 2- BorderChars{..} = borderChars border- hTopChar = head bcHTop- hBottomChar = head bcHBottom-- topBorder = bcTL ++ replicate (contentWidth + 2) hTopChar ++ bcTR- bottomBorder = bcBL ++ replicate (contentWidth + 2) hBottomChar ++ bcBR- createCardLine line = bcVLeft ++ " " ++ padRight contentWidth line ++ " " ++ bcVRight-- in intercalate "\n" $ [topBorder] ++ map createCardLine allLines ++ [bottomBorder]---- | Margin element that adds prefix to each line-data Margin = Margin String [L] -- prefix, elements-instance Element Margin where- renderElement (Margin prefix elements) =- let content = case elements of- [single] -> render single- _ -> render (Layout elements)- in intercalate "\n" $ map ((prefix ++ " ") ++) (lines content)---- | Horizontal rule with custom character and width-data HorizontalRule = HorizontalRule String Int -- char, width-instance Element HorizontalRule where- renderElement (HorizontalRule char ruleWidth) = concat (replicate ruleWidth char)---- | Vertical rule with custom character and height-data VerticalRule = VerticalRule String Int -- char, height-instance Element VerticalRule where- renderElement (VerticalRule char ruleHeight) = intercalate "\n" (replicate ruleHeight char)---- | Padded element with padding around all sides-data Padded = Padded String Int -- content, padding-instance Element Padded where- renderElement (Padded content padding) =- let contentLines = lines content- maxWidth = maximum (0 : map length contentLines)- horizontalPad = replicate padding ' '- totalWidth = maxWidth + padding * 2- verticalPad = replicate totalWidth ' '- paddedLines = map (\line -> horizontalPad ++ padRight maxWidth line ++ horizontalPad) contentLines- verticalLines = replicate padding verticalPad- in intercalate "\n" (verticalLines ++ paddedLines ++ verticalLines)---- | Chart for data visualization-data Chart = Chart [(String, Double)] -- (label, value) pairs-instance Element Chart where- renderElement (Chart dataPoints)- | null dataPoints = "No data"- | otherwise = intercalate "\n" $ map renderBar dataPoints- where- maxValue = maximum (0 : map snd dataPoints)- maxLabelWidth = minimum [15, maximum (0 : map (length . fst) dataPoints)]- chartWidth = 40-- renderBar :: (String, Double) -> String- renderBar (label, value) =- let truncatedLabel- | length label > maxLabelWidth = take (maxLabelWidth - 3) label ++ "..."- | otherwise = label- paddedLabel = padRight maxLabelWidth truncatedLabel- percentage = value / maxValue- barLength = floor (percentage * fromIntegral chartWidth)- bar = replicate barLength '█' ++ replicate (chartWidth - barLength) '─'- valueStr- | value == fromInteger (round value) = show (round value :: Integer)- | otherwise = printf "%.1f" value- in paddedLabel ++ " │" ++ bar ++ "│ " ++ valueStr---- | Table with headers and borders (fixed alignment)-data Table = Table [String] [[L]] Border -- headers, rows, border--instance HasBorder Table where- setBorder border (Table headers rows _) = Table headers rows border--instance Element Table where- renderElement (Table headers rows border) =- let normalizedRows = map (normalizeRow (length headers)) rows- columnWidths = calculateColumnWidths headers normalizedRows- BorderChars{..} = borderChars border- hTopChar = head bcHTop- hBottomChar = head bcHBottom-- -- Top border- topParts = map (\w -> replicate w hTopChar) columnWidths- topBorder = bcTL ++ [hTopChar] ++ intercalate ([hTopChar] ++ bcTopTee ++ [hTopChar]) topParts ++ [hTopChar] ++ bcTR-- -- Separator (between header and data)- separatorParts = map (\w -> replicate w hTopChar) columnWidths- separatorBorder = bcLeftTee ++ [hTopChar] ++ intercalate ([hTopChar] ++ bcCross ++ [hTopChar]) separatorParts ++ [hTopChar] ++ bcRightTee-- -- Bottom border- bottomParts = map (\w -> replicate w hBottomChar) columnWidths- bottomBorder = bcBL ++ [hBottomChar] ++ intercalate ([hBottomChar] ++ bcBottomTee ++ [hBottomChar]) bottomParts ++ [hBottomChar] ++ bcBR-- -- Header row- headerCells = zipWith padRight columnWidths headers- headerRow = bcVLeft ++ " " ++ intercalate (" " ++ bcVLeft ++ " ") headerCells ++ " " ++ bcVRight-- -- Data rows- dataRows = concatMap (renderTableRow columnWidths bcVLeft bcVRight) normalizedRows-- in intercalate "\n" ([topBorder, headerRow, separatorBorder] ++ dataRows ++ [bottomBorder])- where- normalizeRow :: Int -> [L] -> [L]- normalizeRow expectedLen rowData- | currentLen >= expectedLen = take expectedLen rowData- | otherwise = rowData ++ replicate (expectedLen - currentLen) (text "")- where currentLen = length rowData-- calculateColumnWidths :: [String] -> [[L]] -> [Int]- calculateColumnWidths hdrs rws =- let headerWidths = map visibleLength hdrs- rowWidths = map (map (maximum . (0:) . map visibleLength . lines . render)) rws- allWidths = headerWidths : rowWidths- in map (maximum . (0:)) (transpose allWidths)-- renderTableRow :: [Int] -> String -> String -> [L] -> [String]- renderTableRow widths vLeft vRight rowData =- let cellContents = map render rowData- cellLines = map lines cellContents- maxCellHeight = maximum (1 : map length cellLines)- paddedCells = zipWith (padCell maxCellHeight) widths cellLines- tableRows = transpose paddedCells- in map (\rowCells -> vLeft ++ " " ++ intercalate (" " ++ vLeft ++ " ") rowCells ++ " " ++ vRight) tableRows-- padCell :: Int -> Int -> [String] -> [String]- padCell cellHeight cellWidth cellLines =- let paddedLines = cellLines ++ replicate (cellHeight - length cellLines) ""- in map (padRight cellWidth) paddedLines---- | Section with decorative header-data Section = Section String [L] String Int -- title, content, glyph, flanking_chars-instance Element Section where- renderElement (Section title content glyph flankingChars) =- let header = replicate flankingChars (head glyph) ++ " " ++ title ++ " " ++ replicate flankingChars (head glyph)- body = render (Layout content)- in header ++ "\n" ++ body---- | Key-value pairs with alignment-data KeyValue = KeyValue [(String, String)]-instance Element KeyValue where- renderElement (KeyValue pairs) =- if null pairs then ""- else let maxKeyLength = maximum (map (visibleLength . fst) pairs)- alignmentPosition = maxKeyLength + 2- in intercalate "\n" $ map (renderPair alignmentPosition) pairs- where- renderPair alignPos (key, value) =- let keyWithColon = key ++ ":"- spacesNeeded = alignPos - visibleLength keyWithColon- padding = replicate (max 1 spacesNeeded) ' '- in keyWithColon ++ padding ++ value---- | Tree structure for hierarchical data-data Tree = Tree String [Tree]--instance Element Tree where- renderElement treeData = renderTree treeData "" True []- where- renderTree (Tree name children) prefix isLast parentPrefixes =- let nodeLine = if null parentPrefixes- then name- else prefix ++ (if isLast then "└── " else "├── ") ++ name- childPrefix = if null parentPrefixes- then ""- else prefix ++ (if isLast then " " else "│ ")- childLines = zipWith (\child idx ->- renderTree child childPrefix (idx == length children - 1) (parentPrefixes ++ [not isLast])- ) children [0..]- in if null children- then nodeLine- else nodeLine ++ "\n" ++ intercalate "\n" childLines---newtype UnorderedList = UnorderedList [L]-instance Element UnorderedList where- renderElement (UnorderedList items) = renderAtLevel 0 items- where- bulletStyles = ["•", "◦", "▪"]-- renderAtLevel level itemList =- let currentBullet = bulletStyles !! (level `mod` length bulletStyles)- indent = replicate (level * 2) ' '- in intercalate "\n" $ map (renderItem level indent currentBullet) itemList-- renderItem level indent bullet item = case item of- UL nested -> renderAtLevel (level + 1) nested- _ -> let content = render item- contentLines = lines content- in case contentLines of- [singleLine] -> indent ++ bullet ++ " " ++ singleLine- (firstLine:restLines) ->- let firstOutput = indent ++ bullet ++ " " ++ firstLine- restIndent = replicate (length indent + length bullet + 1) ' '- restOutput = map (restIndent ++) restLines- in intercalate "\n" (firstOutput : restOutput)- [] -> indent ++ bullet ++ " "--newtype OrderedList = OrderedList [L]-instance Element OrderedList where- renderElement (OrderedList items) = renderAtLevel 1 0 items- where- renderAtLevel startNum level itemList =- let indent = replicate (level * 2) ' '- numbered = zip [startNum..] itemList- in intercalate "\n" $ map (renderItem level indent) numbered-- renderItem level indent (num, item) = case item of- OL nested -> renderAtLevel 1 (level + 1) nested- _ -> let numStr = formatNumber level num ++ ". "- content = render item- contentLines = lines content- in case contentLines of- [singleLine] -> indent ++ numStr ++ singleLine- (firstLine:restLines) ->- let firstOutput = indent ++ numStr ++ firstLine- restIndent = replicate (length numStr) ' '- restOutput = map ((indent ++ restIndent) ++) restLines- in intercalate "\n" (firstOutput : restOutput)- [] -> indent ++ numStr-- formatNumber :: Int -> Int -> String- formatNumber lvl num = case lvl `mod` 3 of- 0 -> show num -- 1, 2, 3- 1 -> [toEnum (96 + num)] -- a, b, c- _ -> toRoman num -- i, ii, iii-- toRoman :: Int -> String- toRoman = \case- 1 -> "i"; 2 -> "ii"; 3 -> "iii"; 4 -> "iv"; 5 -> "v"- 6 -> "vi"; 7 -> "vii"; 8 -> "viii"; 9 -> "ix"; 10 -> "x"- n -> show n--data InlineBar = InlineBar String Double-instance Element InlineBar where- renderElement (InlineBar label progress) =- let clampedProgress = max 0.0 (min 1.0 progress)- barWidth = 20- filledSegments = floor (clampedProgress * fromIntegral barWidth)- emptySegments = barWidth - filledSegments- bar = replicate filledSegments '█' ++ replicate emptySegments '─'- percentage = floor (clampedProgress * 100) :: Int- in printf "%s [%s] %d%%" label bar percentage---- Smart constructors and automatic conversions-text :: String -> L-text s = L (Text s)--br :: L-br = L LineBreak--center :: Element a => a -> L-center element = AutoCenter (L element)---- | Center element within specified width-center' :: Element a => Int -> a -> L-center' targetWidth element = L (Centered (render element) targetWidth)--underline :: Element a => a -> L-underline element = L (Underlined (render element) "─" Nothing)---- | Add underline with custom character-underline' :: Element a => String -> a -> L-underline' char element = L (Underlined (render element) char Nothing)---- | Add colored underline with custom character and color------ @--- 'underlineColored' "=" 'ColorRed' $ 'text' "Error Section"--- 'underlineColored' "~" 'ColorGreen' $ 'text' "Success"--- 'underlineColored' "─" 'ColorBrightCyan' $ 'text' "Info"--- @-underlineColored :: Element a => String -> Color -> a -> L-underlineColored char color element = L (Underlined (render element) char (Just color))--ul :: [L] -> L-ul = UL--ol :: [L] -> L-ol = OL--inlineBar :: String -> Double -> L-inlineBar label progress = L (InlineBar label progress)--statusCard :: String -> String -> L-statusCard label content = LStatusCard label content BorderNormal--layout :: [L] -> L-layout elements = L (Layout elements)--row :: [L] -> L-row elements = L (Row elements False)---- | Create horizontal row with no spacing between elements (for gradients, etc.)-tightRow :: [L] -> L-tightRow elements = L (Row elements True)---- | Align text to the left within specified width-alignLeft :: Int -> String -> L-alignLeft targetWidth content = L (AlignedText content targetWidth AlignLeft)---- | Align text to the right within specified width-alignRight :: Int -> String -> L-alignRight targetWidth content = L (AlignedText content targetWidth AlignRight)---- | Align text to the center within specified width-alignCenter :: Int -> String -> L-alignCenter targetWidth content = L (AlignedText content targetWidth AlignCenter)---- | Justify text (spread words evenly to fill width)-justify :: Int -> String -> L-justify targetWidth content = L (AlignedText content targetWidth Justify)---- | Wrap text to multiple lines with specified width-wrap :: Int -> String -> L-wrap targetWidth content =- let ws = words content- wrappedLines = wrapWords targetWidth ws- in layout (map text wrappedLines)- where- wrapWords :: Int -> [String] -> [String]- wrapWords _ [] = []- wrapWords maxWidth wordsList =- let (line, rest) = takeLine maxWidth wordsList- in line : wrapWords maxWidth rest-- takeLine :: Int -> [String] -> (String, [String])- takeLine _ [] = ("", [])- takeLine maxWidth (firstWord:restWords)- | length firstWord > maxWidth = (firstWord, restWords) -- Word too long, put it on its own line- | otherwise = go (length firstWord) [firstWord] restWords- where- go _ acc [] = (unwords (reverse acc), [])- go currentLen acc (nextWord:remainingWords)- | currentLen + 1 + length nextWord <= maxWidth = go (currentLen + 1 + length nextWord) (nextWord:acc) remainingWords- | otherwise = (unwords (reverse acc), nextWord:remainingWords)--box :: String -> [L] -> L-box title elements = LBox title elements BorderNormal---- | Create margin with custom prefix------ @--- 'margin' "[error]" ['text' "Something went wrong"]--- 'margin' "[info]" ['text' "FYI: Check the logs"]--- @-margin :: String -> [L] -> L-margin prefix elements = L (Margin prefix elements)---- | Horizontal rule with default character and width-hr :: L-hr = L (HorizontalRule "─" 50)---- | Horizontal rule with custom character-hr' :: String -> L-hr' char = L (HorizontalRule char 50)---- | Horizontal rule with custom character and width-hr'' :: String -> Int -> L-hr'' char ruleWidth = L (HorizontalRule char ruleWidth)---- | Vertical rule with default character and height-vr :: L-vr = L (VerticalRule "│" 10)---- | Vertical rule with custom character-vr' :: String -> L-vr' char = L (VerticalRule char 10)---- | Vertical rule with custom character and height-vr'' :: String -> Int -> L-vr'' char ruleHeight = L (VerticalRule char ruleHeight)---- | Add padding around element-pad :: Element a => Int -> a -> L-pad padding element = L (Padded (render element) padding)---- | Create horizontal bar chart-chart :: [(String, Double)] -> L-chart dataPoints = L (Chart dataPoints)---- | Create table with headers and rows-table :: [String] -> [[L]] -> L-table headers rows = LTable headers rows BorderNormal---- | Create section with title and content-section :: String -> [L] -> L-section title content = L (Section title content "=" 3)---- | Create section with custom glyph-section' :: String -> String -> [L] -> L-section' glyph title content = L (Section title content glyph 3)---- | Create section with custom glyph and flanking chars-section'' :: String -> String -> Int -> [L] -> L-section'' glyph title flanking content = L (Section title content glyph flanking)---- | Create key-value pairs-kv :: [(String, String)] -> L-kv pairs = L (KeyValue pairs)---- | Apply a border style to elements that support borders------ Elements that support borders: 'box', 'statusCard', 'table'.--- Other elements are returned unchanged.------ @--- withBorder BorderDouble $ table [\"Name\"] [[text \"Alice\"]]--- @-withBorder :: Border -> L -> L-withBorder = setBorder---- | Apply a color to an element------ @--- withColor ColorBrightYellow $ box \"Warning\" [text "Check logs"]--- @-withColor :: Color -> L -> L-withColor = Colored---- | Apply a style to an element------ @--- withStyle StyleBold $ text "Important!"--- @-withStyle :: Style -> L -> L-withStyle = Styled---- | Create tree structure-tree :: String -> [Tree] -> L-tree name children = L (Tree name children)---- | Create leaf tree node (no children)-leaf :: String -> Tree-leaf name = Tree name []---- | Create branch tree node with children-branch :: String -> [Tree] -> Tree-branch name children = Tree name children---- ============================================================================--- Spinner Animations--- ============================================================================---- | Spinner style with animation frames-data SpinnerStyle- = SpinnerDots- | SpinnerLine- | SpinnerClock- | SpinnerBounce- deriving (Show, Eq)---- | Get animation frames for a spinner style-spinnerFrames :: SpinnerStyle -> [String]-spinnerFrames SpinnerDots = ["⠋", "⠙", "⠹", "⠸", "⠼", "⠴", "⠦", "⠧", "⠇", "⠏"]-spinnerFrames SpinnerLine = ["|", "/", "-", "\\"]-spinnerFrames SpinnerClock = ["🕐", "🕑", "🕒", "🕓", "🕔", "🕕", "🕖", "🕗", "🕘", "🕙", "🕚", "🕛"]-spinnerFrames SpinnerBounce = ["⠁", "⠂", "⠄", "⠂"]---- | Spinner animation element-data Spinner = Spinner String Int SpinnerStyle -- label, frame, style--instance Element Spinner where- renderElement (Spinner label frame style) =- let frames = spinnerFrames style- spinChar = frames !! (frame `mod` length frames)- in if null label- then spinChar- else spinChar ++ " " ++ label---- | Create an animated spinner------ Example usage:------ @--- 'spinner' \"Loading\" 5 'SpinnerDots' -- Shows the 5th frame of dots spinner--- 'spinner' \"Processing\" 0 'SpinnerLine' -- Shows first frame with label--- @------ Increment the frame number each render to animate:------ @--- 'layout' ['spinner' \"Working\" (tickCount \`mod\` 10) 'SpinnerDots']--- @-spinner :: String -> Int -> SpinnerStyle -> L-spinner label frame style = L (Spinner label frame style)---- ============================================================================--- Visualization Primitives--- ============================================================================---- | Block characters for sparklines and bar charts (indices 0–8)-blockChars :: String-blockChars = " ▁▂▃▄▅▆▇█"---- | Braille dot bit flag for position (row 0–3, col 0–1) in a 2×4 braille cell-brailleDot :: Int -> Int -> Int-brailleDot 0 0 = 0x01-brailleDot 1 0 = 0x02-brailleDot 2 0 = 0x04-brailleDot 3 0 = 0x40-brailleDot 0 1 = 0x08-brailleDot 1 1 = 0x10-brailleDot 2 1 = 0x20-brailleDot 3 1 = 0x80-brailleDot _ _ = 0---- | Default color palette for cycling through series/slices-defaultPalette :: [Color]-defaultPalette = [ ColorBrightCyan, ColorBrightMagenta, ColorBrightYellow- , ColorBrightGreen, ColorBrightRed, ColorBrightBlue ]---- | Use explicit color if not ColorDefault, else cycle palette by index-pickColor :: Int -> Color -> Color-pickColor idx ColorDefault = defaultPalette !! (idx `mod` length defaultPalette)-pickColor _ c = c---- | Format number for axis labels: "3" for integers, "3.5" for decimals-formatAxisNum :: Double -> String-formatAxisNum v- | v == fromInteger (round v) = show (round v :: Integer)- | otherwise = printf "%.1f" v---- | ANSI 256-color background escape sequence-bgColor256 :: Int -> String-bgColor256 n = "\ESC[48;5;" ++ show n ++ "m"---- | ANSI reset sequence-ansiReset :: String-ansiReset = "\ESC[0m"---- Sparkline ----------------------------------------------------data SparklineData = SparklineData [Double]--instance Element SparklineData where- renderElement (SparklineData []) = ""- renderElement (SparklineData vals) =- let mn = minimum vals- mx = maximum vals- rng = mx - mn- idx v | rng == 0 = 4- | otherwise = max 1 $ min 8 $ floor ((v - mn) / rng * 8)- in map (\v -> blockChars !! idx v) vals---- | Create a sparkline from a list of values-plotSparkline :: [Double] -> L-plotSparkline = L . SparklineData---- Line Plot (Braille) ------------------------------------------------------ | A data series for line plots: points, label, color-data Series = Series [(Double, Double)] String Color--data PlotData = PlotData [Series] Int Int -- series, width, height--instance Element PlotData where- renderElement (PlotData ss w h)- | null ss || all (\(Series ps _ _) -> null ps) ss = "No data"- | otherwise =- let allPts = concatMap (\(Series ps _ _) -> ps) ss- (xs, ys) = unzip allPts- xMin = minimum xs; xMax = maximum xs- yMin = minimum ys; yMax = maximum ys- xRng = if xMax == xMin then 1.0 else xMax - xMin- yRng = if yMax == yMin then 1.0 else yMax - yMin- pxW = w * 2; pxH = h * 4-- toPixel (x, y) =- ( clampI 0 (pxW - 1) $ round ((x - xMin) / xRng * fromIntegral (pxW - 1))- , clampI 0 (pxH - 1) $ round ((yMax - y) / yRng * fromIntegral (pxH - 1))- )- clampI lo hi = max lo . min hi-- emptyGrid = replicate h (replicate w (0 :: Int, -1 :: Int))-- plotSeries grd sIdx (Series ps _ _) =- foldl (\g p ->- let (px, py) = toPixel p- cx = px `div` 2; cy = py `div` 4- dx = px `mod` 2; dy = py `mod` 4- bit = brailleDot dy dx- in updGrid cy cx (\(b, si) -> (b .|. bit, if si < 0 then sIdx else si)) g- ) grd ps-- updGrid r c f g =- [ if ri == r- then [ if ci == c then f cell else cell | (ci, cell) <- zip [0..] row' ]- else row'- | (ri, row') <- zip [0..] g ]-- grid = foldl (\g (i, s) -> plotSeries g i s) emptyGrid (zip [0..] ss)-- yTicks = [ yMax - yRng * fromIntegral i / fromIntegral (max 1 (h - 1)) | i <- [0 .. h-1] ]- yLabels = map formatAxisNum yTicks- yLabelW = maximum (0 : map length yLabels)-- gridLines = zipWith (\yLbl row' ->- padLeft yLabelW yLbl ++ " │" ++- concatMap (\(bits, si) ->- let ch = if bits == 0 then ' ' else chr (0x2800 + bits)- c = if si >= 0 then pickColor si (sColor (ss !! si)) else ColorDefault- in if c == ColorDefault then [ch] else wrapAnsi c [ch]- ) row'- ) yLabels grid-- xAxis = replicate (yLabelW + 2) ' ' ++ replicate w '─'- xMinL = formatAxisNum xMin- xMaxL = formatAxisNum xMax- xLabels = replicate (yLabelW + 2) ' ' ++ xMinL- ++ replicate (max 1 (w - length xMinL - length xMaxL)) ' '- ++ xMaxL-- legend- | length ss <= 1 = []- | otherwise = ["", intercalate " " $- zipWith (\i (Series _ nm cl) ->- wrapAnsi (pickColor i cl) "●" ++ " " ++ nm- ) [0..] ss]-- in intercalate "\n" (gridLines ++ [xAxis, xLabels] ++ legend)- where sColor (Series _ _ c) = c---- | Create a braille line plot-plotLine :: Int -> Int -> [Series] -> L-plotLine w h ss = L (PlotData ss w h)---- Pie Chart (Braille) ------------------------------------------------------ | A slice of a pie chart: value, label, color-data Slice = Slice Double String Color--data PieData = PieData [Slice] Int Int--instance Element PieData where- renderElement (PieData [] _ _) = "No data"- renderElement (PieData slices w h) =- let total = sum [ v | Slice v _ _ <- slices ]- cumAngs = scanl (+) 0 [ v / total * 2 * pi | Slice v _ _ <- slices ]-- cxF = fromIntegral w :: Double- cyF = fromIntegral (h * 4) / 2.0 :: Double- radius = min cxF (cyF * 0.9)-- findSlice ang = go 0 (tail cumAngs)- where go i [] = max 0 (i - 1)- go i (a:as') = if ang < a then i else go (i + 1) as'-- renderCell gcx gcy =- let subPx = [ (dy, dx, dist, nAng)- | dy <- [0..3], dx <- [0..1]- , let dpx = fromIntegral (gcx * 2 + dx) :: Double- dpy = fromIntegral (gcy * 4 + dy) :: Double- relX = dpx - cxF- relY = (dpy - cyF) * 2.0- dist = sqrt (relX * relX + relY * relY)- ang = atan2 relY relX- nAng = if ang < 0 then ang + 2 * pi else ang- ]- inside = [ (dy, dx, nAng) | (dy, dx, dist, nAng) <- subPx, dist <= radius ]- bits = foldl (\acc (dy, dx, _) -> acc .|. brailleDot dy dx) 0 inside- domSi = case inside of- [] -> -1- ((_, _, a):_) -> findSlice a- ch = if bits == 0 then ' ' else chr (0x2800 + bits)- color = if domSi >= 0 && domSi < length slices- then pickColor domSi (slColor (slices !! domSi))- else ColorDefault- in if bits == 0 then " " else wrapAnsi color [ch]-- gridLines = [ concatMap (\gcx -> renderCell gcx gcy) [0..w-1] | gcy <- [0..h-1] ]-- legendLines = zipWith (\i (Slice v nm cl) ->- let c = pickColor i cl- pct = printf "%.0f" (v / total * 100) :: String- in " " ++ wrapAnsi c "●" ++ " " ++ nm ++ " (" ++ pct ++ "%)"- ) [0..] slices-- in intercalate "\n" (gridLines ++ [""] ++ legendLines)- where slColor (Slice _ _ c) = c---- | Create a braille pie chart-plotPie :: Int -> Int -> [Slice] -> L-plotPie w h sl = L (PieData sl w h)---- Bar Chart (Vertical) ------------------------------------------------------------ | A bar item: value, label, color-data BarItem = BarItem Double String Color--data BarChartData = BarChartData [BarItem] Int Int--instance Element BarChartData where- renderElement (BarChartData [] _ _) = "No data"- renderElement (BarChartData items w h) =- let maxVal = maximum [ v | BarItem v _ _ <- items ]- nBars = length items- barW = max 1 $ (w - nBars + 1) `div` nBars- totalSub = h * 8- barHts = [ round (v / maxVal * fromIntegral totalSub) :: Int | BarItem v _ _ <- items ]-- yTicks = [ maxVal * fromIntegral (h - 1 - i) / fromIntegral (max 1 (h - 1)) | i <- [0..h-1] ]- yLabels = map formatAxisNum yTicks- yLabelW = maximum (0 : map length yLabels)-- gridLines =- [ let r = h - 1 - rowIdx- barCells = intercalate " " $- map (\(i, (bh, BarItem _ _ cl)) ->- let filled = min 8 $ max 0 (bh - r * 8)- color' = pickColor i cl- barStr = replicate barW (blockChars !! filled)- in if filled > 0 then wrapAnsi color' barStr else barStr- ) (zip [0..] (zip barHts items))- in padLeft yLabelW (yLabels !! rowIdx) ++ " │" ++ barCells- | rowIdx <- [0..h-1]- ]-- xAxisW = nBars * barW + nBars - 1- xAxis = replicate (yLabelW + 2) ' ' ++ replicate xAxisW '─'- barLabels = replicate (yLabelW + 2) ' ' ++- intercalate " " [ take barW (nm ++ replicate barW ' ') | BarItem _ nm _ <- items ]-- in intercalate "\n" (gridLines ++ [xAxis, barLabels])---- | Create a vertical bar chart-plotBar :: Int -> Int -> [BarItem] -> L-plotBar w h items = L (BarChartData items w h)---- Stacked Bar Chart ----------------------------------------------------------- | A group of stacked bars: segments and group label-data StackedBarGroup = StackedBarGroup [BarItem] String--data StackedBarChartData = StackedBarChartData [StackedBarGroup] Int Int--instance Element StackedBarChartData where- renderElement (StackedBarChartData [] _ _) = "No data"- renderElement (StackedBarChartData groups w h) =- let maxTotal = maximum [ sum [ v | BarItem v _ _ <- segs ] | StackedBarGroup segs _ <- groups ]- nGroups = length groups- barW = max 1 $ (w - nGroups + 1) `div` nGroups- totalSub = h * 8-- groupBounds = map (\(StackedBarGroup segs _) ->- let vals = [ v | BarItem v _ _ <- segs ]- subHts = map (\v -> round (v / maxTotal * fromIntegral totalSub) :: Int) vals- cumHts = scanl (+) 0 subHts- bottoms = init cumHts- tops = tail cumHts- in zip segs (zip bottoms tops)- ) groups-- allLabels = nub [ nm | StackedBarGroup segs _ <- groups, BarItem _ nm _ <- segs ]- labelIdx nm = case lookup nm (zip allLabels [0..]) of- Just i -> i- Nothing -> 0-- yTicks = [ maxTotal * fromIntegral (h - 1 - i) / fromIntegral (max 1 (h - 1)) | i <- [0..h-1] ]- yLabels = map formatAxisNum yTicks- yLabelW = maximum (0 : map length yLabels)-- gridLines =- [ let r = h - 1 - rowIdx- subBot = r * 8- subTop = r * 8 + 8- barCells = intercalate " " $- map (\bounds ->- let overlapping = [ (bi, bot, top)- | (bi, (bot, top)) <- bounds- , top > subBot, bot < subTop ]- topSeg = case overlapping of- [] -> Nothing- _ -> Just $ foldl1 (\a@(_, _, t1) b@(_, _, t2) ->- if t2 > t1 then b else a) overlapping- in case topSeg of- Nothing -> replicate barW ' '- Just (BarItem _ nm cl, _, top) ->- let filled = min 8 $ max 0 (top - subBot)- color' = case cl of- ColorDefault -> pickColor (labelIdx nm) ColorDefault- _ -> cl- barStr = replicate barW (blockChars !! filled)- in if filled > 0 then wrapAnsi color' barStr else barStr- ) groupBounds- in padLeft yLabelW (yLabels !! rowIdx) ++ " │" ++ barCells- | rowIdx <- [0..h-1]- ]-- xAxisW = nGroups * barW + nGroups - 1- xAxis = replicate (yLabelW + 2) ' ' ++ replicate xAxisW '─'- grpLabels = replicate (yLabelW + 2) ' ' ++- intercalate " " [ take barW (nm ++ replicate barW ' ')- | StackedBarGroup _ nm <- groups ]-- legendItems = map (\nm ->- let i = labelIdx nm- c = defaultPalette !! (i `mod` length defaultPalette)- in wrapAnsi c "█" ++ " " ++ nm- ) allLabels- legendLine- | length allLabels <= 1 = []- | otherwise = ["", intercalate " " legendItems]-- in intercalate "\n" (gridLines ++ [xAxis, grpLabels] ++ legendLine)---- | Create a stacked vertical bar chart-plotStackedBar :: Int -> Int -> [StackedBarGroup] -> L-plotStackedBar w h groups = L (StackedBarChartData groups w h)---- Heatmap --------------------------------------------------------------- | Heatmap data: grid of values, row labels, column labels-data HeatmapData = HeatmapData [[Double]] [String] [String]--data HeatmapElement = HeatmapElement HeatmapData Int -- data, cellWidth--instance Element HeatmapElement where- renderElement (HeatmapElement (HeatmapData [] _ _) _) = "No data"- renderElement (HeatmapElement (HeatmapData grid rowLbls colLbls) cellW) =- let allVals = concat grid- mn = minimum allVals- mx = maximum allVals- rng = if mx == mn then 1.0 else mx - mn- normalize v = (v - mn) / rng-- toColor256 :: Double -> Int- toColor256 t- | t <= 0.0 = 21- | t >= 1.0 = 196- | t < 0.25 = let s = t / 0.25 in round (21.0 + s * 30.0)- | t < 0.5 = let s = (t-0.25)/0.25 in round (51.0 + s * (-5.0))- | t < 0.75 = let s = (t-0.5)/0.25 in round (46.0 + s * 180.0)- | otherwise = let s = (t-0.75)/0.25 in round (226.0 + s * (-30.0))-- rowLblW = maximum (0 : map length rowLbls)-- header = replicate (rowLblW + 1) ' ' ++- intercalate " " (map (\l -> padRight cellW (take cellW l)) colLbls)-- dataRows = zipWith (\lbl rowVals ->- padRight rowLblW (take rowLblW lbl) ++ " " ++- intercalate " " (map (\v ->- let n = normalize v- c256 = toColor256 n- vs = formatAxisNum v- in bgColor256 c256 ++ padRight cellW (take cellW vs) ++ ansiReset- ) rowVals)- ) rowLbls grid-- legendCs = map (\i -> toColor256 (fromIntegral i / 10.0)) [0..10 :: Int]- legendBar = concatMap (\c -> bgColor256 c ++ " " ++ ansiReset) legendCs- legendLine = replicate (rowLblW + 1) ' ' ++- formatAxisNum mn ++ " " ++ legendBar ++ " " ++ formatAxisNum mx-- in intercalate "\n" ([header] ++ dataRows ++ ["", legendLine])---- | Create a heatmap with default cell width (6)-plotHeatmap :: HeatmapData -> L-plotHeatmap dat = L (HeatmapElement dat 6)---- | Create a heatmap with custom cell width-plotHeatmap' :: Int -> HeatmapData -> L-plotHeatmap' cellW dat = L (HeatmapElement dat cellW)---- ============================================================================--- TUI Runtime - Simple event loop for interactive terminal applications--- ============================================================================---- | Keyboard input representation-data Key- = KeyChar Char -- ^ Regular character keys: 'a', '1', ' ', etc.- | KeyCtrl Char -- ^ Ctrl+key: KeyCtrl 'C', KeyCtrl 'Q', etc.- | KeyEnter -- ^ Enter/Return key- | KeyBackspace -- ^ Backspace key- | KeyTab -- ^ Tab key- | KeyEscape -- ^ Escape key- | KeyDelete -- ^ Delete key- | KeyUp -- ^ Up arrow- | KeyDown -- ^ Down arrow- | KeyLeft -- ^ Left arrow- | KeyRight -- ^ Right arrow- | KeySpecial String -- ^ Other unrecognized escape sequences- deriving (Show, Eq)---- | Commands - side effects the runtime will execute after each update-data Cmd msg- = CmdNone -- ^ No effect- | CmdRun (IO (Maybe msg)) -- ^ Run IO, optionally produce a message- | CmdBatch [Cmd msg] -- ^ Combine multiple commands- | CmdExit -- ^ Gracefully quit the application---- | Create a command from an IO action (fire and forget)-cmdFire :: IO () -> Cmd msg-cmdFire io = CmdRun (io >> pure Nothing)---- | Create a command that produces a message after IO completes-cmdTask :: IO msg -> Cmd msg-cmdTask io = CmdRun (Just <$> io)---- | Create a command that fires a message after a delay-cmdAfterMs :: Int -> msg -> Cmd msg-cmdAfterMs delayMs msg = CmdRun (threadDelay (delayMs * 1000) >> pure (Just msg))---- | Execute a command and return any resulting message.--- Returns 'Nothing' for 'CmdExit' — the exit signal is handled by the runtime.-executeCmd :: Cmd msg -> IO (Maybe msg)-executeCmd CmdNone = pure Nothing-executeCmd CmdExit = pure Nothing-executeCmd (CmdRun io) = io-executeCmd (CmdBatch cmds) = do- results <- mapM executeCmd cmds- pure $ foldr pickFirst Nothing results- where- pickFirst (Just m) _ = Just m- pickFirst Nothing r = r---- | Check whether a command (or any sub-command in a batch) is 'CmdExit'.-cmdIsExit :: Cmd msg -> Bool-cmdIsExit CmdExit = True-cmdIsExit (CmdBatch cmds) = any cmdIsExit cmds-cmdIsExit _ = False---- | Subscriptions - event sources your app listens to-data Sub msg- = SubNone -- ^ No subscriptions- | SubKeyPress (Key -> Maybe msg) -- ^ Subscribe to keyboard input- | SubEveryMs Int msg -- ^ Subscribe to periodic ticks (interval in ms + message)- | SubBatch [Sub msg] -- ^ Combine multiple subscriptions---- | Combine multiple subscriptions-subBatch :: [Sub msg] -> Sub msg-subBatch = SubBatch---- | Subscribe to keyboard events-subKeyPress :: (Key -> Maybe msg) -> Sub msg-subKeyPress = SubKeyPress---- | Subscribe to periodic ticks with custom interval (milliseconds)-subEveryMs :: Int -> msg -> Sub msg-subEveryMs = SubEveryMs---- | The core application structure - Elm Architecture style------ Build interactive TUI apps by defining:------ * Initial state and startup commands--- * How to update state based on messages--- * What events to subscribe to--- * How to render state to UI------ Example:------ @--- data CounterMsg = Inc | Dec------ counterApp :: 'LayoutzApp' Int CounterMsg--- counterApp = 'LayoutzApp'--- { 'appInit' = (0, 'CmdNone')--- , 'appUpdate' = \\msg count -> case msg of--- 'Inc' -> (count + 1, 'CmdNone')--- 'Dec' -> (count - 1, 'CmdNone')--- , 'appSubscriptions' = \\_ -> 'subKeyPress' $ \\key -> case key of--- 'KeyChar' \'+\' -> Just 'Inc'--- 'KeyChar' \'-\' -> Just 'Dec'--- _ -> Nothing--- , 'appView' = \\count -> 'layout' ['text' $ "Count: " <> show count]--- }--- @-data LayoutzApp state msg = LayoutzApp- { appInit :: (state, Cmd msg) -- ^ Initial state and startup commands- , appUpdate :: msg -> state -> (state, Cmd msg) -- ^ Update state with message, return new state and commands- , appSubscriptions :: state -> Sub msg -- ^ Declare event subscriptions based on current state- , appView :: state -> L -- ^ Render state to UI- }---- | App-level alignment within the terminal window-data AppAlignment = AppAlignLeft | AppAlignCenter | AppAlignRight- deriving (Show, Eq)---- | Options for running a 'LayoutzApp'. Use 'defaultAppOptions' and override--- the fields you care about:------ @--- 'runAppWith' 'defaultAppOptions' { 'optAlignment' = 'AppAlignCenter' } myApp--- @-data AppOptions = AppOptions- { optAlignment :: AppAlignment -- ^ Alignment of the app block in the terminal (default: 'AppAlignLeft')- , optClearOnStart :: Bool -- ^ Enter alt screen and clear on start (default: 'True')- , optClearOnExit :: Bool -- ^ Exit alt screen on quit (default: 'True')- } deriving (Show, Eq)---- | Sensible defaults: left-aligned, full-screen (alt screen on start\/exit).-defaultAppOptions :: AppOptions-defaultAppOptions = AppOptions- { optAlignment = AppAlignLeft- , optClearOnStart = True- , optClearOnExit = True- }---- | Get terminal width via ANSI cursor position report (zero dependencies).--- Moves cursor to far bottom-right, queries position, restores cursor.--- Falls back to 80 columns on timeout or parse failure.-getTerminalWidth :: IO Int-getTerminalWidth = do- -- Save cursor, move to 999;999, query position, restore cursor- putStr "\ESC7\ESC[999;999H\ESC[6n\ESC8"- hFlush stdout- -- Terminal responds with: ESC [ rows ; cols R- result <- timeout 100000 readCPR -- 100ms timeout- pure $ maybe 80 id result- where- readCPR = do- c <- getChar- if c == '\ESC' then do- c2 <- getChar- if c2 == '[' then parseResponse ""- else pure 80- else pure 80- parseResponse acc = do- c <- getChar- if c == 'R' then- let resp = reverse acc- in pure $ case break (== ';') resp of- (_, ';':cols) -> case reads cols of- [(n, "")] -> n- _ -> 80- _ -> 80- else parseResponse (c : acc)---- | Run an interactive TUI application with default options.------ This function:------ * Sets up raw terminal mode (no echo, no buffering)--- * Clears screen and hides cursor--- * Enters event loop that:------ * Listens to subscribed events (keyboard, ticks, etc.)--- * Dispatches messages to update function--- * Updates state and re-renders------ * Restores terminal on exit (ESC, Ctrl+C, or Ctrl+D)------ Press ESC, Ctrl+C, or Ctrl+D to quit the application.-runApp :: LayoutzApp state msg -> IO ()-runApp app = runAppWithFinal defaultAppOptions app >> pure ()---- | Like 'runApp', but returns the final application state after exit.--- Useful for interactive tweaking of state followed by further processing.-runAppFinal :: LayoutzApp state msg -> IO state-runAppFinal = runAppWithFinal defaultAppOptions---- | Run an app inline — no alt screen, no clearing. The app renders in-place--- below whatever is already on screen and returns when it issues 'CmdExit'.--- Useful for embedding animated progress bars or spinners in scripts.-runInline :: LayoutzApp state msg -> IO ()-runInline app = runAppWithFinal defaultAppOptions- { optClearOnStart = False, optClearOnExit = False } app >> pure ()---- | Run an interactive TUI application with custom options.------ @--- 'runAppWith' 'defaultAppOptions' { 'optAlignment' = 'AppAlignCenter' } myApp--- @-runAppWith :: AppOptions -> LayoutzApp state msg -> IO ()-runAppWith opts app = runAppWithFinal opts app >> pure ()---- | Like 'runAppWith', but returns the final application state after exit.--- Useful for interactive tweaking of state followed by further processing.------ @--- finalState <- 'runAppWithFinal' 'defaultAppOptions' { 'optAlignment' = 'AppAlignCenter' } myApp--- @-runAppWithFinal :: AppOptions -> LayoutzApp state msg -> IO state-runAppWithFinal opts LayoutzApp{..} = do- oldBuffering <- hGetBuffering stdin- oldEcho <- hGetEcho stdin-- hSetBuffering stdin NoBuffering- hSetBuffering stdout NoBuffering- hSetEcho stdin False-- when (optClearOnStart opts) $ do- enterAltScreen- clearScreen- hideCursor-- -- Query terminal width once, after raw mode is set, before threads- termWidth <- getTerminalWidth-- let (initialState, initialCmd) = appInit-- stateRef <- newIORef initialState- exitRef <- newIORef False- cmdChan <- newChan -- Channel for commands to execute-- -- Helper to update state and queue commands- let updateState msg = do- cmdToRun <- atomicModifyIORef' stateRef $ \s ->- let (newState, c) = appUpdate msg s in (newState, c)- when (cmdIsExit cmdToRun) $ writeIORef exitRef True- case cmdToRun of- CmdNone -> pure ()- CmdExit -> pure ()- _ -> writeChan cmdChan cmdToRun-- -- Command thread: executes commands async, feeds results back- cmdThread <- forkIO $ forever $ do- cmdToRun <- readChan cmdChan- when (cmdIsExit cmdToRun) $ writeIORef exitRef True- maybeMsg <- executeCmd cmdToRun- case maybeMsg of- Just msg -> updateState msg -- Feed message back into app- Nothing -> pure ()-- -- Execute initial command- case initialCmd of- CmdNone -> pure ()- _ -> writeChan cmdChan initialCmd-- lastLineCount <- newIORef 0- lastRendered <- newIORef ""-- renderThread <- forkIO $ forever $ do- state <- readIORef stateRef- let rendered = render (appView state)- lastRender <- readIORef lastRendered-- when (rendered /= lastRender) $ do- prevLineCount <- readIORef lastLineCount- let renderedLines = lines rendered- currentLineCount = length renderedLines- maxLineWidth = maximum (0 : map visibleLength renderedLines)- blockPad = case optAlignment opts of- AppAlignLeft -> 0- AppAlignCenter -> max 0 ((termWidth - maxLineWidth) `div` 2)- AppAlignRight -> max 0 (termWidth - maxLineWidth)- padding = replicate blockPad ' '- alignedLines = if blockPad > 0- then map (padding ++) renderedLines- else renderedLines- moveUp = if optClearOnStart opts- then "\ESC[H"- else if prevLineCount > 0- then "\ESC[" ++ show prevLineCount ++ "A\r"- else ""- output = moveUp ++ concatMap (\l -> l ++ "\ESC[K\n") alignedLines- ++ concat (replicate (max 0 (prevLineCount - currentLineCount)) "\ESC[K\n")- putStr output- hFlush stdout- writeIORef lastRendered rendered- writeIORef lastLineCount currentLineCount-- threadDelay 33333-- let getKeyHandler sub = case sub of- SubKeyPress handler -> Just handler- SubBatch subs -> case [h | SubKeyPress h <- subs] of- (h:_) -> Just h- [] -> Nothing- _ -> Nothing-- getTickInfo sub = case sub of- SubEveryMs interval msg -> Just (interval, msg)- SubBatch subs -> case [(i, m) | SubEveryMs i m <- subs] of- ((i,m):_) -> Just (i, m)- [] -> Nothing- _ -> Nothing-- let killThreads = killThread renderThread >> killThread cmdThread-- doCleanup = do- killThreads- showCursor- when (optClearOnExit opts) exitAltScreen- hFlush stdout- hSetBuffering stdin oldBuffering- hSetEcho stdin oldEcho-- checkExit cont = do- exiting <- readIORef exitRef- if exiting then doCleanup else cont-- inputLoop = do- state <- readIORef stateRef- let subs = appSubscriptions state- keyHandler = getKeyHandler subs- tickInfo = getTickInfo subs-- maybeKey <- case tickInfo of- Just (intervalMs, _) -> timeout (intervalMs * 1000) readKey- Nothing -> Just <$> readKey-- case maybeKey of- Nothing -> do- case tickInfo of- Just (_, msg) -> updateState msg >> checkExit inputLoop- Nothing -> inputLoop-- Just key -> case key of- KeyEscape -> doCleanup- KeyCtrl 'C' -> doCleanup- KeyCtrl 'D' -> doCleanup-- _ -> case keyHandler of- Just handler -> case handler key of- Just msg -> updateState msg >> checkExit inputLoop- Nothing -> checkExit inputLoop- Nothing -> checkExit inputLoop-- (inputLoop `catch` \ex -> case ex of- UserInterrupt -> doCleanup- _ -> doCleanup)-- readIORef stateRef---- | Clear the screen and move cursor to top-left-clearScreen :: IO ()-clearScreen = putStr "\ESC[2J\ESC[H"---- | Hide the terminal cursor-hideCursor :: IO ()-hideCursor = putStr "\ESC[?25l"---- | Show the terminal cursor-showCursor :: IO ()-showCursor = putStr "\ESC[?25h"---- | Enter alternate screen buffer (like vim/less use)-enterAltScreen :: IO ()-enterAltScreen = putStr "\ESC[?1049h"---- | Exit alternate screen buffer-exitAltScreen :: IO ()-exitAltScreen = putStr "\ESC[?1049l"---- | Read a single key from stdin and parse it-readKey :: IO Key-readKey = do- c <- getChar- case ord c of- 10 -> return KeyEnter -- LF (Unix)- 13 -> return KeyEnter -- CR (Windows/Mac)- 27 -> readEscapeSequence -- ESC - might be arrow key- 9 -> return KeyTab- 127 -> return KeyBackspace -- DEL (often used as backspace)- 8 -> return KeyBackspace -- BS- n | n >= 32 && n <= 126 -> return $ KeyChar (chr n) -- Printable ASCII- | n < 32 -> return $ KeyCtrl (chr (n + 64)) -- Ctrl+Key- | otherwise -> return $ KeyChar (chr n)---- | Read escape sequence for arrow keys and other special keys--- Uses a small timeout to distinguish between ESC key and ESC sequences-readEscapeSequence :: IO Key-readEscapeSequence = do- -- Try to read next character with 50ms timeout- -- If timeout, it's just ESC key; if character arrives, it's an escape sequence- maybeChar <- timeout 50000 getChar -- 50000 microseconds = 50ms- case maybeChar of- Nothing -> return KeyEscape -- Timeout - just ESC key pressed- Just '[' -> do- -- It's an escape sequence, read the command character- c2 <- getChar- case c2 of- 'A' -> return KeyUp- 'B' -> return KeyDown- 'C' -> return KeyRight- 'D' -> return KeyLeft- '3' -> do- c3 <- getChar -- Read the '~'- if c3 == '~'- then return KeyDelete- else return KeyEscape- _ -> return KeyEscape- Just _ -> return KeyEscape -- Some other character after ESC+Copyright : (c) 2026 Matthieu Court+License : Apache-2.0++A simple Haskell port of the layoutz library for creating structured terminal layouts.+-}++module Layoutz+ ( -- * Core Types+ Element(..)+ , Border(..)+ , HasBorder(..)+ , Color(..)+ , Style(..)+ , L+ , Tree(..)+ -- * Basic Elements+ , layout+ , text+ , br+ -- * Layout Functions+ , center, center'+ , row, tightRow+ , columns, columns'+ , underline, underline', underlineColored+ , alignLeft, alignRight, alignCenter, justify, wrap+ , truncate', truncate''+ -- * Containers+ , box+ , banner+ , statusCard+ -- * Widgets+ , ul+ , ol+ , inlineBar+ , table+ , section, section', section''+ , kv+ , tree, leaf, branch+ -- * Visual Elements+ , margin+ , hr, hr', hr''+ , vr, vr', vr''+ , pad+ , chart+ -- * Spinners+ , spinner+ , SpinnerStyle(..)+ -- * Visualizations+ , plotSparkline+ , Series(..), plotLine+ , Slice(..), plotPie+ , BarItem(..), plotBar+ , StackedBarGroup(..), plotStackedBar+ , HeatmapData(..), plotHeatmap, plotHeatmap'+ -- * Border utilities+ , withBorder+ -- * Color utilities+ , withColor+ -- * Style utilities+ , withStyle+ -- * Rendering+ , render+ , renderText+ -- * TUI Runtime+ , LayoutzApp(..)+ , Key(..)+ , Cmd(..)+ , cmdFire+ , cmdTask+ , cmdAfterMs+ , executeCmd+ , cmdIsExit+ , Sub(..)+ , AppOptions(..)+ , defaultAppOptions+ , AppAlignment(..)+ , runApp+ , runAppFinal+ , runAppWith+ , runAppWithFinal+ , runInline+ -- * Subscriptions+ , subKeyPress+ , subEveryMs+ , subBatch+ -- * Kitty graphics+ , KittyImage(..)+ , kittyImage+ , kittyRGB+ , kittyRGBA+ , kittyImageFile+ -- * Progress loaders+ , LoaderStyle(..)+ , styleBlocks, styleBar, styleAscii, styleDots, styleLine, stylePipes, loaderStyles+ , loader, loaderStyled, loaderStream, loaderStreamStyled+ -- * Interactive prompts (Ask)+ , askInput+ , askConfirm+ , askChoose+ , askChooseMany+ , askSpin+ , askWrite+ , askFilter+ , askFile+ , askPager+ ) where++import Data.List (intercalate, transpose, nub, sortOn, isPrefixOf)+import qualified Data.Text+import qualified Data.Text as T+import qualified Data.IntSet as IntSet+import Data.Bits ((.|.), (.&.), xor, shiftL, shiftR)+import Data.Word (Word8)+import Data.String (IsString(..))+import Data.Char (ord, chr, toLower, isDigit)+import Text.Printf (printf)+import System.IO+import Control.Exception (catch, finally, throwIO, AsyncException(..), IOException, SomeException)+import System.Timeout (timeout)+import Control.Monad (when, unless, forever, forM)+import Control.Concurrent (forkIO, threadDelay, killThread, newChan, writeChan, readChan)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef', modifyIORef')+import GHC.Clock (getMonotonicTimeNSec)+import System.Directory (listDirectory, doesDirectoryExist, doesPathExist, canonicalizePath)++-- | Strip ANSI escape codes from a string for accurate width calculation.+-- Also drops kitty graphics APC escapes (@ESC _ G ... ESC \\@) so an inline+-- image's transmit block doesn't get counted as visible width.+stripAnsi :: String -> String+stripAnsi [] = []+stripAnsi ('\ESC':'[':rest) = stripAnsi (dropAfterM rest)+ where+ dropAfterM [] = []+ dropAfterM ('m':xs) = xs+ dropAfterM (_:xs) = dropAfterM xs+stripAnsi ('\ESC':'_':rest) = stripAnsi (dropAfterST rest)+ where+ -- APC string terminates at ST (ESC \)+ dropAfterST [] = []+ dropAfterST ('\ESC':'\\':xs) = xs+ dropAfterST (_:xs) = dropAfterST xs+stripAnsi (c:rest) = c : stripAnsi rest++-- | Returns width of a character in a monospace terminal: 0 for combining+-- characters, 1 for regular characters, 2 for East Asian wide and emoji.+charWidth :: Char -> Int+charWidth c+ | c < '\x0300' = 1 -- Fast path for ASCII and common Latin+ | c == kittyPlaceholderChar = 1 -- Kitty Unicode placeholder (one cell)+ | isRowColumnDiacritic c = 0 -- Kitty row/column combining diacritics+ | c >= '\x0300' && c < '\x0370' = 0 -- Combining diacriticals+ | c >= '\x1100' && c < '\x1200' = 2 -- Hangul Jamo+ | c >= '\x2E80' && c < '\x9FFF' = 2 -- CJK+ | c >= '\xAC00' && c < '\xD7A4' = 2 -- Hangul Syllables+ | c >= '\xF900' && c < '\xFB00' = 2 -- CJK Compatibility Ideographs+ | c >= '\xFE10' && c < '\xFE20' = 2 -- Vertical forms+ | c >= '\xFE30' && c < '\xFE70' = 2 -- CJK Compatibility Forms+ | c >= '\xFF00' && c < '\xFF61' = 2 -- Fullwidth Forms+ | c >= '\xFFE0' && c < '\xFFE7' = 2 -- Fullwidth symbols+ | c >= '\x1F000' = 2 -- Emoji, symbols, supplementary ideographs+ | c >= '\x20000' && c < '\x2FFFF' = 2 -- Supplementary ideographs+ | c >= '\x30000' && c < '\x3FFFF' = 2 -- Tertiary ideographs+ | otherwise = 1++-- | Calculate visible width of string (handles ANSI codes, emoji, CJK)+visibleLength :: String -> Int+visibleLength = sum . map charWidth . stripAnsi++-- | The Unicode placeholder code point (U+10EEEE) the kitty graphics protocol+-- uses to reserve one terminal cell per pixel-block of an inline image.+kittyPlaceholderChar :: Char+kittyPlaceholderChar = '\x10EEEE'++-- | Row/column combining diacritics used by the kitty placeholder protocol to+-- encode a cell's (row, column) into the placeholder glyph. Each renders with+-- zero width. The table's length also caps the maximum image dimensions.+rowColumnDiacritics :: [Int]+rowColumnDiacritics =+ [ 0x0305, 0x030d, 0x030e, 0x0310, 0x0312, 0x033d, 0x033e, 0x033f, 0x0346+ , 0x034a, 0x034b, 0x034c, 0x0350, 0x0351, 0x0352, 0x0357, 0x035b, 0x0363+ , 0x0364, 0x0365, 0x0366, 0x0367, 0x0368, 0x0369, 0x036a, 0x036b, 0x036c+ , 0x036d, 0x036e, 0x036f, 0x0483, 0x0484, 0x0485, 0x0486, 0x0487, 0x0592+ , 0x0593, 0x0594, 0x0595, 0x0597, 0x0598, 0x0599, 0x059c, 0x059d, 0x059e+ , 0x059f, 0x05a0, 0x05a1, 0x05a8, 0x05a9, 0x05ab, 0x05ac, 0x05af, 0x05c4+ , 0x0610, 0x0611, 0x0612, 0x0613, 0x0614, 0x0615, 0x0616, 0x0617, 0x0657+ , 0x0658, 0x0659, 0x065a, 0x065b, 0x065d, 0x065e, 0x06d6, 0x06d7, 0x06d8+ , 0x06d9, 0x06da, 0x06db, 0x06dc, 0x06df, 0x06e0, 0x06e1, 0x06e2, 0x06e4+ , 0x06e7, 0x06e8, 0x06eb, 0x06ec, 0x0730, 0x0732, 0x0733, 0x0735, 0x0736+ , 0x073a, 0x073d, 0x073f, 0x0740, 0x0741, 0x0743, 0x0745, 0x0747, 0x0749+ , 0x074a, 0x07eb, 0x07ec, 0x07ed, 0x07ee, 0x07ef, 0x07f0, 0x07f1, 0x07f3+ , 0x0816, 0x0817, 0x0818, 0x0819, 0x081b, 0x081c, 0x081d, 0x081e, 0x081f+ , 0x0820, 0x0821, 0x0822, 0x0823, 0x0825, 0x0826, 0x0827, 0x0829, 0x082a+ , 0x082b, 0x082c, 0x082d, 0x0951, 0x0953, 0x0954, 0x0f82, 0x0f83, 0x0f86+ , 0x0f87, 0x135d, 0x135e, 0x135f, 0x17dd, 0x193a, 0x1a17, 0x1a75, 0x1a76+ , 0x1a77, 0x1a78, 0x1a79, 0x1a7a, 0x1a7b, 0x1a7c, 0x1b6b, 0x1b6d, 0x1b6e+ , 0x1b6f, 0x1b70, 0x1b71, 0x1b72, 0x1b73, 0x1cd0, 0x1cd1, 0x1cd2, 0x1cda+ , 0x1cdb, 0x1ce0, 0x1dc0, 0x1dc1, 0x1dc3, 0x1dc4, 0x1dc5, 0x1dc6, 0x1dc7+ , 0x1dc8, 0x1dc9, 0x1dcb, 0x1dcc, 0x1dd1, 0x1dd2, 0x1dd3, 0x1dd4, 0x1dd5+ , 0x1dd6, 0x1dd7, 0x1dd8, 0x1dd9, 0x1dda, 0x1ddb, 0x1ddc, 0x1ddd, 0x1dde+ , 0x1ddf, 0x1de0, 0x1de1, 0x1de2, 0x1de3, 0x1de4, 0x1de5, 0x1de6, 0x1dfe+ , 0x20d0, 0x20d1, 0x20d4, 0x20d5, 0x20d6, 0x20d7, 0x20db, 0x20dc, 0x20e1+ , 0x20e7, 0x20e9, 0x20f0, 0x2cef, 0x2cf0, 0x2cf1, 0x2de0, 0x2de1, 0x2de2+ , 0x2de3, 0x2de4, 0x2de5, 0x2de6, 0x2de7, 0x2de8, 0x2de9, 0x2dea, 0x2deb+ , 0x2dec, 0x2ded, 0x2dee, 0x2def, 0x2df0, 0x2df1, 0x2df2, 0x2df3, 0x2df4+ , 0x2df5, 0x2df6, 0x2df7, 0x2df8, 0x2df9, 0x2dfa, 0x2dfb, 0x2dfc, 0x2dfd+ , 0x2dfe, 0x2dff, 0xa66f, 0xa67c, 0xa67d, 0xa6f0, 0xa6f1, 0xa8e0, 0xa8e1+ , 0xa8e2, 0xa8e3, 0xa8e4, 0xa8e5, 0xa8e6, 0xa8e7, 0xa8e8, 0xa8e9, 0xa8ea+ , 0xa8eb, 0xa8ec, 0xa8ed, 0xa8ee, 0xa8ef, 0xa8f0, 0xa8f1, 0xaab0, 0xaab2+ , 0xaab3, 0xaab7, 0xaab8, 0xaabe, 0xaabf, 0xaac1, 0xfe20, 0xfe21, 0xfe22+ , 0xfe23, 0xfe24, 0xfe25, 0xfe26, 0x10a0f, 0x10a38, 0x1d185, 0x1d186+ , 0x1d187, 0x1d188, 0x1d189, 0x1d1aa, 0x1d1ab, 0x1d1ac, 0x1d1ad, 0x1d242+ , 0x1d243, 0x1d244+ ]++-- | O(1)-ish membership test for the zero-width kitty diacritics above.+rowColumnDiacriticsSet :: IntSet.IntSet+rowColumnDiacriticsSet = IntSet.fromList rowColumnDiacritics++isRowColumnDiacritic :: Char -> Bool+isRowColumnDiacritic c = IntSet.member (ord c) rowColumnDiacriticsSet++-- | Apply a function to each line, preserving trailing newlines+mapLines :: (String -> String) -> String -> String+mapLines f str+ | null str = str+ | otherwise = let ls = lines str+ hasTrailingNewline = last str == '\n'+ in if hasTrailingNewline+ then unlines (map f ls)+ else intercalate "\n" (map f ls)++-- | Helper: pad a string to a target width on the right (ANSI-aware)+padRight :: Int -> String -> String+padRight targetWidth str = str ++ replicate (max 0 (targetWidth - visibleLength str)) ' '++-- | Helper: pad a string to a target width on the left (ANSI-aware)+padLeft :: Int -> String -> String+padLeft targetWidth str = replicate (max 0 (targetWidth - visibleLength str)) ' ' ++ str++-- | Helper: center a string within a target width (ANSI-aware)+centerString :: Int -> String -> String+centerString targetWidth str+ | len >= targetWidth = str+ | otherwise = leftPad ++ str ++ rightPad+ where+ len = visibleLength str+ totalPadding = targetWidth - len+ leftPad = replicate (totalPadding `div` 2) ' '+ rightPad = replicate (totalPadding - length leftPad) ' '++-- | Helper: justify text (spread words evenly to fill width)+justifyString :: Int -> String -> String+justifyString targetWidth str+ | len >= targetWidth = str+ | length ws <= 1 = str -- Can't justify single word+ | otherwise = intercalate "" $ zipWith (++) ws spaces+ where+ ws = words str+ len = length str+ wordLengths = sum (map length ws)+ totalSpaces = targetWidth - wordLengths+ gaps = length ws - 1+ baseSpaces = totalSpaces `div` gaps+ extraSpaces = totalSpaces `mod` gaps+ spaces = replicate extraSpaces (replicate (baseSpaces + 1) ' ')+ ++ replicate (gaps - extraSpaces) (replicate baseSpaces ' ')+ ++ [""] -- No space after last word++-- | Core Element typeclass+class Element a where+ renderElement :: a -> String++ -- | Calculate element width (longest line)+ width :: a -> Int+ width element =+ let rendered = renderElement element+ renderedLines = lines rendered+ in if null renderedLines then 0+ else maximum $ 0 : map visibleLength renderedLines++ -- | Calculate element height (number of lines)+ height :: a -> Int+ height element =+ let rendered = renderElement element+ in if null rendered then 1+ else length (lines rendered)++render :: Element a => a -> String+render = renderElement++renderText :: Element a => a -> Data.Text.Text+renderText = T.pack . renderElement++-- | L is the universal layout element type - a type-erased wrapper for the DSL.+--+-- This allows mixing different element types in layouts while providing a common interface.+-- Uses existential quantification to store any Element type inside L.+--+-- Constructors:+--+-- * @L a@ - Wraps any Element (Text, Box, Table, etc.)+-- * @UL [L]@ - Special case for unordered lists (allows nesting)+-- * @AutoCenter L@ - Smart centering that adapts to layout context width+-- * @LBox@, @LStatusCard@, @LTable@ - Specialized constructors for bordered elements+--+-- Example usage:+--+-- @+-- 'layout' ['text' "title", 'box' "content" [...], 'center' ('text' "footer")]+-- @+--+-- All different types unified as L, so they can be composed together.+data L = forall a. Element a => L a+ | UL [L]+ | OL [L]+ | AutoCenter L+ | Colored Color L+ | Styled Style L+ | LBox String [L] Border+ | LStatusCard String String Border+ | LTable [String] [[L]] Border++instance Element L where+ renderElement (L x) = render x+ renderElement (UL items) = render (UnorderedList items)+ renderElement (OL items) = render (OrderedList items)+ renderElement (AutoCenter element) = render element -- Will be handled by Layout+ renderElement (Colored color element) = mapLines (wrapAnsi color) (render element)+ renderElement (Styled style element) = mapLines (wrapStyle style) (render element)+ renderElement (LBox title elements border) = render (Box title elements border)+ renderElement (LStatusCard label content border) = render (StatusCard label content border)+ renderElement (LTable headers rows border) = render (Table headers rows border)++ width (L x) = width x+ width (UL items) = width (UnorderedList items)+ width (OL items) = width (OrderedList items)+ width (AutoCenter element) = width element+ width (Colored _ element) = width element -- Width ignores color+ width (Styled _ element) = width element -- Width ignores style+ width (LBox title elements border) = width (Box title elements border)+ width (LStatusCard label content border) = width (StatusCard label content border)+ width (LTable headers rows border) = width (Table headers rows border)++ height (L x) = height x+ height (UL items) = height (UnorderedList items)+ height (OL items) = height (OrderedList items)+ height (AutoCenter element) = height element+ height (Colored _ element) = height element -- Height ignores color+ height (Styled _ element) = height element -- Height ignores style+ height (LBox title elements border) = height (Box title elements border)+ height (LStatusCard label content border) = height (StatusCard label content border)+ height (LTable headers rows border) = height (Table headers rows border)++instance Show L where+ show = render++-- | Enable string literals to be used directly as elements with OverloadedStrings+--+-- With OverloadedStrings enabled, you can write @layout [\"Hello\", \"World\"]@+-- instead of @layout [text \"Hello\", text \"World\"]@.+instance IsString L where+ fromString = text++-- | Border styles+data Border+ = BorderNormal+ | BorderDouble+ | BorderThick+ | BorderRound+ | BorderAscii+ | BorderBlock+ | BorderDashed+ | BorderDotted+ | BorderInnerHalfBlock+ | BorderOuterHalfBlock+ | BorderMarkdown+ | BorderCustom String String String -- ^ corner, horizontal, vertical+ | BorderNone+ deriving (Show, Eq)++-- | Typeclass for elements that support customizable borders+class HasBorder a where+ -- | Set the border style for an element+ setBorder :: Border -> a -> a++instance HasBorder L where+ setBorder border (LBox title elements _) = LBox title elements border+ setBorder border (LStatusCard label content _) = LStatusCard label content border+ setBorder border (LTable headers rows _) = LTable headers rows border+ setBorder border (Colored color element) = Colored color (setBorder border element)+ setBorder border (Styled style element) = Styled style (setBorder border element)+ setBorder _ other = other -- Non-bordered elements remain unchanged++-- | Color support with ANSI codes+data Color = ColorDefault | ColorBlack | ColorRed | ColorGreen | ColorYellow+ | ColorBlue | ColorMagenta | ColorCyan | ColorWhite+ | ColorBrightBlack | ColorBrightRed | ColorBrightGreen | ColorBrightYellow+ | ColorBrightBlue | ColorBrightMagenta | ColorBrightCyan | ColorBrightWhite+ | ColorFull Int -- ^ 256-color palette (0-255)+ | ColorTrue Int Int Int -- ^ 24-bit RGB true color (r, g, b)+ deriving (Show, Eq)++-- | Get ANSI foreground color code+colorCode :: Color -> String+colorCode ColorDefault = ""+colorCode ColorBlack = "30"+colorCode ColorRed = "31"+colorCode ColorGreen = "32"+colorCode ColorYellow = "33"+colorCode ColorBlue = "34"+colorCode ColorMagenta = "35"+colorCode ColorCyan = "36"+colorCode ColorWhite = "37"+colorCode ColorBrightBlack = "90"+colorCode ColorBrightRed = "91"+colorCode ColorBrightGreen = "92"+colorCode ColorBrightYellow = "93"+colorCode ColorBrightBlue = "94"+colorCode ColorBrightMagenta = "95"+colorCode ColorBrightCyan = "96"+colorCode ColorBrightWhite = "97"+colorCode (ColorFull n) = "38;5;" ++ show (clamp n)+colorCode (ColorTrue r g b) = "38;2;" ++ show (clamp r) ++ ";" ++ show (clamp g) ++ ";" ++ show (clamp b)++-- | Clamp value to 0-255 range for color codes+clamp :: Int -> Int+clamp = max 0 . min 255++-- | Wrap text with ANSI color codes+wrapAnsi :: Color -> String -> String+wrapAnsi color str+ | null (colorCode color) = str+ | otherwise = "\ESC[" ++ colorCode color ++ "m" ++ str ++ "\ESC[0m"++-- | Style support with ANSI codes+data Style = StyleDefault | StyleBold | StyleDim | StyleItalic | StyleUnderline+ | StyleBlink | StyleReverse | StyleHidden | StyleStrikethrough+ | StyleCombined [Style] -- ^ Combine multiple styles+ deriving (Show, Eq)++-- | Combine styles using @<>@+instance Semigroup Style where+ StyleDefault <> other = other+ other <> StyleDefault = other+ StyleCombined styles1 <> StyleCombined styles2 = StyleCombined (styles1 ++ styles2)+ StyleCombined styles <> style = StyleCombined (styles ++ [style])+ style <> StyleCombined styles = StyleCombined (style : styles)+ style1 <> style2 = StyleCombined [style1, style2]++instance Monoid Style where+ mempty = StyleDefault++-- | Get ANSI style code+styleCode :: Style -> String+styleCode StyleDefault = ""+styleCode StyleBold = "1"+styleCode StyleDim = "2"+styleCode StyleItalic = "3"+styleCode StyleUnderline = "4"+styleCode StyleBlink = "5"+styleCode StyleReverse = "7"+styleCode StyleHidden = "8"+styleCode StyleStrikethrough = "9"+styleCode (StyleCombined styles) =+ let codes = filter (not . null) (map styleCode styles)+ in if null codes then "" else intercalate ";" codes++-- | Wrap text with ANSI style codes+wrapStyle :: Style -> String -> String+wrapStyle style str+ | null (styleCode style) = str+ | otherwise = "\ESC[" ++ styleCode style ++ "m" ++ str ++ "\ESC[0m"++-- | Border character set supporting asymmetric borders (e.g. half-block styles)+data BorderChars = BorderChars+ { bcTL, bcTR, bcBL, bcBR :: String -- corners+ , bcHTop, bcHBottom :: String -- horizontal (top vs bottom)+ , bcVLeft, bcVRight :: String -- vertical (left vs right)+ , bcLeftTee, bcRightTee, bcCross :: String -- separator connectors+ , bcTopTee, bcBottomTee :: String -- top/bottom column connectors+ }++-- | Helper for symmetric borders (hTop == hBottom, vLeft == vRight)+mkSymmetric :: String -> String -> String -> String -> String -> String+ -> String -> String -> String -> String -> String -> BorderChars+mkSymmetric tl tr bl br' h v lt rt cross tt bt = BorderChars+ { bcTL = tl, bcTR = tr, bcBL = bl, bcBR = br'+ , bcHTop = h, bcHBottom = h+ , bcVLeft = v, bcVRight = v+ , bcLeftTee = lt, bcRightTee = rt, bcCross = cross+ , bcTopTee = tt, bcBottomTee = bt+ }++borderChars :: Border -> BorderChars+borderChars BorderNormal = mkSymmetric "┌" "┐" "└" "┘" "─" "│" "├" "┤" "┼" "┬" "┴"+borderChars BorderDouble = mkSymmetric "╔" "╗" "╚" "╝" "═" "║" "╠" "╣" "╬" "╦" "╩"+borderChars BorderThick = mkSymmetric "┏" "┓" "┗" "┛" "━" "┃" "┣" "┫" "╋" "┳" "┻"+borderChars BorderRound = mkSymmetric "╭" "╮" "╰" "╯" "─" "│" "├" "┤" "┼" "┬" "┴"+borderChars BorderAscii = mkSymmetric "+" "+" "+" "+" "-" "|" "+" "+" "+" "+" "+"+borderChars BorderBlock = mkSymmetric "█" "█" "█" "█" "█" "█" "█" "█" "█" "█" "█"+borderChars BorderDashed = mkSymmetric "┌" "┐" "└" "┘" "╌" "╎" "├" "┤" "┼" "┬" "┴"+borderChars BorderDotted = mkSymmetric "┌" "┐" "└" "┘" "┈" "┊" "├" "┤" "┼" "┬" "┴"+borderChars BorderInnerHalfBlock = BorderChars+ { bcTL = "▗", bcTR = "▖", bcBL = "▝", bcBR = "▘"+ , bcHTop = "▄", bcHBottom = "▀"+ , bcVLeft = "▐", bcVRight = "▌"+ , bcLeftTee = "▐", bcRightTee = "▌", bcCross = "▄"+ , bcTopTee = "▄", bcBottomTee = "▀"+ }+borderChars BorderOuterHalfBlock = BorderChars+ { bcTL = "▛", bcTR = "▜", bcBL = "▙", bcBR = "▟"+ , bcHTop = "▀", bcHBottom = "▄"+ , bcVLeft = "▌", bcVRight = "▐"+ , bcLeftTee = "▌", bcRightTee = "▐", bcCross = "▀"+ , bcTopTee = "▀", bcBottomTee = "▄"+ }+borderChars BorderMarkdown = mkSymmetric "|" "|" "|" "|" "-" "|" "|" "|" "|" "|" "|"+borderChars (BorderCustom corner h v) = mkSymmetric corner corner corner corner h v corner corner corner corner corner+borderChars BorderNone = mkSymmetric " " " " " " " " " " " " " " " " " " " " " "++-- Elements+newtype Text = Text String+instance Element Text where renderElement (Text s) = s++data LineBreak = LineBreak+instance Element LineBreak where renderElement _ = ""++data Layout = Layout [L]+instance Element Layout where+ renderElement (Layout elements) =+ let -- Calculate max width of all non-AutoCenter elements+ nonAutoCenterElements = [e | e <- elements, not (isAutoCenter e)]+ maxWidth = if null nonAutoCenterElements+ then 80 -- fallback+ else maximum (0 : map width nonAutoCenterElements)++ -- Render elements, providing context width to AutoCenter elements+ renderedElements = map (renderWithContext maxWidth) elements+ in intercalate "\n" renderedElements+ where+ isAutoCenter (AutoCenter _) = True+ isAutoCenter _ = False++ renderWithContext contextWidth (AutoCenter element) =+ render (Centered (render element) contextWidth)+ renderWithContext _ element = render element++-- | Centered element with custom width+data Centered = Centered String Int -- content, target_width+instance Element Centered where+ renderElement (Centered content targetWidth) =+ intercalate "\n" $ map (centerString targetWidth) (lines content)++-- | Underlined element with custom character+data Underlined = Underlined String String (Maybe Color) -- content, underline_char, optional color+instance Element Underlined where+ renderElement (Underlined content underlineChar maybeColor) =+ let contentLines = lines content+ maxWidth = if null contentLines then 0+ else maximum (map visibleLength contentLines)+ repeats = maxWidth `div` length underlineChar+ remainder = maxWidth `mod` length underlineChar+ underlinePart = concat (replicate repeats underlineChar) ++ take remainder underlineChar+ coloredUnderline = maybe underlinePart (`wrapAnsi` underlinePart) maybeColor+ in content ++ "\n" ++ coloredUnderline++data Row = Row [L] Bool -- elements, tight (no spacing)+instance Element Row where+ renderElement (Row elements tight)+ | null elements = ""+ | otherwise = intercalate "\n" $ map (intercalate separator) (transpose paddedElements)+ where+ separator = if tight then "" else " "+ elementStrings = map render elements+ elementLines = map lines elementStrings+ maxHeight = maximum (map length elementLines)+ elementWidths = map (maximum . map visibleLength) elementLines+ paddedElements = zipWith padElement elementWidths elementLines++ padElement :: Int -> [String] -> [String]+ padElement cellWidth linesList =+ let currentLines = linesList ++ replicate (maxHeight - length linesList) ""+ in map (padRight cellWidth) currentLines++-- | Text alignment options+data Alignment = AlignLeft | AlignRight | AlignCenter | Justify+ deriving (Show, Eq)++-- | Aligned text with specified width and alignment+data AlignedText = AlignedText String Int Alignment -- content, width, alignment+instance Element AlignedText where+ renderElement (AlignedText content targetWidth alignment) =+ let alignFn = case alignment of+ AlignLeft -> padRight targetWidth+ AlignRight -> padLeft targetWidth+ AlignCenter -> centerString targetWidth+ Justify -> justifyString targetWidth+ in intercalate "\n" $ map alignFn (lines content)++data Box = Box String [L] Border++instance HasBorder Box where+ setBorder border (Box title elements _) = Box title elements border++instance Element Box where+ renderElement (Box title elements border) =+ let elementStrings = map render elements+ content = intercalate "\n" elementStrings+ contentLines = if null content then [""] else lines content+ contentWidth = maximum (0 : map visibleLength contentLines)+ titleWidth = if null title then 0 else visibleLength title + 2+ innerWidth = max contentWidth titleWidth+ totalWidth = innerWidth + 4+ BorderChars{..} = borderChars border+ hTopChar = head bcHTop+ hBottomChar = head bcHBottom++ topBorder+ | null title = bcTL ++ replicate (totalWidth - 2) hTopChar ++ bcTR+ | otherwise = let titlePadding = totalWidth - visibleLength title - 2+ leftPad = titlePadding `div` 2+ rightPad = titlePadding - leftPad+ in bcTL ++ replicate leftPad hTopChar ++ title ++ replicate rightPad hTopChar ++ bcTR++ bottomBorder = bcBL ++ replicate (totalWidth - 2) hBottomChar ++ bcBR+ paddedContent = map (\line -> bcVLeft ++ " " ++ padRight innerWidth line ++ " " ++ bcVRight) contentLines++ in intercalate "\n" (topBorder : paddedContent ++ [bottomBorder])++data StatusCard = StatusCard String String Border++instance HasBorder StatusCard where+ setBorder border (StatusCard label content _) = StatusCard label content border++instance Element StatusCard where+ renderElement (StatusCard label content border) =+ let labelLines = lines label+ contentLines = lines content+ allLines = labelLines ++ contentLines+ maxWidth = maximum (0 : map visibleLength allLines)+ contentWidth = maxWidth + 2+ BorderChars{..} = borderChars border+ hTopChar = head bcHTop+ hBottomChar = head bcHBottom++ topBorder = bcTL ++ replicate (contentWidth + 2) hTopChar ++ bcTR+ bottomBorder = bcBL ++ replicate (contentWidth + 2) hBottomChar ++ bcBR+ createCardLine line = bcVLeft ++ " " ++ padRight contentWidth line ++ " " ++ bcVRight++ in intercalate "\n" $ [topBorder] ++ map createCardLine allLines ++ [bottomBorder]++-- | Margin element that adds prefix to each line+data Margin = Margin String [L] -- prefix, elements+instance Element Margin where+ renderElement (Margin prefix elements) =+ let content = case elements of+ [single] -> render single+ _ -> render (Layout elements)+ in intercalate "\n" $ map ((prefix ++ " ") ++) (lines content)++-- | Horizontal rule with custom character and width+data HorizontalRule = HorizontalRule String Int -- char, width+instance Element HorizontalRule where+ renderElement (HorizontalRule char ruleWidth) = concat (replicate ruleWidth char)++-- | Vertical rule with custom character and height+data VerticalRule = VerticalRule String Int -- char, height+instance Element VerticalRule where+ renderElement (VerticalRule char ruleHeight) = intercalate "\n" (replicate ruleHeight char)++-- | Padded element with padding around all sides+data Padded = Padded String Int -- content, padding+instance Element Padded where+ renderElement (Padded content padding) =+ let contentLines = lines content+ maxWidth = maximum (0 : map length contentLines)+ horizontalPad = replicate padding ' '+ totalWidth = maxWidth + padding * 2+ verticalPad = replicate totalWidth ' '+ paddedLines = map (\line -> horizontalPad ++ padRight maxWidth line ++ horizontalPad) contentLines+ verticalLines = replicate padding verticalPad+ in intercalate "\n" (verticalLines ++ paddedLines ++ verticalLines)++-- | Columns: place elements side by side, each padded to its own width+data Columns = Columns [L] Int -- elements, spacing between columns+instance Element Columns where+ renderElement (Columns elements spacing)+ | null elements = ""+ | otherwise = intercalate "\n" $ map (intercalate separator) (transpose paddedElements)+ where+ separator = replicate spacing ' '+ elementLines = map (lines . render) elements+ maxHeight = maximum (map length elementLines)+ elementWidths = map (maximum . (0 :) . map visibleLength) elementLines+ paddedElements = zipWith padColumn elementWidths elementLines++ padColumn :: Int -> [String] -> [String]+ padColumn cellWidth linesList =+ let filled = linesList ++ replicate (maxHeight - length linesList) ""+ in map (padRight cellWidth) filled++-- | Truncate each line with an ellipsis when it exceeds the max width+data Truncated = Truncated String Int String -- content, maxWidth, ellipsis+instance Element Truncated where+ renderElement (Truncated content maxWidth ellipsis) =+ intercalate "\n" $ map truncateLine (lines content)+ where+ truncateLine line+ | visibleLength line <= maxWidth = line+ | truncateAt <= 0 = take maxWidth ellipsis+ | otherwise = take truncateAt (stripAnsi line) ++ ellipsis+ where truncateAt = maxWidth - length ellipsis++-- | Chart for data visualization+data Chart = Chart [(String, Double)] -- (label, value) pairs+instance Element Chart where+ renderElement (Chart dataPoints)+ | null dataPoints = "No data"+ | otherwise = intercalate "\n" $ map renderBar dataPoints+ where+ maxValue = maximum (0 : map snd dataPoints)+ maxLabelWidth = minimum [15, maximum (0 : map (length . fst) dataPoints)]+ chartWidth = 40++ renderBar :: (String, Double) -> String+ renderBar (label, value) =+ let truncatedLabel+ | length label > maxLabelWidth = take (maxLabelWidth - 3) label ++ "..."+ | otherwise = label+ paddedLabel = padRight maxLabelWidth truncatedLabel+ percentage = value / maxValue+ barLength = floor (percentage * fromIntegral chartWidth)+ bar = replicate barLength '█' ++ replicate (chartWidth - barLength) '─'+ valueStr+ | value == fromInteger (round value) = show (round value :: Integer)+ | otherwise = printf "%.1f" value+ in paddedLabel ++ " │" ++ bar ++ "│ " ++ valueStr++-- | Table with headers and borders (fixed alignment)+data Table = Table [String] [[L]] Border -- headers, rows, border++instance HasBorder Table where+ setBorder border (Table headers rows _) = Table headers rows border++instance Element Table where+ renderElement (Table headers rows border) =+ let normalizedRows = map (normalizeRow (length headers)) rows+ columnWidths = calculateColumnWidths headers normalizedRows+ BorderChars{..} = borderChars border+ hTopChar = head bcHTop+ hBottomChar = head bcHBottom++ -- Top border+ topParts = map (\w -> replicate w hTopChar) columnWidths+ topBorder = bcTL ++ [hTopChar] ++ intercalate ([hTopChar] ++ bcTopTee ++ [hTopChar]) topParts ++ [hTopChar] ++ bcTR++ -- Separator (between header and data)+ separatorParts = map (\w -> replicate w hTopChar) columnWidths+ separatorBorder = bcLeftTee ++ [hTopChar] ++ intercalate ([hTopChar] ++ bcCross ++ [hTopChar]) separatorParts ++ [hTopChar] ++ bcRightTee++ -- Bottom border+ bottomParts = map (\w -> replicate w hBottomChar) columnWidths+ bottomBorder = bcBL ++ [hBottomChar] ++ intercalate ([hBottomChar] ++ bcBottomTee ++ [hBottomChar]) bottomParts ++ [hBottomChar] ++ bcBR++ -- Header row+ headerCells = zipWith padRight columnWidths headers+ headerRow = bcVLeft ++ " " ++ intercalate (" " ++ bcVLeft ++ " ") headerCells ++ " " ++ bcVRight++ -- Data rows+ dataRows = concatMap (renderTableRow columnWidths bcVLeft bcVRight) normalizedRows++ in intercalate "\n" ([topBorder, headerRow, separatorBorder] ++ dataRows ++ [bottomBorder])+ where+ normalizeRow :: Int -> [L] -> [L]+ normalizeRow expectedLen rowData+ | currentLen >= expectedLen = take expectedLen rowData+ | otherwise = rowData ++ replicate (expectedLen - currentLen) (text "")+ where currentLen = length rowData++ calculateColumnWidths :: [String] -> [[L]] -> [Int]+ calculateColumnWidths hdrs rws =+ let headerWidths = map visibleLength hdrs+ rowWidths = map (map (maximum . (0:) . map visibleLength . lines . render)) rws+ allWidths = headerWidths : rowWidths+ in map (maximum . (0:)) (transpose allWidths)++ renderTableRow :: [Int] -> String -> String -> [L] -> [String]+ renderTableRow widths vLeft vRight rowData =+ let cellContents = map render rowData+ cellLines = map lines cellContents+ maxCellHeight = maximum (1 : map length cellLines)+ paddedCells = zipWith (padCell maxCellHeight) widths cellLines+ tableRows = transpose paddedCells+ in map (\rowCells -> vLeft ++ " " ++ intercalate (" " ++ vLeft ++ " ") rowCells ++ " " ++ vRight) tableRows++ padCell :: Int -> Int -> [String] -> [String]+ padCell cellHeight cellWidth cellLines =+ let paddedLines = cellLines ++ replicate (cellHeight - length cellLines) ""+ in map (padRight cellWidth) paddedLines++-- | Section with decorative header+data Section = Section String [L] String Int -- title, content, glyph, flanking_chars+instance Element Section where+ renderElement (Section title content glyph flankingChars) =+ let header = replicate flankingChars (head glyph) ++ " " ++ title ++ " " ++ replicate flankingChars (head glyph)+ body = render (Layout content)+ in header ++ "\n" ++ body++-- | Key-value pairs with alignment+data KeyValue = KeyValue [(String, String)]+instance Element KeyValue where+ renderElement (KeyValue pairs) =+ if null pairs then ""+ else let maxKeyLength = maximum (map (visibleLength . fst) pairs)+ alignmentPosition = maxKeyLength + 2+ in intercalate "\n" $ map (renderPair alignmentPosition) pairs+ where+ renderPair alignPos (key, value) =+ let keyWithColon = key ++ ":"+ spacesNeeded = alignPos - visibleLength keyWithColon+ padding = replicate (max 1 spacesNeeded) ' '+ in keyWithColon ++ padding ++ value++-- | Tree structure for hierarchical data+data Tree = Tree String [Tree]++instance Element Tree where+ renderElement treeData = renderTree treeData "" True []+ where+ renderTree (Tree name children) prefix isLast parentPrefixes =+ let nodeLine = if null parentPrefixes+ then name+ else prefix ++ (if isLast then "└── " else "├── ") ++ name+ childPrefix = if null parentPrefixes+ then ""+ else prefix ++ (if isLast then " " else "│ ")+ childLines = zipWith (\child idx ->+ renderTree child childPrefix (idx == length children - 1) (parentPrefixes ++ [not isLast])+ ) children [0..]+ in if null children+ then nodeLine+ else nodeLine ++ "\n" ++ intercalate "\n" childLines+++newtype UnorderedList = UnorderedList [L]+instance Element UnorderedList where+ renderElement (UnorderedList items) = renderAtLevel 0 items+ where+ bulletStyles = ["•", "◦", "▪"]++ renderAtLevel level itemList =+ let currentBullet = bulletStyles !! (level `mod` length bulletStyles)+ indent = replicate (level * 2) ' '+ in intercalate "\n" $ map (renderItem level indent currentBullet) itemList++ renderItem level indent bullet item = case item of+ UL nested -> renderAtLevel (level + 1) nested+ _ -> let content = render item+ contentLines = lines content+ in case contentLines of+ [singleLine] -> indent ++ bullet ++ " " ++ singleLine+ (firstLine:restLines) ->+ let firstOutput = indent ++ bullet ++ " " ++ firstLine+ restIndent = replicate (length indent + length bullet + 1) ' '+ restOutput = map (restIndent ++) restLines+ in intercalate "\n" (firstOutput : restOutput)+ [] -> indent ++ bullet ++ " "++newtype OrderedList = OrderedList [L]+instance Element OrderedList where+ renderElement (OrderedList items) = renderAtLevel 1 0 items+ where+ renderAtLevel startNum level itemList =+ let indent = replicate (level * 2) ' '+ numbered = zip [startNum..] itemList+ in intercalate "\n" $ map (renderItem level indent) numbered++ renderItem level indent (num, item) = case item of+ OL nested -> renderAtLevel 1 (level + 1) nested+ _ -> let numStr = formatNumber level num ++ ". "+ content = render item+ contentLines = lines content+ in case contentLines of+ [singleLine] -> indent ++ numStr ++ singleLine+ (firstLine:restLines) ->+ let firstOutput = indent ++ numStr ++ firstLine+ restIndent = replicate (length numStr) ' '+ restOutput = map ((indent ++ restIndent) ++) restLines+ in intercalate "\n" (firstOutput : restOutput)+ [] -> indent ++ numStr++ formatNumber :: Int -> Int -> String+ formatNumber lvl num = case lvl `mod` 3 of+ 0 -> show num -- 1, 2, 3+ 1 -> [toEnum (96 + num)] -- a, b, c+ _ -> toRoman num -- i, ii, iii++ toRoman :: Int -> String+ toRoman = \case+ 1 -> "i"; 2 -> "ii"; 3 -> "iii"; 4 -> "iv"; 5 -> "v"+ 6 -> "vi"; 7 -> "vii"; 8 -> "viii"; 9 -> "ix"; 10 -> "x"+ n -> show n++data InlineBar = InlineBar String Double+instance Element InlineBar where+ renderElement (InlineBar label progress) =+ let clampedProgress = max 0.0 (min 1.0 progress)+ barWidth = 20+ filledSegments = floor (clampedProgress * fromIntegral barWidth)+ emptySegments = barWidth - filledSegments+ bar = replicate filledSegments '█' ++ replicate emptySegments '─'+ percentage = floor (clampedProgress * 100) :: Int+ in printf "%s [%s] %d%%" label bar percentage++-- Smart constructors and automatic conversions+text :: String -> L+text s = L (Text s)++br :: L+br = L LineBreak++center :: Element a => a -> L+center element = AutoCenter (L element)++-- | Center element within specified width+center' :: Element a => Int -> a -> L+center' targetWidth element = L (Centered (render element) targetWidth)++underline :: Element a => a -> L+underline element = L (Underlined (render element) "─" Nothing)++-- | Add underline with custom character+underline' :: Element a => String -> a -> L+underline' char element = L (Underlined (render element) char Nothing)++-- | Add colored underline with custom character and color+--+-- @+-- 'underlineColored' "=" 'ColorRed' $ 'text' "Error Section"+-- 'underlineColored' "~" 'ColorGreen' $ 'text' "Success"+-- 'underlineColored' "─" 'ColorBrightCyan' $ 'text' "Info"+-- @+underlineColored :: Element a => String -> Color -> a -> L+underlineColored char color element = L (Underlined (render element) char (Just color))++ul :: [L] -> L+ul = UL++ol :: [L] -> L+ol = OL++inlineBar :: String -> Double -> L+inlineBar label progress = L (InlineBar label progress)++statusCard :: String -> String -> L+statusCard label content = LStatusCard label content BorderNormal++layout :: [L] -> L+layout elements = L (Layout elements)++row :: [L] -> L+row elements = L (Row elements False)++-- | Create horizontal row with no spacing between elements (for gradients, etc.)+tightRow :: [L] -> L+tightRow elements = L (Row elements True)++-- | Align text to the left within specified width+alignLeft :: Int -> String -> L+alignLeft targetWidth content = L (AlignedText content targetWidth AlignLeft)++-- | Align text to the right within specified width+alignRight :: Int -> String -> L+alignRight targetWidth content = L (AlignedText content targetWidth AlignRight)++-- | Align text to the center within specified width+alignCenter :: Int -> String -> L+alignCenter targetWidth content = L (AlignedText content targetWidth AlignCenter)++-- | Justify text (spread words evenly to fill width)+justify :: Int -> String -> L+justify targetWidth content = L (AlignedText content targetWidth Justify)++-- | Wrap text to multiple lines with specified width+wrap :: Int -> String -> L+wrap targetWidth content =+ let ws = words content+ wrappedLines = wrapWords targetWidth ws+ in layout (map text wrappedLines)+ where+ wrapWords :: Int -> [String] -> [String]+ wrapWords _ [] = []+ wrapWords maxWidth wordsList =+ let (line, rest) = takeLine maxWidth wordsList+ in line : wrapWords maxWidth rest++ takeLine :: Int -> [String] -> (String, [String])+ takeLine _ [] = ("", [])+ takeLine maxWidth (firstWord:restWords)+ | length firstWord > maxWidth = (firstWord, restWords) -- Word too long, put it on its own line+ | otherwise = go (length firstWord) [firstWord] restWords+ where+ go _ acc [] = (unwords (reverse acc), [])+ go currentLen acc (nextWord:remainingWords)+ | currentLen + 1 + length nextWord <= maxWidth = go (currentLen + 1 + length nextWord) (nextWord:acc) remainingWords+ | otherwise = (unwords (reverse acc), nextWord:remainingWords)++box :: String -> [L] -> L+box title elements = LBox title elements BorderNormal++-- | Banner: a titleless bordered box (Double border by default)+--+-- @+-- 'banner' ["System Dashboard"]+-- -- ╔══════════════════╗+-- -- ║ System Dashboard ║+-- -- ╚══════════════════╝+-- @+banner :: [L] -> L+banner content = LBox "" content BorderDouble++-- | Create margin with custom prefix+--+-- @+-- 'margin' "[error]" ['text' "Something went wrong"]+-- 'margin' "[info]" ['text' "FYI: Check the logs"]+-- @+margin :: String -> [L] -> L+margin prefix elements = L (Margin prefix elements)++-- | Horizontal rule with default character and width+hr :: L+hr = L (HorizontalRule "─" 50)++-- | Horizontal rule with custom character+hr' :: String -> L+hr' char = L (HorizontalRule char 50)++-- | Horizontal rule with custom character and width+hr'' :: String -> Int -> L+hr'' char ruleWidth = L (HorizontalRule char ruleWidth)++-- | Vertical rule with default character and height+vr :: L+vr = L (VerticalRule "│" 10)++-- | Vertical rule with custom character+vr' :: String -> L+vr' char = L (VerticalRule char 10)++-- | Vertical rule with custom character and height+vr'' :: String -> Int -> L+vr'' char ruleHeight = L (VerticalRule char ruleHeight)++-- | Add padding around element+pad :: Element a => Int -> a -> L+pad padding element = L (Padded (render element) padding)++-- | Place elements side by side (2 spaces between columns)+--+-- @+-- 'columns' ['layout' ["A", "B"], 'layout' ["C", "D"]]+-- -- A C+-- -- B D+-- @+columns :: [L] -> L+columns elements = L (Columns elements 2)++-- | Like 'columns' with a custom gap between columns+columns' :: Int -> [L] -> L+columns' spacing elements = L (Columns elements spacing)++-- | Truncate an element with a trailing @"..."@ when it is too wide+--+-- @+-- 'truncate'' 15 "Very long text that will be cut off" -- Very long te...+-- @+truncate' :: Element a => Int -> a -> L+truncate' maxWidth element = L (Truncated (render element) maxWidth "...")++-- | Like 'truncate'' with a custom ellipsis+truncate'' :: Element a => Int -> String -> a -> L+truncate'' maxWidth ellipsis element = L (Truncated (render element) maxWidth ellipsis)++-- | Create horizontal bar chart+chart :: [(String, Double)] -> L+chart dataPoints = L (Chart dataPoints)++-- | Create table with headers and rows+table :: [String] -> [[L]] -> L+table headers rows = LTable headers rows BorderNormal++-- | Create section with title and content+section :: String -> [L] -> L+section title content = L (Section title content "=" 3)++-- | Create section with custom glyph+section' :: String -> String -> [L] -> L+section' glyph title content = L (Section title content glyph 3)++-- | Create section with custom glyph and flanking chars+section'' :: String -> String -> Int -> [L] -> L+section'' glyph title flanking content = L (Section title content glyph flanking)++-- | Create key-value pairs+kv :: [(String, String)] -> L+kv pairs = L (KeyValue pairs)++-- | Apply a border style to elements that support borders+--+-- Elements that support borders: 'box', 'statusCard', 'table'.+-- Other elements are returned unchanged.+--+-- @+-- withBorder BorderDouble $ table [\"Name\"] [[text \"Alice\"]]+-- @+withBorder :: Border -> L -> L+withBorder = setBorder++-- | Apply a color to an element+--+-- @+-- withColor ColorBrightYellow $ box \"Warning\" [text "Check logs"]+-- @+withColor :: Color -> L -> L+withColor = Colored++-- | Apply a style to an element+--+-- @+-- withStyle StyleBold $ text "Important!"+-- @+withStyle :: Style -> L -> L+withStyle = Styled++-- | Create tree structure+tree :: String -> [Tree] -> L+tree name children = L (Tree name children)++-- | Create leaf tree node (no children)+leaf :: String -> Tree+leaf name = Tree name []++-- | Create branch tree node with children+branch :: String -> [Tree] -> Tree+branch name children = Tree name children++-- ============================================================================+-- Spinner Animations+-- ============================================================================++-- | Spinner style with animation frames+data SpinnerStyle+ = SpinnerDots+ | SpinnerLine+ | SpinnerClock+ | SpinnerBounce+ | SpinnerEarth+ | SpinnerMoon+ | SpinnerGrow+ | SpinnerArrow+ deriving (Show, Eq)++-- | Get animation frames for a spinner style+spinnerFrames :: SpinnerStyle -> [String]+spinnerFrames SpinnerDots = ["⠋", "⠙", "⠹", "⠸", "⠼", "⠴", "⠦", "⠧", "⠇", "⠏"]+spinnerFrames SpinnerLine = ["|", "/", "-", "\\"]+spinnerFrames SpinnerClock = ["🕐", "🕑", "🕒", "🕓", "🕔", "🕕", "🕖", "🕗", "🕘", "🕙", "🕚", "🕛"]+spinnerFrames SpinnerBounce = ["⠁", "⠂", "⠄", "⠂"]+spinnerFrames SpinnerEarth = ["🌍", "🌎", "🌏"]+spinnerFrames SpinnerMoon = ["🌑", "🌒", "🌓", "🌔", "🌕", "🌖", "🌗", "🌘"]+spinnerFrames SpinnerGrow = ["▏", "▎", "▍", "▌", "▋", "▊", "▉", "█", "▉", "▊", "▋", "▌", "▍", "▎"]+spinnerFrames SpinnerArrow = ["←", "↖", "↑", "↗", "→", "↘", "↓", "↙"]++-- | Spinner animation element+data Spinner = Spinner String Int SpinnerStyle -- label, frame, style++instance Element Spinner where+ renderElement (Spinner label frame style) =+ let frames = spinnerFrames style+ spinChar = frames !! (frame `mod` length frames)+ in if null label+ then spinChar+ else spinChar ++ " " ++ label++-- | Create an animated spinner+--+-- Example usage:+--+-- @+-- 'spinner' \"Loading\" 5 'SpinnerDots' -- Shows the 5th frame of dots spinner+-- 'spinner' \"Processing\" 0 'SpinnerLine' -- Shows first frame with label+-- @+--+-- Increment the frame number each render to animate:+--+-- @+-- 'layout' ['spinner' \"Working\" (tickCount \`mod\` 10) 'SpinnerDots']+-- @+spinner :: String -> Int -> SpinnerStyle -> L+spinner label frame style = L (Spinner label frame style)++-- ============================================================================+-- Visualization Primitives+-- ============================================================================++-- | Block characters for sparklines and bar charts (indices 0–8)+blockChars :: String+blockChars = " ▁▂▃▄▅▆▇█"++-- | Braille dot bit flag for position (row 0–3, col 0–1) in a 2×4 braille cell+brailleDot :: Int -> Int -> Int+brailleDot 0 0 = 0x01+brailleDot 1 0 = 0x02+brailleDot 2 0 = 0x04+brailleDot 3 0 = 0x40+brailleDot 0 1 = 0x08+brailleDot 1 1 = 0x10+brailleDot 2 1 = 0x20+brailleDot 3 1 = 0x80+brailleDot _ _ = 0++-- | Default color palette for cycling through series/slices+defaultPalette :: [Color]+defaultPalette = [ ColorBrightCyan, ColorBrightMagenta, ColorBrightYellow+ , ColorBrightGreen, ColorBrightRed, ColorBrightBlue ]++-- | Use explicit color if not ColorDefault, else cycle palette by index+pickColor :: Int -> Color -> Color+pickColor idx ColorDefault = defaultPalette !! (idx `mod` length defaultPalette)+pickColor _ c = c++-- | Format number for axis labels: "3" for integers, "3.5" for decimals+formatAxisNum :: Double -> String+formatAxisNum v+ | v == fromInteger (round v) = show (round v :: Integer)+ | otherwise = printf "%.1f" v++-- | ANSI 256-color background escape sequence+bgColor256 :: Int -> String+bgColor256 n = "\ESC[48;5;" ++ show n ++ "m"++-- | ANSI reset sequence+ansiReset :: String+ansiReset = "\ESC[0m"++-- Sparkline --------------------------------------------------++data SparklineData = SparklineData [Double]++instance Element SparklineData where+ renderElement (SparklineData []) = ""+ renderElement (SparklineData vals) =+ let mn = minimum vals+ mx = maximum vals+ rng = mx - mn+ idx v | rng == 0 = 4+ | otherwise = max 1 $ min 8 $ floor ((v - mn) / rng * 8)+ in map (\v -> blockChars !! idx v) vals++-- | Create a sparkline from a list of values+plotSparkline :: [Double] -> L+plotSparkline = L . SparklineData++-- Line Plot (Braille) --------------------------------------------------++-- | A data series for line plots: points, label, color+data Series = Series [(Double, Double)] String Color++data PlotData = PlotData [Series] Int Int -- series, width, height++instance Element PlotData where+ renderElement (PlotData ss w h)+ | null ss || all (\(Series ps _ _) -> null ps) ss = "No data"+ | otherwise =+ let allPts = concatMap (\(Series ps _ _) -> ps) ss+ (xs, ys) = unzip allPts+ xMin = minimum xs; xMax = maximum xs+ yMin = minimum ys; yMax = maximum ys+ xRng = if xMax == xMin then 1.0 else xMax - xMin+ yRng = if yMax == yMin then 1.0 else yMax - yMin+ pxW = w * 2; pxH = h * 4++ toPixel (x, y) =+ ( clampI 0 (pxW - 1) $ round ((x - xMin) / xRng * fromIntegral (pxW - 1))+ , clampI 0 (pxH - 1) $ round ((yMax - y) / yRng * fromIntegral (pxH - 1))+ )+ clampI lo hi = max lo . min hi++ emptyGrid = replicate h (replicate w (0 :: Int, -1 :: Int))++ plotSeries grd sIdx (Series ps _ _) =+ foldl (\g p ->+ let (px, py) = toPixel p+ cx = px `div` 2; cy = py `div` 4+ dx = px `mod` 2; dy = py `mod` 4+ bit = brailleDot dy dx+ in updGrid cy cx (\(b, si) -> (b .|. bit, if si < 0 then sIdx else si)) g+ ) grd ps++ updGrid r c f g =+ [ if ri == r+ then [ if ci == c then f cell else cell | (ci, cell) <- zip [0..] row' ]+ else row'+ | (ri, row') <- zip [0..] g ]++ grid = foldl (\g (i, s) -> plotSeries g i s) emptyGrid (zip [0..] ss)++ yTicks = [ yMax - yRng * fromIntegral i / fromIntegral (max 1 (h - 1)) | i <- [0 .. h-1] ]+ yLabels = map formatAxisNum yTicks+ yLabelW = maximum (0 : map length yLabels)++ gridLines = zipWith (\yLbl row' ->+ padLeft yLabelW yLbl ++ " │" +++ concatMap (\(bits, si) ->+ let ch = if bits == 0 then ' ' else chr (0x2800 + bits)+ c = if si >= 0 then pickColor si (sColor (ss !! si)) else ColorDefault+ in if c == ColorDefault then [ch] else wrapAnsi c [ch]+ ) row'+ ) yLabels grid++ xAxis = replicate (yLabelW + 2) ' ' ++ replicate w '─'+ xMinL = formatAxisNum xMin+ xMaxL = formatAxisNum xMax+ xLabels = replicate (yLabelW + 2) ' ' ++ xMinL+ ++ replicate (max 1 (w - length xMinL - length xMaxL)) ' '+ ++ xMaxL++ legend+ | length ss <= 1 = []+ | otherwise = ["", intercalate " " $+ zipWith (\i (Series _ nm cl) ->+ wrapAnsi (pickColor i cl) "●" ++ " " ++ nm+ ) [0..] ss]++ in intercalate "\n" (gridLines ++ [xAxis, xLabels] ++ legend)+ where sColor (Series _ _ c) = c++-- | Create a braille line plot+plotLine :: Int -> Int -> [Series] -> L+plotLine w h ss = L (PlotData ss w h)++-- Pie Chart (Braille) --------------------------------------------------++-- | A slice of a pie chart: value, label, color+data Slice = Slice Double String Color++data PieData = PieData [Slice] Int Int++instance Element PieData where+ renderElement (PieData [] _ _) = "No data"+ renderElement (PieData slices w h) =+ let total = sum [ v | Slice v _ _ <- slices ]+ cumAngs = scanl (+) 0 [ v / total * 2 * pi | Slice v _ _ <- slices ]++ cxF = fromIntegral w :: Double+ cyF = fromIntegral (h * 4) / 2.0 :: Double+ radius = min cxF (cyF * 0.9)++ findSlice ang = go 0 (tail cumAngs)+ where go i [] = max 0 (i - 1)+ go i (a:as') = if ang < a then i else go (i + 1) as'++ renderCell gcx gcy =+ let subPx = [ (dy, dx, dist, nAng)+ | dy <- [0..3], dx <- [0..1]+ , let dpx = fromIntegral (gcx * 2 + dx) :: Double+ dpy = fromIntegral (gcy * 4 + dy) :: Double+ relX = dpx - cxF+ relY = (dpy - cyF) * 2.0+ dist = sqrt (relX * relX + relY * relY)+ ang = atan2 relY relX+ nAng = if ang < 0 then ang + 2 * pi else ang+ ]+ inside = [ (dy, dx, nAng) | (dy, dx, dist, nAng) <- subPx, dist <= radius ]+ bits = foldl (\acc (dy, dx, _) -> acc .|. brailleDot dy dx) 0 inside+ domSi = case inside of+ [] -> -1+ ((_, _, a):_) -> findSlice a+ ch = if bits == 0 then ' ' else chr (0x2800 + bits)+ color = if domSi >= 0 && domSi < length slices+ then pickColor domSi (slColor (slices !! domSi))+ else ColorDefault+ in if bits == 0 then " " else wrapAnsi color [ch]++ gridLines = [ concatMap (\gcx -> renderCell gcx gcy) [0..w-1] | gcy <- [0..h-1] ]++ legendLines = zipWith (\i (Slice v nm cl) ->+ let c = pickColor i cl+ pct = printf "%.0f" (v / total * 100) :: String+ in " " ++ wrapAnsi c "●" ++ " " ++ nm ++ " (" ++ pct ++ "%)"+ ) [0..] slices++ in intercalate "\n" (gridLines ++ [""] ++ legendLines)+ where slColor (Slice _ _ c) = c++-- | Create a braille pie chart+plotPie :: Int -> Int -> [Slice] -> L+plotPie w h sl = L (PieData sl w h)++-- Bar Chart (Vertical) --------------------------------------------------------++-- | A bar item: value, label, color+data BarItem = BarItem Double String Color++data BarChartData = BarChartData [BarItem] Int Int++instance Element BarChartData where+ renderElement (BarChartData [] _ _) = "No data"+ renderElement (BarChartData items w h) =+ let maxVal = maximum [ v | BarItem v _ _ <- items ]+ nBars = length items+ barW = max 1 $ (w - nBars + 1) `div` nBars+ totalSub = h * 8+ barHts = [ round (v / maxVal * fromIntegral totalSub) :: Int | BarItem v _ _ <- items ]++ yTicks = [ maxVal * fromIntegral (h - 1 - i) / fromIntegral (max 1 (h - 1)) | i <- [0..h-1] ]+ yLabels = map formatAxisNum yTicks+ yLabelW = maximum (0 : map length yLabels)++ gridLines =+ [ let r = h - 1 - rowIdx+ barCells = intercalate " " $+ map (\(i, (bh, BarItem _ _ cl)) ->+ let filled = min 8 $ max 0 (bh - r * 8)+ color' = pickColor i cl+ barStr = replicate barW (blockChars !! filled)+ in if filled > 0 then wrapAnsi color' barStr else barStr+ ) (zip [0..] (zip barHts items))+ in padLeft yLabelW (yLabels !! rowIdx) ++ " │" ++ barCells+ | rowIdx <- [0..h-1]+ ]++ xAxisW = nBars * barW + nBars - 1+ xAxis = replicate (yLabelW + 2) ' ' ++ replicate xAxisW '─'+ barLabels = replicate (yLabelW + 2) ' ' +++ intercalate " " [ take barW (nm ++ replicate barW ' ') | BarItem _ nm _ <- items ]++ in intercalate "\n" (gridLines ++ [xAxis, barLabels])++-- | Create a vertical bar chart+plotBar :: Int -> Int -> [BarItem] -> L+plotBar w h items = L (BarChartData items w h)++-- Stacked Bar Chart -------------------------------------------------------++-- | A group of stacked bars: segments and group label+data StackedBarGroup = StackedBarGroup [BarItem] String++data StackedBarChartData = StackedBarChartData [StackedBarGroup] Int Int++instance Element StackedBarChartData where+ renderElement (StackedBarChartData [] _ _) = "No data"+ renderElement (StackedBarChartData groups w h) =+ let maxTotal = maximum [ sum [ v | BarItem v _ _ <- segs ] | StackedBarGroup segs _ <- groups ]+ nGroups = length groups+ barW = max 1 $ (w - nGroups + 1) `div` nGroups+ totalSub = h * 8++ groupBounds = map (\(StackedBarGroup segs _) ->+ let vals = [ v | BarItem v _ _ <- segs ]+ subHts = map (\v -> round (v / maxTotal * fromIntegral totalSub) :: Int) vals+ cumHts = scanl (+) 0 subHts+ bottoms = init cumHts+ tops = tail cumHts+ in zip segs (zip bottoms tops)+ ) groups++ allLabels = nub [ nm | StackedBarGroup segs _ <- groups, BarItem _ nm _ <- segs ]+ labelIdx nm = case lookup nm (zip allLabels [0..]) of+ Just i -> i+ Nothing -> 0++ yTicks = [ maxTotal * fromIntegral (h - 1 - i) / fromIntegral (max 1 (h - 1)) | i <- [0..h-1] ]+ yLabels = map formatAxisNum yTicks+ yLabelW = maximum (0 : map length yLabels)++ gridLines =+ [ let r = h - 1 - rowIdx+ subBot = r * 8+ subTop = r * 8 + 8+ barCells = intercalate " " $+ map (\bounds ->+ let overlapping = [ (bi, bot, top)+ | (bi, (bot, top)) <- bounds+ , top > subBot, bot < subTop ]+ topSeg = case overlapping of+ [] -> Nothing+ _ -> Just $ foldl1 (\a@(_, _, t1) b@(_, _, t2) ->+ if t2 > t1 then b else a) overlapping+ in case topSeg of+ Nothing -> replicate barW ' '+ Just (BarItem _ nm cl, _, top) ->+ let filled = min 8 $ max 0 (top - subBot)+ color' = case cl of+ ColorDefault -> pickColor (labelIdx nm) ColorDefault+ _ -> cl+ barStr = replicate barW (blockChars !! filled)+ in if filled > 0 then wrapAnsi color' barStr else barStr+ ) groupBounds+ in padLeft yLabelW (yLabels !! rowIdx) ++ " │" ++ barCells+ | rowIdx <- [0..h-1]+ ]++ xAxisW = nGroups * barW + nGroups - 1+ xAxis = replicate (yLabelW + 2) ' ' ++ replicate xAxisW '─'+ grpLabels = replicate (yLabelW + 2) ' ' +++ intercalate " " [ take barW (nm ++ replicate barW ' ')+ | StackedBarGroup _ nm <- groups ]++ legendItems = map (\nm ->+ let i = labelIdx nm+ c = defaultPalette !! (i `mod` length defaultPalette)+ in wrapAnsi c "█" ++ " " ++ nm+ ) allLabels+ legendLine+ | length allLabels <= 1 = []+ | otherwise = ["", intercalate " " legendItems]++ in intercalate "\n" (gridLines ++ [xAxis, grpLabels] ++ legendLine)++-- | Create a stacked vertical bar chart+plotStackedBar :: Int -> Int -> [StackedBarGroup] -> L+plotStackedBar w h groups = L (StackedBarChartData groups w h)++-- Heatmap -----------------------------------------------------------++-- | Heatmap data: grid of values, row labels, column labels+data HeatmapData = HeatmapData [[Double]] [String] [String]++data HeatmapElement = HeatmapElement HeatmapData Int -- data, cellWidth++instance Element HeatmapElement where+ renderElement (HeatmapElement (HeatmapData [] _ _) _) = "No data"+ renderElement (HeatmapElement (HeatmapData grid rowLbls colLbls) cellW) =+ let allVals = concat grid+ mn = minimum allVals+ mx = maximum allVals+ rng = if mx == mn then 1.0 else mx - mn+ normalize v = (v - mn) / rng++ toColor256 :: Double -> Int+ toColor256 t+ | t <= 0.0 = 21+ | t >= 1.0 = 196+ | t < 0.25 = let s = t / 0.25 in round (21.0 + s * 30.0)+ | t < 0.5 = let s = (t-0.25)/0.25 in round (51.0 + s * (-5.0))+ | t < 0.75 = let s = (t-0.5)/0.25 in round (46.0 + s * 180.0)+ | otherwise = let s = (t-0.75)/0.25 in round (226.0 + s * (-30.0))++ rowLblW = maximum (0 : map length rowLbls)++ header = replicate (rowLblW + 1) ' ' +++ intercalate " " (map (\l -> padRight cellW (take cellW l)) colLbls)++ dataRows = zipWith (\lbl rowVals ->+ padRight rowLblW (take rowLblW lbl) ++ " " +++ intercalate " " (map (\v ->+ let n = normalize v+ c256 = toColor256 n+ vs = formatAxisNum v+ in bgColor256 c256 ++ padRight cellW (take cellW vs) ++ ansiReset+ ) rowVals)+ ) rowLbls grid++ legendCs = map (\i -> toColor256 (fromIntegral i / 10.0)) [0..10 :: Int]+ legendBar = concatMap (\c -> bgColor256 c ++ " " ++ ansiReset) legendCs+ legendLine = replicate (rowLblW + 1) ' ' +++ formatAxisNum mn ++ " " ++ legendBar ++ " " ++ formatAxisNum mx++ in intercalate "\n" ([header] ++ dataRows ++ ["", legendLine])++-- | Create a heatmap with default cell width (6)+plotHeatmap :: HeatmapData -> L+plotHeatmap dat = L (HeatmapElement dat 6)++-- | Create a heatmap with custom cell width+plotHeatmap' :: Int -> HeatmapData -> L+plotHeatmap' cellW dat = L (HeatmapElement dat cellW)++-- ============================================================================+-- TUI Runtime - Simple event loop for interactive terminal applications+-- ============================================================================++-- | Keyboard input representation+data Key+ = KeyChar Char -- ^ Regular character keys: 'a', '1', ' ', etc.+ | KeyCtrl Char -- ^ Ctrl+key: KeyCtrl 'C', KeyCtrl 'Q', etc.+ | KeyEnter -- ^ Enter/Return key+ | KeyBackspace -- ^ Backspace key+ | KeyTab -- ^ Tab key+ | KeyEscape -- ^ Escape key+ | KeyDelete -- ^ Delete key+ | KeyUp -- ^ Up arrow+ | KeyDown -- ^ Down arrow+ | KeyLeft -- ^ Left arrow+ | KeyRight -- ^ Right arrow+ | KeyPageUp -- ^ Page Up+ | KeyPageDown -- ^ Page Down+ | KeyHome -- ^ Home+ | KeyEnd -- ^ End+ | KeySpecial String -- ^ Other unrecognized escape sequences+ deriving (Show, Eq)++-- | Commands - side effects the runtime will execute after each update+data Cmd msg+ = CmdNone -- ^ No effect+ | CmdRun (IO (Maybe msg)) -- ^ Run IO, optionally produce a message+ | CmdBatch [Cmd msg] -- ^ Combine multiple commands+ | CmdExit -- ^ Gracefully quit the application++-- | Create a command from an IO action (fire and forget)+cmdFire :: IO () -> Cmd msg+cmdFire io = CmdRun (io >> pure Nothing)++-- | Create a command that produces a message after IO completes+cmdTask :: IO msg -> Cmd msg+cmdTask io = CmdRun (Just <$> io)++-- | Create a command that fires a message after a delay+cmdAfterMs :: Int -> msg -> Cmd msg+cmdAfterMs delayMs msg = CmdRun (threadDelay (delayMs * 1000) >> pure (Just msg))++-- | Execute a command and return any resulting message.+-- Returns 'Nothing' for 'CmdExit' — the exit signal is handled by the runtime.+executeCmd :: Cmd msg -> IO (Maybe msg)+executeCmd CmdNone = pure Nothing+executeCmd CmdExit = pure Nothing+executeCmd (CmdRun io) = io+executeCmd (CmdBatch cmds) = do+ results <- mapM executeCmd cmds+ pure $ foldr pickFirst Nothing results+ where+ pickFirst (Just m) _ = Just m+ pickFirst Nothing r = r++-- | Check whether a command (or any sub-command in a batch) is 'CmdExit'.+cmdIsExit :: Cmd msg -> Bool+cmdIsExit CmdExit = True+cmdIsExit (CmdBatch cmds) = any cmdIsExit cmds+cmdIsExit _ = False++-- | Subscriptions - event sources your app listens to+data Sub msg+ = SubNone -- ^ No subscriptions+ | SubKeyPress (Key -> Maybe msg) -- ^ Subscribe to keyboard input+ | SubEveryMs Int msg -- ^ Subscribe to periodic ticks (interval in ms + message)+ | SubBatch [Sub msg] -- ^ Combine multiple subscriptions++-- | Combine multiple subscriptions+subBatch :: [Sub msg] -> Sub msg+subBatch = SubBatch++-- | Subscribe to keyboard events+subKeyPress :: (Key -> Maybe msg) -> Sub msg+subKeyPress = SubKeyPress++-- | Subscribe to periodic ticks with custom interval (milliseconds)+subEveryMs :: Int -> msg -> Sub msg+subEveryMs = SubEveryMs++-- | The core application structure - Elm Architecture style+--+-- Build interactive TUI apps by defining:+--+-- * Initial state and startup commands+-- * How to update state based on messages+-- * What events to subscribe to+-- * How to render state to UI+--+-- Example:+--+-- @+-- data CounterMsg = Inc | Dec+--+-- counterApp :: 'LayoutzApp' Int CounterMsg+-- counterApp = 'LayoutzApp'+-- { 'appInit' = (0, 'CmdNone')+-- , 'appUpdate' = \\msg count -> case msg of+-- 'Inc' -> (count + 1, 'CmdNone')+-- 'Dec' -> (count - 1, 'CmdNone')+-- , 'appSubscriptions' = \\_ -> 'subKeyPress' $ \\key -> case key of+-- 'KeyChar' \'+\' -> Just 'Inc'+-- 'KeyChar' \'-\' -> Just 'Dec'+-- _ -> Nothing+-- , 'appView' = \\count -> 'layout' ['text' $ "Count: " <> show count]+-- }+-- @+data LayoutzApp state msg = LayoutzApp+ { appInit :: (state, Cmd msg) -- ^ Initial state and startup commands+ , appUpdate :: msg -> state -> (state, Cmd msg) -- ^ Update state with message, return new state and commands+ , appSubscriptions :: state -> Sub msg -- ^ Declare event subscriptions based on current state+ , appView :: state -> L -- ^ Render state to UI+ }++-- | App-level alignment within the terminal window+data AppAlignment = AppAlignLeft | AppAlignCenter | AppAlignRight+ deriving (Show, Eq)++-- | Options for running a 'LayoutzApp'. Use 'defaultAppOptions' and override+-- the fields you care about:+--+-- @+-- 'runAppWith' 'defaultAppOptions' { 'optAlignment' = 'AppAlignCenter' } myApp+-- @+data AppOptions = AppOptions+ { optAlignment :: AppAlignment -- ^ Alignment of the app block in the terminal (default: 'AppAlignLeft')+ , optClearOnStart :: Bool -- ^ Enter alt screen and clear on start (default: 'True')+ , optClearOnExit :: Bool -- ^ Exit alt screen on quit (default: 'True')+ } deriving (Show, Eq)++-- | Sensible defaults: left-aligned, full-screen (alt screen on start\/exit).+defaultAppOptions :: AppOptions+defaultAppOptions = AppOptions+ { optAlignment = AppAlignLeft+ , optClearOnStart = True+ , optClearOnExit = True+ }++-- | Get terminal width via ANSI cursor position report (zero dependencies).+-- Moves cursor to far bottom-right, queries position, restores cursor.+-- Falls back to 80 columns on timeout or parse failure.+getTerminalWidth :: IO Int+getTerminalWidth = do+ -- Save cursor, move to 999;999, query position, restore cursor+ putStr "\ESC7\ESC[999;999H\ESC[6n\ESC8"+ hFlush stdout+ -- Terminal responds with: ESC [ rows ; cols R+ result <- timeout 100000 readCPR -- 100ms timeout+ pure $ maybe 80 id result+ where+ readCPR = do+ c <- getChar+ if c == '\ESC' then do+ c2 <- getChar+ if c2 == '[' then parseResponse ""+ else pure 80+ else pure 80+ parseResponse acc = do+ c <- getChar+ if c == 'R' then+ let resp = reverse acc+ in pure $ case break (== ';') resp of+ (_, ';':cols) -> case reads cols of+ [(n, "")] -> n+ _ -> 80+ _ -> 80+ else parseResponse (c : acc)++-- | Get terminal size as @(rows, cols)@ via an ANSI cursor position report.+-- Falls back to @(24, 80)@ on timeout or parse failure. Must be called while+-- raw mode is active and nothing else is reading stdin.+getTerminalSize :: IO (Int, Int)+getTerminalSize = do+ putStr "\ESC7\ESC[999;999H\ESC[6n\ESC8"+ hFlush stdout+ result <- timeout 100000 (readCPR "")+ pure $ maybe (24, 80) id result+ where+ readCPR acc = do+ c <- getChar+ case c of+ '\ESC' -> getChar >> readCPR acc -- skip ESC and the following '['+ '[' -> readCPR acc+ 'R' -> pure (parseRC (reverse acc))+ _ -> readCPR (c : acc)+ parseRC resp = case break (== ';') resp of+ (rows, ';':cols) -> (readOr 24 rows, readOr 80 cols)+ _ -> (24, 80)+ readOr d s = case reads s of+ [(n, "")] -> n+ _ -> d++-- | Run an interactive TUI application with default options.+--+-- This function:+--+-- * Sets up raw terminal mode (no echo, no buffering)+-- * Clears screen and hides cursor+-- * Enters event loop that:+--+-- * Listens to subscribed events (keyboard, ticks, etc.)+-- * Dispatches messages to update function+-- * Updates state and re-renders+--+-- * Restores terminal on exit (ESC, Ctrl+C, or Ctrl+D)+--+-- Press ESC, Ctrl+C, or Ctrl+D to quit the application.+runApp :: LayoutzApp state msg -> IO ()+runApp app = runAppWithFinal defaultAppOptions app >> pure ()++-- | Like 'runApp', but returns the final application state after exit.+-- Useful for interactive tweaking of state followed by further processing.+runAppFinal :: LayoutzApp state msg -> IO state+runAppFinal = runAppWithFinal defaultAppOptions++-- | Run an app inline — no alt screen, no clearing. The app renders in-place+-- below whatever is already on screen and returns when it issues 'CmdExit'.+-- Useful for embedding animated progress bars or spinners in scripts.+runInline :: LayoutzApp state msg -> IO ()+runInline app = runAppWithFinal defaultAppOptions+ { optClearOnStart = False, optClearOnExit = False } app >> pure ()++-- | Run an interactive TUI application with custom options.+--+-- @+-- 'runAppWith' 'defaultAppOptions' { 'optAlignment' = 'AppAlignCenter' } myApp+-- @+runAppWith :: AppOptions -> LayoutzApp state msg -> IO ()+runAppWith opts app = runAppWithFinal opts app >> pure ()++-- | Internal runtime event. Every source (keypresses, interval ticks, command+-- results) is funnelled into a single channel as one of these, so there is+-- exactly one consumer applying 'appUpdate' with no races on state+data AppEvent msg+ = AppMsg msg+ | AppExit++-- | Like 'runAppWith', but returns the final application state after exit.+-- Useful for interactive tweaking of state followed by further processing.+--+-- @+-- finalState <- 'runAppWithFinal' 'defaultAppOptions' { 'optAlignment' = 'AppAlignCenter' } myApp+-- @+runAppWithFinal :: AppOptions -> LayoutzApp state msg -> IO state+runAppWithFinal opts LayoutzApp{..} = do+ oldBuffering <- hGetBuffering stdin+ oldEcho <- hGetEcho stdin++ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ hSetEcho stdin False++ when (optClearOnStart opts) $ do+ enterAltScreen+ clearScreen+ hideCursor++ -- Query terminal width once, after raw mode is set, before threads+ termWidth <- getTerminalWidth++ let (initialState, initialCmd) = appInit++ stateRef <- newIORef initialState+ eventChan <- newChan -- Single event stream: keys, ticks, cmd results, exit+ cmdChan <- newChan -- Commands awaiting async execution++ let applyMsg msg = do+ cmdToRun <- atomicModifyIORef' stateRef $ \s ->+ let (newState, c) = appUpdate msg s in (newState, c)+ case cmdToRun of+ CmdNone -> pure ()+ CmdExit -> writeChan eventChan AppExit+ _ -> writeChan cmdChan cmdToRun++ cmdThread <- forkIO $ forever $ do+ cmdToRun <- readChan cmdChan+ when (cmdIsExit cmdToRun) $ writeChan eventChan AppExit+ maybeMsg <- executeCmd cmdToRun+ case maybeMsg of+ Just msg -> writeChan eventChan (AppMsg msg)+ Nothing -> pure ()++ case initialCmd of+ CmdNone -> pure ()+ _ -> writeChan cmdChan initialCmd++ lastLineCount <- newIORef 0+ lastRendered <- newIORef ""+ sentKittyIds <- newIORef IntSet.empty -- kitty images already transmitted this session++ renderThread <- forkIO $ forever $ do+ state <- readIORef stateRef+ let rendered = render (appView state)+ lastRender <- readIORef lastRendered++ when (rendered /= lastRender) $ do+ prevLineCount <- readIORef lastLineCount+ -- Drop transmit blocks for images already sent, so each distinct kitty+ -- image is uploaded only once across frames.+ priorIds <- readIORef sentKittyIds+ let (deduped, newKittyIds) = dedupeTransmits priorIds rendered+ writeIORef sentKittyIds newKittyIds+ let renderedLines = lines deduped+ currentLineCount = length renderedLines+ maxLineWidth = maximum (0 : map visibleLength renderedLines)+ blockPad = case optAlignment opts of+ AppAlignLeft -> 0+ AppAlignCenter -> max 0 ((termWidth - maxLineWidth) `div` 2)+ AppAlignRight -> max 0 (termWidth - maxLineWidth)+ padding = replicate blockPad ' '+ alignedLines = if blockPad > 0+ then map (padding ++) renderedLines+ else renderedLines+ moveUp = if optClearOnStart opts+ then "\ESC[H"+ else if prevLineCount > 0+ then "\ESC[" ++ show prevLineCount ++ "A\r"+ else ""+ output = moveUp ++ concatMap (\l -> l ++ "\ESC[K\n") alignedLines+ ++ concat (replicate (max 0 (prevLineCount - currentLineCount)) "\ESC[K\n")+ putStr output+ hFlush stdout+ writeIORef lastRendered rendered+ writeIORef lastLineCount currentLineCount++ threadDelay 33333++ let getKeyHandler sub = case sub of+ SubKeyPress handler -> Just handler+ SubBatch subs -> case [h | SubKeyPress h <- subs] of+ (h:_) -> Just h+ [] -> Nothing+ _ -> Nothing++ getTicks sub = case sub of+ SubEveryMs interval msg -> [(interval, msg)]+ SubBatch subs -> concatMap getTicks subs+ _ -> []++ tickThread <- forkIO $+ let tickLoop deadlines = do+ state <- readIORef stateRef+ now <- getMonotonicTimeNSec+ let ticks = getTicks (appSubscriptions state)+ nsOf ms = fromIntegral ms * 1000 * 1000+ intervals = foldr (\i acc -> if i `elem` acc then acc else i : acc)+ [] (map fst ticks)+ armed = [ (i, maybe (now + nsOf i) id (lookup i deadlines))+ | i <- intervals ]+ dueNow = [ i | (i, d) <- armed, d <= now ]+ fired = [ (i, msg) | (i, msg) <- ticks, i `elem` dueNow ]+ deadlines' = [ (i, if i `elem` dueNow+ then let nd = d + nsOf i+ in if nd <= now then now + nsOf i else nd+ else d)+ | (i, d) <- armed ]+ mapM_ (\(_, msg) -> writeChan eventChan (AppMsg msg)) fired+ threadDelay 5000 -- 5ms poll: bounds tick jitter without busy-waiting+ tickLoop deadlines'+ in tickLoop []++ -- Input thread: translate keypresses into events. Exit keys become AppExit;+ -- a closed stdin (EOF) is treated as a quit request, like Ctrl-D.+ inputThread <- forkIO $+ let readLoop = do+ key <- readKey+ case key of+ KeyEscape -> writeChan eventChan AppExit+ KeyCtrl 'C' -> writeChan eventChan AppExit+ KeyCtrl 'D' -> writeChan eventChan AppExit+ _ -> do+ state <- readIORef stateRef+ case getKeyHandler (appSubscriptions state) of+ Just handler -> maybe (pure ()) (writeChan eventChan . AppMsg) (handler key)+ Nothing -> pure ()+ readLoop+ in readLoop `catch` \e ->+ let _ = (e :: IOException) in writeChan eventChan AppExit++ let killThreads = killThread renderThread >> killThread cmdThread+ >> killThread tickThread >> killThread inputThread++ doCleanup = do+ killThreads+ showCursor+ when (optClearOnExit opts) exitAltScreen+ hFlush stdout+ hSetBuffering stdin oldBuffering+ hSetEcho stdin oldEcho++ dispatchLoop = do+ ev <- readChan eventChan+ case ev of+ AppExit -> pure () -- stop looping; `finally` restores the tty+ AppMsg msg -> applyMsg msg >> dispatchLoop++ -- Ctrl-C quits gracefully; every other exit path (normal quit, an+ -- exception from update/view, or an async kill) still restores the+ -- terminal via `finally`, so the tty is never left in raw mode.+ onAsync :: AsyncException -> IO ()+ onAsync UserInterrupt = pure ()+ onAsync e = throwIO e++ (dispatchLoop `catch` onAsync) `finally` doCleanup++ readIORef stateRef++-- | Clear the screen and move cursor to top-left+clearScreen :: IO ()+clearScreen = putStr "\ESC[2J\ESC[H"++-- | Hide the terminal cursor+hideCursor :: IO ()+hideCursor = putStr "\ESC[?25l"++-- | Show the terminal cursor+showCursor :: IO ()+showCursor = putStr "\ESC[?25h"++-- | Enter alternate screen buffer (like vim/less use)+enterAltScreen :: IO ()+enterAltScreen = putStr "\ESC[?1049h"++-- | Exit alternate screen buffer+exitAltScreen :: IO ()+exitAltScreen = putStr "\ESC[?1049l"++-- | Read a single key from stdin and parse it+readKey :: IO Key+readKey = do+ c <- getChar+ case ord c of+ 10 -> return KeyEnter -- LF (Unix)+ 13 -> return KeyEnter -- CR (Windows/Mac)+ 27 -> readEscapeSequence -- ESC - might be arrow key+ 9 -> return KeyTab+ 127 -> return KeyBackspace -- DEL (often used as backspace)+ 8 -> return KeyBackspace -- BS+ n | n >= 32 && n <= 126 -> return $ KeyChar (chr n) -- Printable ASCII+ | n < 32 -> return $ KeyCtrl (chr (n + 64)) -- Ctrl+Key+ | otherwise -> return $ KeyChar (chr n)++-- | Read escape sequence for arrow keys and other special keys+-- Uses a small timeout to distinguish between ESC key and ESC sequences+readEscapeSequence :: IO Key+readEscapeSequence = do+ -- Try to read next character with 50ms timeout+ -- If timeout, it's just ESC key; if character arrives, it's an escape sequence+ maybeChar <- timeout 50000 getChar -- 50000 microseconds = 50ms+ case maybeChar of+ Nothing -> return KeyEscape -- Timeout - just ESC key pressed+ Just '[' -> do+ -- It's an escape sequence, read the command character+ c2 <- getChar+ case c2 of+ 'A' -> return KeyUp+ 'B' -> return KeyDown+ 'C' -> return KeyRight+ 'D' -> return KeyLeft+ 'H' -> return KeyHome+ 'F' -> return KeyEnd+ -- Numeric sequences terminated by '~': ESC [ n ~+ n | n >= '1' && n <= '6' -> do+ c3 <- getChar+ if c3 == '~'+ then return $ case n of+ '1' -> KeyHome+ '3' -> KeyDelete+ '4' -> KeyEnd+ '5' -> KeyPageUp+ '6' -> KeyPageDown+ _ -> KeyEscape+ else return KeyEscape+ _ -> return KeyEscape+ Just 'O' -> do+ -- Application cursor mode: ESC O H/F for Home/End+ c2 <- getChar+ case c2 of+ 'H' -> return KeyHome+ 'F' -> return KeyEnd+ _ -> return KeyEscape+ Just _ -> return KeyEscape -- Some other character after ESC+++-- ============================================================================+-- Shared helpers (small string/ANSI utilities used by kitty, loader and Ask)+-- ============================================================================++-- | Dim a string with the SGR faint style.+dimText :: String -> String+dimText = wrapStyle StyleDim++-- | Colour a string, leaving it untouched for 'ColorDefault'.+paintColor :: Color -> String -> String+paintColor = wrapAnsi++-- | Split on a single character, keeping empty trailing segments (like+-- Scala's @split(sep, -1)@ — unlike 'lines', a trailing separator yields a+-- final empty segment).+splitOnChar :: Char -> String -> [String]+splitOnChar c s = case break (== c) s of+ (a, []) -> [a]+ (a, _:rest) -> a : splitOnChar c rest++-- | Split a string at the first occurrence of a substring pattern, returning+-- @(before, fromPattern)@ where @fromPattern@ begins with the pattern.+splitOnFirst :: String -> String -> Maybe (String, String)+splitOnFirst pat = go ""+ where+ go acc s+ | pat `isPrefixOf` s = Just (reverse acc, s)+ | otherwise = case s of+ [] -> Nothing+ (x:xs) -> go (x:acc) xs++-- | Break a list into chunks of at most @n@ elements.+chunksOf :: Int -> [a] -> [[a]]+chunksOf n xs+ | n <= 0 = [xs]+ | null xs = []+ | otherwise = let (a, b) = splitAt n xs in a : chunksOf n b++-- | ANSI background-colour SGR code corresponding to a foreground 'Color'.+bgColorCode :: Color -> String+bgColorCode ColorDefault = ""+bgColorCode (ColorFull n) = "48;5;" ++ show (clamp n)+bgColorCode (ColorTrue r g b) = "48;2;" ++ show (clamp r) ++ ";" ++ show (clamp g) ++ ";" ++ show (clamp b)+bgColorCode c = case reads (colorCode c) :: [(Int, String)] of+ [(n, "")] -> show (n + 10) -- 30-37 -> 40-47, 90-97 -> 100-107+ _ -> ""++-- ============================================================================+-- Kitty graphics protocol+-- ============================================================================++-- | Kitty transmit format: PNG.+formatPng :: Int+formatPng = 100++-- | Kitty transmit format: raw RGB (3 bytes/pixel).+formatRgb :: Int+formatRgb = 24++-- | Kitty transmit format: raw RGBA (4 bytes/pixel).+formatRgba :: Int+formatRgba = 32++-- | An inline image rendered via the kitty graphics protocol using Unicode+-- placeholders, so it composes like any other element: it measures exactly+-- @cols@ wide and @rows@ tall and drops into 'box', 'row', 'table', 'center', …+--+-- Prefer the smart constructors 'kittyImage', 'kittyRGB', 'kittyRGBA' (or the+-- 'kittyImageFile' loader) over building this record directly.+data KittyImage = KittyImage+ { kiPayload :: [Word8] -- ^ Raw image bytes (PNG, or raw RGB\/RGBA pixels)+ , kiFormat :: Int -- ^ 100 = PNG, 24 = RGB, 32 = RGBA+ , kiCols :: Int -- ^ Cell width+ , kiRows :: Int -- ^ Cell height+ , kiPxW :: Int -- ^ Source pixel width (raw formats only)+ , kiPxH :: Int -- ^ Source pixel height (raw formats only)+ , kiAlt :: String -- ^ Alt text (kept for parity; unused by terminals)+ , kiIdOverride :: Maybe Int -- ^ Explicit image id (otherwise a content hash)+ }++instance Element KittyImage where+ renderElement img = kittyTransmit img ++ kittyPlacement img+ width = kiCols+ height = kiRows++-- | Deterministic 24-bit image id: an explicit override, or an FNV-1a hash of+-- the payload masked to 24 bits (forced non-zero). Stable across redraws so a+-- runtime can transmit each distinct image only once.+kittyImageId :: [Word8] -> Maybe Int -> Int+kittyImageId payload override =+ let raw = maybe (foldl step 0x811c9dc5 payload) id override+ masked = raw .&. 0xffffff+ in if masked == 0 then 1 else masked+ where+ step h b = (h `xor` fromIntegral b) * 0x01000193 .&. 0xffffffff++-- | Standard base64 (RFC 4648, @+/@ alphabet, @=@ padding). Shipped inline to+-- keep the library dependency-light.+kittyBase64 :: [Word8] -> String+kittyBase64 = go+ where+ alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"+ idx i = alphabet !! i+ go [] = ""+ go (b0:b1:b2:rest) =+ let t = (fromIntegral b0 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 8) .|. fromIntegral b2+ in idx ((t `shiftR` 18) .&. 0x3f) : idx ((t `shiftR` 12) .&. 0x3f)+ : idx ((t `shiftR` 6) .&. 0x3f) : idx (t .&. 0x3f) : go rest+ go [b0, b1] =+ let t = (fromIntegral b0 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 8) :: Int+ in idx ((t `shiftR` 18) .&. 0x3f) : idx ((t `shiftR` 12) .&. 0x3f)+ : idx ((t `shiftR` 6) .&. 0x3f) : "="+ go [b0] =+ let t = fromIntegral b0 `shiftL` 16 :: Int+ in idx ((t `shiftR` 18) .&. 0x3f) : idx ((t `shiftR` 12) .&. 0x3f) : "=="++kittyApcG :: String+kittyApcG = "\ESC_G"++kittyST :: String+kittyST = "\ESC\\"++-- | Transmit block: base64 the payload, chunk into <=4096-char escapes. Every+-- chunk carries @i=\<id\>@ so 'dedupeTransmits' can drop all chunks of an+-- already-sent image.+kittyTransmit :: KittyImage -> String+kittyTransmit img =+ let b64 = kittyBase64 (kiPayload img)+ chunks = if null b64 then [""] else chunksOf 4096 b64+ theId = kittyImageId (kiPayload img) (kiIdOverride img)+ dims = if kiFormat img == formatPng then ""+ else ",s=" ++ show (kiPxW img) ++ ",v=" ++ show (kiPxH img)+ firstKeys = "a=T,U=1,i=" ++ show theId ++ ",f=" ++ show (kiFormat img)+ ++ ",c=" ++ show (kiCols img) ++ ",r=" ++ show (kiRows img) ++ dims ++ ",q=2"+ contKeys = "i=" ++ show theId ++ ",q=2"+ lastIdx = length chunks - 1+ block i chunk =+ let m = if i == lastIdx then "0" else "1"+ keys = (if i == 0 then firstKeys else contKeys) ++ ",m=" ++ m+ in kittyApcG ++ keys ++ ";" ++ chunk ++ kittyST+ in concat (zipWith block [0 ..] chunks)++-- | Placement grid: one line per image row of @U+10EEEE@ placeholders; the+-- image id rides in the foreground colour and the (row, column) in two+-- combining diacritics on the first cell of each row.+kittyPlacement :: KittyImage -> String+kittyPlacement img =+ let theId = kittyImageId (kiPayload img) (kiIdOverride img)+ fg = "\ESC[38;2;" ++ show ((theId `shiftR` 16) .&. 0xff) ++ ";"+ ++ show ((theId `shiftR` 8) .&. 0xff) ++ ";" ++ show (theId .&. 0xff) ++ "m"+ reset = "\ESC[0m"+ placeholder = [kittyPlaceholderChar]+ col0 = [chr (head rowColumnDiacritics)]+ rowLine r =+ let firstCell = placeholder ++ [chr (rowColumnDiacritics !! r)] ++ col0+ in fg ++ firstCell ++ concat (replicate (kiCols img - 1) placeholder) ++ reset+ in intercalate "\n" (map rowLine [0 .. kiRows img - 1])++-- | Strip transmit blocks whose image id is already in the seen-set, adding+-- new ids as they are encountered. Returns the rewritten string and the+-- updated set. Placement grids are always left intact.+dedupeTransmits :: IntSet.IntSet -> String -> (String, IntSet.IntSet)+dedupeTransmits ids0 input = go ids0 input+ where+ go ids s = case splitOnFirst kittyApcG s of+ Nothing -> (s, ids)+ Just (before, rest) ->+ let (block, after) = takeBlock rest+ bid = parseId block+ (keep, ids')+ | bid /= 0 && IntSet.member bid ids = ("", ids)+ | bid /= 0 = (block, IntSet.insert bid ids)+ | otherwise = (block, ids)+ (restOut, idsF) = go ids' after+ in (before ++ keep ++ restOut, idsF)++ -- @s@ starts with the APC introducer; return (whole block incl. ST, rest).+ takeBlock s = case splitOnFirst kittyST (drop (length kittyApcG) s) of+ Nothing -> (s, "") -- unterminated: keep verbatim+ Just (mid, after) -> (kittyApcG ++ mid ++ kittyST, drop (length kittyST) after)++ parseId block =+ let body = drop (length kittyApcG) block+ keys = takeWhile (/= ';') body+ fields = splitOnChar ',' keys+ in case [ drop 2 f | f <- fields, "i=" `isPrefixOf` f ] of+ (v:_) -> let ds = takeWhile isDigit v in if null ds then 0 else read ds+ [] -> 0++-- | Validate dimensions/format and build a 'KittyImage'.+mkKitty :: [Word8] -> Int -> Int -> Int -> Int -> Int -> String -> KittyImage+mkKitty payload fmt cols rows pxW pxH alt+ | cols < 1 || rows < 1 = error "KittyImage cols/rows must be >= 1"+ | cols > maxCells || rows > maxCells =+ error ("KittyImage cols/rows must be <= " ++ show maxCells ++ " (the diacritics table size)")+ | not validFormat =+ error "raw RGB/RGBA images (format 24/32) require pxW > 0 and pxH > 0"+ | otherwise = KittyImage payload fmt cols rows pxW pxH alt Nothing+ where+ maxCells = length rowColumnDiacritics+ validFormat = fmt == formatPng+ || ((fmt == formatRgb || fmt == formatRgba) && pxW > 0 && pxH > 0)++-- | Inline PNG image sized to a @cols@x@rows@ cell footprint. The terminal+-- decodes the PNG and fits it into that box; layout math uses @cols@\/@rows@.+kittyImage :: [Word8] -> Int -> Int -> L+kittyImage bytes cols rows = L (mkKitty bytes formatPng cols rows 0 0 "")++-- | Inline raw RGB image (@format 24@): @pxW@x@pxH@ source pixels shown in a+-- @cols@x@rows@ cell footprint.+kittyRGB :: [Word8] -> Int -> Int -> Int -> Int -> L+kittyRGB pixels pxW pxH cols rows = L (mkKitty pixels formatRgb cols rows pxW pxH "")++-- | Inline raw RGBA image (@format 32@): like 'kittyRGB' with an alpha channel.+kittyRGBA :: [Word8] -> Int -> Int -> Int -> Int -> L+kittyRGBA pixels pxW pxH cols rows = L (mkKitty pixels formatRgba cols rows pxW pxH "")++-- | Load an image file and size it to a @cols@x@rows@ cell footprint. PNG bytes+-- are sent to the terminal as-is.+kittyImageFile :: FilePath -> Int -> Int -> IO L+kittyImageFile path cols rows = do+ bytes <- readFileBytes path+ pure (kittyImage bytes cols rows)++-- | Read a file strictly as a list of bytes (binary mode, no dependencies).+readFileBytes :: FilePath -> IO [Word8]+readFileBytes path = withBinaryFile path ReadMode $ \h -> do+ contents <- hGetContents h+ let n = length contents+ n `seq` pure (map (fromIntegral . ord) contents)++-- ============================================================================+-- Progress loaders+-- ============================================================================++-- | Visual preset for a 'loader'. Controls the bar glyphs and colour for+-- bounded loaders, and the spinner frames + colour for streaming loaders.+data LoaderStyle = LoaderStyle+ { lsFill :: Char+ , lsEmpty :: Char+ , lsOpen :: String+ , lsClose :: String+ , lsHead :: String+ , lsSmooth :: Bool+ , lsSpinner :: SpinnerStyle+ , lsColor :: Color+ }++-- | Smooth gradient blocks @████▊░░░@ (default).+styleBlocks :: LoaderStyle+styleBlocks = LoaderStyle '█' '░' "" "" "" True SpinnerGrow ColorCyan++-- | Classic bracketed bar @[██████░░░░]@.+styleBar :: LoaderStyle+styleBar = LoaderStyle '█' '░' "[" "]" "" False SpinnerDots ColorGreen++-- | Retro ASCII with an arrow head @[====> ]@.+styleAscii :: LoaderStyle+styleAscii = LoaderStyle '=' ' ' "[" "]" ">" False SpinnerLine ColorYellow++-- | Dotted @●●●●∙∙∙∙@.+styleDots :: LoaderStyle+styleDots = LoaderStyle '●' '∙' "" "" "" False SpinnerBounce ColorMagenta++-- | Heavy\/light rule @━━━━────@.+styleLine :: LoaderStyle+styleLine = LoaderStyle '━' '─' "" "" "" False SpinnerLine ColorBlue++-- | Segmented pipes @▰▰▰▱▱▱@.+stylePipes :: LoaderStyle+stylePipes = LoaderStyle '▰' '▱' "" "" "" False SpinnerArrow ColorBrightMagenta++-- | All built-in styles, in display order.+loaderStyles :: [LoaderStyle]+loaderStyles = [styleBlocks, styleBar, styleAscii, styleDots, styleLine, stylePipes]++-- | Fractional block glyphs for the smooth-fill boundary cell (1\/8 .. 8\/8).+blockEighths :: [String]+blockEighths = ["", "▏", "▎", "▍", "▌", "▋", "▊", "▉"]++-- | Render a progress bar of the given style filled to @progress@ (0..1) over+-- @w@ cells.+renderProgressBar :: LoaderStyle -> Double -> Int -> String+renderProgressBar style progress w =+ let p = max 0.0 (min 1.0 progress)+ exact = p * fromIntegral w+ filled = floor exact :: Int+ in if lsSmooth style+ then let eighths = floor ((exact - fromIntegral filled) * 8) :: Int+ hasPartial = filled < w && eighths > 0+ partial = if hasPartial then blockEighths !! eighths else ""+ used = filled + (if hasPartial then 1 else 0)+ body = paintColor (lsColor style) (replicate filled (lsFill style) ++ partial)+ in lsOpen style ++ body ++ dimText (replicate (w - used) (lsEmpty style)) ++ lsClose style+ else let showHead = not (null (lsHead style)) && filled > 0 && filled < w+ hd = if showHead then lsHead style else ""+ emptyCount = max 0 (w - filled - length hd)+ body = paintColor (lsColor style) (replicate filled (lsFill style) ++ hd)+ in lsOpen style ++ body ++ dimText (replicate emptyCount (lsEmpty style)) ++ lsClose style++-- | Run an inline progress line: a background ticker redraws @renderLine@ every+-- 80ms while the main thread maps @action@ over @items@, bumping @counter@ per+-- item. On completion the ticker stops and @finalLine@ is drawn.+runLoader :: (Int -> IO String) -> IO String -> IORef Int -> [a] -> (a -> IO b) -> IO [b]+runLoader renderLine finalLine counter items action = do+ hideCursor+ hFlush stdout+ stopRef <- newIORef False+ ticker <- forkIO $+ let tick frame = do+ stop <- readIORef stopRef+ unless stop $ do+ line <- renderLine frame+ putStr ("\r" ++ line ++ "\ESC[K")+ hFlush stdout+ threadDelay 80000+ tick (frame + 1)+ in tick 0+ results <- mapM (\x -> do r <- action x; modifyIORef' counter (+ 1); pure r) items+ writeIORef stopRef True+ killThread ticker+ final <- finalLine+ putStr ("\r" ++ final ++ "\ESC[K\n")+ showCursor+ hFlush stdout+ pure results++boundedRender :: LoaderStyle -> String -> Int -> IORef Int -> Int -> IO String+boundedRender style label total counter _frame = do+ done <- readIORef counter+ let progress = if total > 0 then min 1.0 (fromIntegral done / fromIntegral total) else 1.0+ bar = renderProgressBar style progress 20+ pct = floor (progress * 100) :: Int+ prefix = if null label then "" else label ++ " "+ pure (prefix ++ bar ++ " " ++ show done ++ "/" ++ show total ++ " (" ++ show pct ++ "%)")++streamingRender :: LoaderStyle -> String -> IORef Int -> Int -> IO String+streamingRender style label counter frame = do+ done <- readIORef counter+ let frames = spinnerFrames (lsSpinner style)+ spin = paintColor (lsColor style) (frames !! (frame `mod` length frames))+ prefix = if null label then "" else label ++ " "+ pure (spin ++ " " ++ prefix ++ "(" ++ show done ++ " processed)")++streamingFinal :: String -> IORef Int -> IO String+streamingFinal label counter = do+ done <- readIORef counter+ let prefix = if null label then "" else label ++ " "+ pure (prefix ++ show done ++ " processed")++-- | Iterate a sized collection while streaming an inline progress bar (blocks+-- style). Returns the results of @action@ over each item.+--+-- @+-- _ <- 'loader' "Processing" [1..100] (\\_ -> threadDelay 20000)+-- @+loader :: String -> [a] -> (a -> IO b) -> IO [b]+loader = loaderStyled styleBlocks++-- | Like 'loader' with an explicit 'LoaderStyle' (e.g. 'styleAscii').+loaderStyled :: LoaderStyle -> String -> [a] -> (a -> IO b) -> IO [b]+loaderStyled style label items action = do+ let total = length items+ counter <- newIORef 0+ let rl = boundedRender style label total counter+ runLoader rl (rl 0) counter items action++-- | Iterate a collection of unknown \"size\", streaming a spinner + running+-- count (blocks style spinner).+loaderStream :: String -> [a] -> (a -> IO b) -> IO [b]+loaderStream = loaderStreamStyled styleBlocks++-- | Like 'loaderStream' with an explicit 'LoaderStyle'.+loaderStreamStyled :: LoaderStyle -> String -> [a] -> (a -> IO b) -> IO [b]+loaderStreamStyled style label items action = do+ counter <- newIORef 0+ runLoader (streamingRender style label counter) (streamingFinal label counter) counter items action++-- ============================================================================+-- Interactive prompts (Ask)+-- ============================================================================+--+-- One-shot prompts. Each takes over the tty briefly, returns a value, and+-- leaves a single committed line behind. 'Nothing' means the user cancelled+-- (Esc / Ctrl-C / Ctrl-D).++askCursorUp :: Int -> String+askCursorUp n = "\ESC[" ++ show n ++ "A\r"++askClearEol :: String+askClearEol = "\ESC[K"++askClearBelow :: String+askClearBelow = "\ESC[J"++-- | Put the tty into raw mode, hide the cursor, run the body, and restore the+-- terminal afterwards (even on exception).+withAskTty :: IO a -> IO a+withAskTty body = do+ oldBuffering <- hGetBuffering stdin+ oldEcho <- hGetEcho stdin+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ hSetEcho stdin False+ hideCursor+ body `finally` do+ showCursor+ hSetEcho stdin oldEcho+ hSetBuffering stdin oldBuffering+ hFlush stdout++-- | Redraw a multi-line frame in place, returning its line count.+askRepaint :: String -> Int -> IO Int+askRepaint frame prevLines = do+ let ls = splitOnChar '\n' frame+ up = if prevLines > 0 then askCursorUp prevLines else ""+ body = concatMap (\l -> l ++ askClearEol ++ "\n") ls+ belw = if prevLines > length ls then askClearBelow else ""+ putStr (up ++ body ++ belw)+ hFlush stdout+ pure (length ls)++-- | Replace the live frame with a single committed summary line.+askCommit :: String -> Int -> IO ()+askCommit summary prevLines = do+ let up = if prevLines > 0 then askCursorUp prevLines else ""+ belw = if prevLines > 1 then askClearBelow else ""+ putStr (up ++ summary ++ askClearEol ++ "\n" ++ belw)+ hFlush stdout++-- | Wipe the live frame entirely (used on cancel).+askErase :: Int -> IO ()+askErase prevLines = when (prevLines > 0) $ do+ putStr (askCursorUp prevLines ++ askClearBelow)+ hFlush stdout++-- | Render an active confirm button (white on a coloured background, bold).+askActiveBtn :: Color -> String -> String+askActiveBtn bg t = "\ESC[1;37;" ++ bgColorCode bg ++ "m" ++ t ++ "\ESC[0m"++renderInputFrame :: String -> String -> String -> String+renderInputFrame prompt value placeholder =+ let body = if null value && not (null placeholder) then dimText placeholder else value+ in prompt ++ body ++ paintColor ColorCyan "▌"++renderConfirmFrame :: String -> Bool -> String -> String -> String+renderConfirmFrame question yes affirmative negative =+ question ++ "\n " ++ btn affirmative yes ColorGreen ++ " " ++ btn negative (not yes) ColorRed+ where+ btn t active bg = let padded = " " ++ t ++ " "+ in if active then askActiveBtn bg padded else padded++renderChooseFrame :: String -> [a] -> Int -> (a -> String) -> String+renderChooseFrame prompt items idx renderItem =+ let rows = [ if i == idx then paintColor ColorCyan ("› " ++ renderItem item) else " " ++ renderItem item+ | (item, i) <- zip items [0 ..] ]+ in (if not (null prompt) then prompt ++ "\n" else "") ++ intercalate "\n" rows++renderChooseManyFrame :: String -> [a] -> Int -> [Int] -> Int -> (a -> String) -> String+renderChooseManyFrame prompt items idx selected limit renderItem =+ let rows = [ let mark = if i `elem` selected then paintColor ColorGreen "[x]" else dimText "[ ]"+ line = mark ++ " " ++ renderItem item+ in if i == idx then paintColor ColorCyan "› " ++ line else " " ++ line+ | (item, i) <- zip items [0 ..] ]+ header+ | null prompt = ""+ | otherwise =+ let tag | limit > 0 = " (" ++ show (length selected) ++ "/" ++ show limit ++ ")"+ | not (null selected) = " (" ++ show (length selected) ++ ")"+ | otherwise = ""+ in prompt ++ dimText tag ++ "\n"+ in header ++ intercalate "\n" rows++renderWriteFrame :: String -> String -> String -> String -> String+renderWriteFrame prompt value placeholder hint =+ let header = if not (null prompt) then prompt ++ "\n" else ""+ body = if null value && not (null placeholder)+ then dimText placeholder ++ paintColor ColorCyan "▌"+ else value ++ paintColor ColorCyan "▌"+ footer = if not (null hint) then "\n" ++ dimText hint else ""+ in header ++ body ++ footer++renderFilterFrame :: String -> String -> [a] -> Int -> Int -> (a -> String) -> String+renderFilterFrame prompt query matches idx viewHeight renderItem =+ let total = length matches+ h = max 0 (min viewHeight total)+ top = if total <= h then 0 else max 0 (min (idx - h `div` 2) (total - h))+ visible = take h (drop top matches)+ rows = [ let absIdx = top + i; label = renderItem item+ in if absIdx == idx then paintColor ColorCyan ("› " ++ label) else " " ++ label+ | (item, i) <- zip visible [0 ..] ]+ header = prompt ++ query ++ paintColor ColorCyan "▌"+ list = if null rows then dimText " (no matches)" else intercalate "\n" rows+ in header ++ "\n" ++ list++-- | Fuzzy-match score: 'Nothing' if @query@ isn't a subsequence of @target@,+-- otherwise @Just gap@ where a smaller gap sum means a tighter match.+fuzzyScore :: String -> String -> Maybe Int+fuzzyScore query target+ | null query = Just 0+ | otherwise = loop (map toLower query) (map toLower target) (-1) 0 0+ where+ loop [] _ _ gap _ = Just gap+ loop _ [] _ _ _ = Nothing+ loop (qc:qs) (sc:ss) lastMatch gap ti+ | qc == sc = let gap' = if lastMatch >= 0 then gap + (ti - lastMatch - 1) else gap+ in loop qs ss ti gap' (ti + 1)+ | otherwise = loop (qc:qs) ss lastMatch gap (ti + 1)++-- | Filter items to those matching @query@, best (tightest) matches first.+fuzzyMatches :: String -> [a] -> (a -> String) -> [a]+fuzzyMatches query items renderItem+ | null query = items+ | otherwise = map fst $ sortOn snd+ [ (item, score) | item <- items, Just score <- [fuzzyScore query (renderItem item)] ]++-- | A directory entry for the file picker.+data FileEntry = FileEntry { feName :: String, feIsDir :: Bool }++feDisplay :: FileEntry -> String+feDisplay e = if feIsDir e then feName e ++ "/" else feName e++renderFileFrame :: String -> [FileEntry] -> Int -> Int -> String+renderFileFrame path entries idx viewHeight =+ let total = length entries+ h = max 0 (min viewHeight total)+ top = if total <= h then 0 else max 0 (min (idx - h `div` 2) (total - h))+ visible = take h (drop top entries)+ rows = [ let absIdx = top + i+ name = if feIsDir e then paintColor ColorBlue (feDisplay e) else feDisplay e+ in if absIdx == idx then paintColor ColorCyan "› " ++ name else " " ++ name+ | (e, i) <- zip visible [0 ..] ]+ in dimText path ++ "\n" ++ intercalate "\n" rows++renderPagerFrame :: [String] -> Int -> Int -> Int -> Bool -> String+renderPagerFrame allLines top h viewWidth lineNumbers =+ let total = length allLines+ visible = take h (drop top allLines)+ numWidth = length (show total)+ gutter = if lineNumbers then numWidth + 3 else 0+ maxLineW = max 20 (viewWidth - gutter)+ body = intercalate "\n"+ [ let truncated = if length line > maxLineW then take (maxLineW - 1) line ++ "…" else line+ in if lineNumbers+ then dimText (padNum numWidth (top + i + 1) ++ " │ ") ++ truncated+ else truncated+ | (line, i) <- zip visible [0 ..] ]+ viewEnd = min (top + h) total+ percent = if total == 0 then 100 else (viewEnd * 100) `div` total+ status = dimText (" L" ++ show (top + 1) ++ "–" ++ show viewEnd ++ " of " ++ show total+ ++ " " ++ show percent ++ "% ↑↓ PgUp/PgDn Home/End q to quit")+ in body ++ "\n" ++ status+ where+ padNum w n = let s = show n in replicate (max 0 (w - length s)) ' ' ++ s++-- | Prompt for a single line of text. Returns 'Nothing' if cancelled.+askInput :: String -- ^ prompt (e.g. @"› "@)+ -> String -- ^ placeholder shown when empty+ -> String -- ^ initial value+ -> IO (Maybe String)+askInput prompt placeholder initial = withAskTty $ do+ initLines <- askRepaint (renderInputFrame prompt initial placeholder) 0+ let loop value prevLines = do+ key <- readKey+ case key of+ KeyEnter -> askCommit (prompt ++ value) prevLines >> pure (Just value)+ KeyEscape -> askErase prevLines >> pure Nothing+ KeyCtrl 'C' -> askErase prevLines >> pure Nothing+ KeyCtrl 'D' -> askErase prevLines >> pure Nothing+ KeyBackspace | not (null value) -> do+ let nv = init value+ n <- askRepaint (renderInputFrame prompt nv placeholder) prevLines+ loop nv n+ KeyChar c -> do+ let nv = value ++ [c]+ n <- askRepaint (renderInputFrame prompt nv placeholder) prevLines+ loop nv n+ _ -> loop value prevLines+ loop initial initLines++-- | Yes\/No confirmation. On cancel returns the opposite of @def@ (matching the+-- Scala @Ask.confirm@).+askConfirm :: String -- ^ question+ -> Bool -- ^ default selection+ -> String -- ^ affirmative label (e.g. @"Yes"@)+ -> String -- ^ negative label (e.g. @"No"@)+ -> IO Bool+askConfirm question def affirmative negative = do+ r <- withAskTty $ do+ initLines <- askRepaint (renderConfirmFrame question def affirmative negative) 0+ let picked yes prevLines = do+ let label = if yes then affirmative else negative+ askCommit (question ++ " " ++ paintColor ColorCyan label) prevLines+ pure (Just yes)+ loop yes prevLines = do+ let flipSel = do+ let ny = not yes+ n <- askRepaint (renderConfirmFrame question ny affirmative negative) prevLines+ loop ny n+ key <- readKey+ case key of+ KeyEnter -> picked yes prevLines+ KeyChar c | c `elem` ("yY" :: String) -> picked True prevLines+ | c `elem` ("nN" :: String) -> picked False prevLines+ KeyLeft -> flipSel+ KeyRight -> flipSel+ KeyTab -> flipSel+ KeyEscape -> askErase prevLines >> pure (Just (not def))+ KeyCtrl 'C' -> askErase prevLines >> pure (Just (not def))+ KeyCtrl 'D' -> askErase prevLines >> pure (Just (not def))+ _ -> loop yes prevLines+ loop def initLines+ pure (maybe def id r)++-- | Single-choice menu. Returns 'Nothing' if cancelled or @items@ is empty.+askChoose :: String -> [a] -> (a -> String) -> IO (Maybe a)+askChoose prompt items renderItem+ | null items = pure Nothing+ | otherwise = withAskTty $ do+ initLines <- askRepaint (renderChooseFrame prompt items 0 renderItem) 0+ let n = length items+ loop idx prevLines = do+ let move ni = do+ pl <- askRepaint (renderChooseFrame prompt items ni renderItem) prevLines+ loop ni pl+ key <- readKey+ case key of+ KeyEnter -> do+ let pick = items !! idx+ askCommit (prompt ++ " " ++ paintColor ColorCyan (renderItem pick)) prevLines+ pure (Just pick)+ KeyUp -> move ((idx - 1 + n) `mod` n)+ KeyDown -> move ((idx + 1) `mod` n)+ KeyTab -> move ((idx + 1) `mod` n)+ KeyEscape -> askErase prevLines >> pure Nothing+ KeyCtrl 'C' -> askErase prevLines >> pure Nothing+ KeyCtrl 'D' -> askErase prevLines >> pure Nothing+ _ -> loop idx prevLines+ loop 0 initLines++-- | Multi-choice menu. @limit@ of 0 means unlimited. Space\/Tab toggles the+-- current row; Enter commits. Returns 'Nothing' if cancelled or empty.+askChooseMany :: String -> [a] -> Int -> (a -> String) -> IO (Maybe [a])+askChooseMany prompt items limit renderItem+ | null items = pure Nothing+ | otherwise = withAskTty $ do+ let n = length items+ toggle i sel+ | i `elem` sel = filter (/= i) sel+ | limit > 0 && length sel >= limit = sel+ | otherwise = sel ++ [i]+ loop idx selected prevLines = do+ pl <- askRepaint (renderChooseManyFrame prompt items idx selected limit renderItem) prevLines+ key <- readKey+ case key of+ KeyEnter -> do+ let picks = [ item | (item, i) <- zip items [0 ..], i `elem` selected ]+ summary = if null picks+ then prompt ++ " " ++ dimText "(nothing)"+ else prompt ++ " " ++ paintColor ColorCyan (intercalate ", " (map renderItem picks))+ askCommit summary pl+ pure (Just picks)+ KeyUp -> loop ((idx - 1 + n) `mod` n) selected pl+ KeyDown -> loop ((idx + 1) `mod` n) selected pl+ KeyChar ' ' -> loop idx (toggle idx selected) pl+ KeyTab -> loop idx (toggle idx selected) pl+ KeyEscape -> askErase pl >> pure Nothing+ KeyCtrl 'C' -> askErase pl >> pure Nothing+ KeyCtrl 'D' -> askErase pl >> pure Nothing+ _ -> loop idx selected pl+ loop 0 [] 0++-- | Run @task@ while animating a spinner labelled @label@; print a ✓\/✗ line+-- when it finishes. Re-throws if the task threw.+askSpin :: String -> SpinnerStyle -> IO a -> IO a+askSpin label style task = do+ hideCursor+ hFlush stdout+ stopRef <- newIORef False+ ticker <- forkIO $+ let tick i = do+ stop <- readIORef stopRef+ unless stop $ do+ let frames = spinnerFrames style+ frame = paintColor ColorCyan (frames !! (i `mod` length frames)) ++ " " ++ label+ putStr ("\r" ++ frame ++ askClearEol)+ hFlush stdout+ threadDelay 80000+ tick (i + 1)+ in tick 0+ outcome <- (Right <$> task) `catch` \e -> pure (Left (e :: SomeException))+ writeIORef stopRef True+ killThread ticker+ let (glyph, col) = case outcome of+ Right _ -> ("✓", ColorGreen)+ Left _ -> ("✗", ColorRed)+ putStr ("\r" ++ paintColor col (glyph ++ " " ++ label) ++ askClearEol ++ "\n")+ showCursor+ hFlush stdout+ case outcome of+ Right v -> pure v+ Left e -> throwIO e++-- | Multi-line text editor. Enter inserts a newline; Ctrl-D submits; Esc+-- cancels.+askWrite :: String -- ^ prompt+ -> String -- ^ placeholder+ -> String -- ^ initial value+ -> String -- ^ hint line+ -> IO (Maybe String)+askWrite prompt placeholder initial hint = withAskTty $ do+ let loop value prevLines = do+ pl <- askRepaint (renderWriteFrame prompt value placeholder hint) prevLines+ key <- readKey+ case key of+ KeyCtrl 'D' -> do+ let firstLine = case splitOnChar '\n' value of (x:_) -> x; [] -> ""+ summary = if '\n' `elem` value then firstLine ++ " …" else firstLine+ askCommit ((if not (null prompt) then prompt ++ " " else "") ++ paintColor ColorCyan summary) pl+ pure (Just value)+ KeyEscape -> askErase pl >> pure Nothing+ KeyCtrl 'C' -> askErase pl >> pure Nothing+ KeyEnter -> loop (value ++ "\n") pl+ KeyChar c -> loop (value ++ [c]) pl+ KeyBackspace | not (null value) -> loop (init value) pl+ _ -> loop value pl+ loop initial 0++-- | Fuzzy incremental filter over @items@. Type to narrow, arrows to move,+-- Enter to pick. Returns 'Nothing' if cancelled or empty.+askFilter :: String -> [a] -> Int -> (a -> String) -> IO (Maybe a)+askFilter prompt items viewHeight renderItem+ | null items = pure Nothing+ | otherwise = withAskTty $ do+ let loop query idx prevLines = do+ let matches = fuzzyMatches query items renderItem+ safeIdx = if null matches then 0 else max 0 (min idx (length matches - 1))+ m = length matches+ pl <- askRepaint (renderFilterFrame prompt query matches safeIdx viewHeight renderItem) prevLines+ key <- readKey+ case key of+ KeyEnter | not (null matches) -> do+ let pick = matches !! safeIdx+ askCommit (prompt ++ query ++ " " ++ paintColor ColorCyan (renderItem pick)) pl+ pure (Just pick)+ KeyUp | not (null matches) -> loop query ((safeIdx - 1 + m) `mod` m) pl+ KeyDown | not (null matches) -> loop query ((safeIdx + 1) `mod` m) pl+ KeyTab | not (null matches) -> loop query ((safeIdx + 1) `mod` m) pl+ KeyBackspace | not (null query) -> loop (init query) 0 pl+ KeyChar c -> loop (query ++ [c]) 0 pl+ KeyEscape -> askErase pl >> pure Nothing+ KeyCtrl 'C' -> askErase pl >> pure Nothing+ KeyCtrl 'D' -> askErase pl >> pure Nothing+ _ -> loop query safeIdx pl+ loop "" 0 0++-- | Directory browser. Enter descends into a directory or picks a file; Right+-- descends; Left\/Backspace goes to the parent. Returns the chosen file path.+askFile :: String -> Int -> IO (Maybe String)+askFile start viewHeight = withAskTty (loop start 0 0)+ where+ loop dir idx prevLines = do+ canonical <- canonicalizePath dir+ res <- listEntries canonical+ case res of+ Left err -> askCommit (dimText err) prevLines >> pure Nothing+ Right entries -> do+ let count = length entries+ safeIdx = max 0 (min idx (count - 1))+ target = entries !! safeIdx+ pl <- askRepaint (renderFileFrame canonical entries safeIdx viewHeight) prevLines+ key <- readKey+ case key of+ KeyEnter -> do+ full <- canonicalizePath (canonical ++ "/" ++ feName target)+ if feIsDir target+ then loop full 0 pl+ else askCommit (paintColor ColorCyan full) pl >> pure (Just full)+ KeyRight ->+ if feIsDir target+ then do full <- canonicalizePath (canonical ++ "/" ++ feName target); loop full 0 pl+ else loop canonical safeIdx pl+ KeyUp -> loop canonical ((safeIdx - 1 + count) `mod` count) pl+ KeyDown -> loop canonical ((safeIdx + 1) `mod` count) pl+ KeyTab -> loop canonical ((safeIdx + 1) `mod` count) pl+ KeyLeft -> goParent canonical safeIdx pl+ KeyBackspace -> goParent canonical safeIdx pl+ KeyEscape -> askErase pl >> pure Nothing+ KeyCtrl 'C' -> askErase pl >> pure Nothing+ KeyCtrl 'D' -> askErase pl >> pure Nothing+ _ -> loop canonical safeIdx pl+ goParent canonical safeIdx pl = do+ parent <- canonicalizePath (canonical ++ "/..")+ if parent /= canonical then loop parent 0 pl else loop canonical safeIdx pl++-- | List a directory as sorted 'FileEntry's (dirs first), with @".."@ prepended.+listEntries :: String -> IO (Either String [FileEntry])+listEntries path = do+ exists <- doesPathExist path+ isDir <- doesDirectoryExist path+ if not exists then pure (Left ("not found: " ++ path))+ else if not isDir then pure (Left ("not a directory: " ++ path))+ else do+ names <- listDirectory path `catch` \e -> let _ = (e :: IOException) in pure []+ entries <- forM names $ \nm -> do+ d <- doesDirectoryExist (path ++ "/" ++ nm)+ pure (FileEntry nm d)+ let sorted = sortOn (\e -> (not (feIsDir e), map toLower (feName e))) entries+ pure (Right (FileEntry ".." True : sorted))++-- | Scrollable pager. @viewHeight@ of 0 auto-sizes to the terminal.+-- Arrows\/PgUp\/PgDn\/Home\/End navigate; q or Esc quits.+askPager :: String -> Int -> Bool -> IO ()+askPager content viewHeight lineNumbers = do+ let ls = if null content then [""] else splitOnChar '\n' content+ _ <- withAskTty $ do+ (termH, termW) <- getTerminalSize+ let h = if viewHeight > 0 then viewHeight else max 5 (termH - 3)+ total = length ls+ maxTop = max 0 (total - h)+ loop top prevLines = do+ let safeTop = max 0 (min top maxTop)+ pl <- askRepaint (renderPagerFrame ls safeTop h termW lineNumbers) prevLines+ key <- readKey+ case key of+ KeyChar 'q' -> askErase pl+ KeyEscape -> askErase pl+ KeyCtrl 'C' -> askErase pl+ KeyUp -> loop (safeTop - 1) pl+ KeyDown -> loop (safeTop + 1) pl+ KeyEnter -> loop (safeTop + 1) pl+ KeyPageUp -> loop (safeTop - h) pl+ KeyPageDown -> loop (safeTop + h) pl+ KeyChar ' ' -> loop (safeTop + h) pl+ KeyHome -> loop 0 pl+ KeyEnd -> loop maxTop pl+ _ -> loop safeTop pl+ loop 0 0+ pure ()
README.md view
@@ -1,3 +1,7 @@+<div align="right">+ <sub><em>part of <a href="https://github.com/mattlianje/d4"><img src="https://raw.githubusercontent.com/mattlianje/d4/master/pix/d4.png" width="23"></a> <a href="https://github.com/mattlianje/d4">d4</a></em></sub>+</div>+ <p align="center"> <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/layoutz-hs/pix/layoutz-demo.png" width="750"> </p>@@ -9,20 +13,23 @@ A lightweight, zero-dep lib to build compositional ANSI strings, terminal plots, and interactive Elm-style TUI's in pure Haskell. -Part of [d4](https://github.com/mattlianje/d4) · Also in [Scala](https://github.com/mattlianje/layoutz), [OCaml](https://github.com/mattlianje/layoutz/tree/master/layoutz-ocaml)+Also in [Scala](https://github.com/mattlianje/layoutz), [OCaml](https://github.com/mattlianje/layoutz/tree/master/layoutz-ocaml) ## Features-- Pure Haskell, zero dependencies (use `Layoutz.hs` like a header file)+- Pure Haskell, zero-dependencies (use `Layoutz.hs` like a header file) - Elm-style TUIs - Layout primitives, tables, trees, lists, CJK-aware - Colors, ANSI styles, rich formatting - Terminal charts and plots - Widgets: text input, spinners, progress bars+- Inline raster images via the [kitty graphics protocol](https://sw.kovidgoyal.net/kitty/graphics-protocol/)+- One-shot interactive prompts (`askInput`, `askChoose`, `askFilter`, …)+- Drop-in progress `loader`s for build scripts and batch jobs - Implement `Element` to add your own primitives - Easy porting to MicroHs <p align="center">-<img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/pix/showcase-demo.gif" width="650">+<img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/demos/showcase.gif" width="650"> <br> <sub><a href="examples/ShowcaseApp.hs">ShowcaseApp.hs</a></sub> </p>@@ -44,8 +51,12 @@ - [Border Styles](#border-styles) - [Charts & Plots](#charts--plots) - [Colors & Styles](#colors-ansi-support)-- [Custom Components](#custom-components)+- [Inline Images](#inline-images)+- [Custom Elements](#custom-elements)+- [Collections](#collections) - [Interactive Apps](#interactive-apps)+- [Prompts (Ask)](#prompts-ask)+- [Progress (loader)](#progress-loader) - [Examples](#examples) - [Contributing](#contributing) @@ -63,7 +74,7 @@ ## Quickstart -**(1/2) Static rendering** - Beautiful, compositional strings:+**(1/3) Static rendering**: pretty, composable strings. ```haskell import Layoutz@@ -93,7 +104,7 @@ </p> -**(2/2) Interactive apps** - Build Elm-style TUI's:+**(2/3) Interactive apps** - Build Elm-style TUI's: ```haskell import Layoutz@@ -122,6 +133,31 @@ <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/pix/counter-demo.gif" width="650"> </p> +**(3/3) Prompts (Ask)**++One-shot CLI prompts (inputs, choosers, filters, file pickers, spinners) that collapse to a single line as you answer them.++```haskell+import Layoutz+import Control.Concurrent (threadDelay)++main :: IO ()+main = do+ name <- askInput "Name › " "anonymous" ""+ realm <- askChoose "Choose a realm" ["The Shire", "Rivendell", "Mirkwood"] id+ packs <- askChooseMany "Pack provisions" ["lembas", "pipe-weed", "rope"] 3 id+ member <- askFilter "Search a companion › " ["Bilbo", "Gandalf", "Thorin"] 8 id+ riddle <- askWrite "Pose a riddle" "This thing all things devours…" "" "Ctrl-D to save"+ quest <- askConfirm "Venture on the quest?" True "Yes" "No"+ smaug <- askSpin "Awaking Smaug…" SpinnerDots (threadDelay 1500000 >> pure "ready")+ pure ()+```+<p align="center">+ <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/demos/ask-mini.gif" width="600">+ <br>+ <sub><a href="examples/AskDemo.hs">AskDemo.hs</a></sub>+</p>+ ## Why layoutz? - We have `printf` and [full-blown](https://hackage.haskell.org/package/brick) TUI libraries - but there's a gap in-between - **layoutz** is a tiny, declarative DSL for structured CLI output@@ -145,7 +181,9 @@ layout ["Hello", "World"] -- Instead of layout [text "Hello", text "World"] ``` -**Note:** When passing to functions that take polymorphic `Element a` parameters (like `underline'`, `center'`, `pad`), use `text` explicitly:+> [!NOTE]+> When passing to functions that take polymorphic `Element a` parameters (like `underline'`, `center'`, `pad`), use `text` explicitly:+ ```haskell underline' "=" $ text "Title" -- Correct underline' "=" "Title" -- Ambiguous type error@@ -184,95 +222,163 @@ ## Elements -### Text: `text`-```haskell-text "hello"-"hello" -- with OverloadedStrings-```+### Layout -### Line Break: `br`+#### Stacking & rows ```haskell-layout [text "Line 1", br, text "Line 2"]-```+layout ["First", "Second", "Third"] -- vertical+-- First+-- Second+-- Third -### Layout (vertical): `layout`-```haskell-layout ["First", "Second", "Third"]-```-```-First-Second-Third-```+row ["Left", "Middle", "Right"] -- horizontal+-- Left Middle Right -### Row (horizontal): `row`, `tightRow`-```haskell-row ["Left", "Middle", "Right"]+columns [layout ["A", "B"], layout ["C", "D"]]+-- A C+-- B D+ tightRow [text "A", text "B", text "C"] -- no spacing-```-```-Left Middle Right-ABC+-- ABC ``` -### Horizontal Rule: `hr`, `hr'`, `hr''`+#### Spacing & rules ```haskell-hr -- default ──────────-hr' "~" -- custom char-hr'' "=" 20 -- custom char + width-```+layout [text "Line 1", br, text "Line 2"] -- br is a blank line++hr -- default ──────────...+hr' "~" -- custom char+hr'' "=" 20 -- ====================++vr -- vertical rule, 10 high with │+vr' "║" -- custom char+vr'' "|" 5 -- custom char + height ```-──────────────────────────────────────────────────-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-====================++#### Text transforms+```haskell+center $ text "Auto-centered" -- width taken from siblings+center' 20 $ text "TITLE" -- │ TITLE │+alignLeft 20 "Left" -- │Left │+alignRight 20 "Right" -- │ Right│++justify 30 "Spread this out"+-- │Spread this out│++wrap 20 "Long text here that should wrap"+-- Long text here that+-- should wrap++truncate' 15 (text "Very long text that will be cut off") -- Very long te...+truncate'' 20 "…" (text "Custom ellipsis example text here") -- Custom ellipsis exa…++pad 2 $ text "content" -- 2 cells of padding all around++underline $ text "Title" -- Title+ -- ─────+underline' "=" $ text "Custom" -- Custom+ -- ══════+underlineColored "~" ColorCyan $ text "Fancy"++margin "[error]"+ [ text "Ooops!"+ , row [text "val result: Int = ", underline' "^" (text "getString()")]+ , text "Expected Int, found String"+ ]+-- [error] Ooops!+-- [error] val result: Int = getString()+-- [error] ^^^^^^^^^^^+-- [error] Expected Int, found String ``` -### Vertical Rule: `vr`, `vr'`, `vr''`+### Content++#### Basics ```haskell-vr -- default: 10 high with │-vr' "║" -- custom char-vr'' "|" 5 -- custom char + height+text "hello"+"hello" - with OverloadedStrings++section "Status" [text "All systems operational"]+-- === Status ===+-- All systems operational+section' "-" "Status" [text "ok"] -- custom glyph+section'' "#" "Report" 5 [text "42"] -- custom glyph + width++kv [("Name", "Alice"), ("Age", "30"), ("City", "NYC")]+-- Name: Alice+-- Age: 30+-- City: NYC ``` -### Box: `box`+#### Boxes, cards & banners ```haskell box "Status" [text "All systems go"]+-- ┌──Status──────────┐+-- │ All systems go │+-- └──────────────────┘+ withBorder BorderDouble $ box "Fancy" [text "Double border"]+-- ╔══Fancy═══════════╗+-- ║ Double border ║+-- ╚══════════════════╝+ withBorder BorderRound $ box "Smooth" [text "Rounded corners"]-```-```-┌──Status──────────┐-│ All systems go │-└──────────────────┘-╔══Fancy═══════════╗-║ Double border ║-╚══════════════════╝-╭──Smooth────────────╮-│ Rounded corners │-╰────────────────────╯+-- ╭──Smooth────────────╮+-- │ Rounded corners │+-- ╰────────────────────╯++row [ withColor ColorGreen $ statusCard "CPU" "45%"+ , withColor ColorCyan $ statusCard "MEM" "2.1G"+ ]+-- ┌──────┐ ┌───────┐+-- │ CPU │ │ MEM │+-- │ 45% │ │ 2.1G │+-- └──────┘ └───────┘++banner ["System Dashboard"]+-- ╔══════════════════╗+-- ║ System Dashboard ║+-- ╚══════════════════╝ ``` -Pipe any element through `withBorder`:+Pipe any `HasBorder` element through `withBorder`: ```haskell withBorder BorderRound $ box "Info" ["content"] withBorder BorderDouble $ statusCard "API" "UP" withBorder BorderThick $ table ["Name"] [["Alice"]] ``` -### Status Card: `statusCard`+#### Lists & trees ```haskell-row [ withColor ColorGreen $ statusCard "CPU" "45%"- , withColor ColorCyan $ statusCard "MEM" "2.1G"- ]-```-```-┌──────┐ ┌───────┐-│ CPU │ │ MEM │-│ 45% │ │ 2.1G │-└──────┘ └───────┘+ul ["Backend", ul ["API", ul ["REST", "GraphQL"], "DB"], "Frontend"]+-- • Backend+-- ◦ API+-- ▪ REST+-- ▪ GraphQL+-- ◦ DB+-- • Frontend++ol ["Setup", ol ["Install deps", ol ["npm", "pip"], "Configure"], "Deploy"]+-- 1. Setup+-- a. Install deps+-- i. npm+-- ii. pip+-- b. Configure+-- 2. Deploy++tree "Project"+ [ branch "src" [leaf "main.hs", leaf "test.hs"]+ , branch "docs" [leaf "README.md"]+ ]+-- Project+-- ├── src+-- │ ├── main.hs+-- │ └── test.hs+-- └── docs+-- └── README.md ``` -### Table: `table`+#### Table ```haskell table ["Name", "Age", "City"] [ ["Alice", "30", "New York"]@@ -290,134 +396,73 @@ └─────────┴─────┴──────────┘ ``` -### Key-Value: `kv`-```haskell-kv [("Name", "Alice"), ("Age", "30"), ("City", "NYC")]-```-```-Name: Alice-Age: 30-City: NYC-```--### Section: `section`, `section'`, `section''`-```haskell-section "Status" [text "All systems operational"]-section' "-" "Status" [text "ok"] -- custom glyph-section'' "#" "Report" 5 [text "42"] -- custom glyph + width-```-```-=== Status ===-All systems operational-```--### Unordered List: `ul`-```haskell-ul ["Backend", ul ["API", ul ["REST", "GraphQL"], "DB"], "Frontend"]-```-```-• Backend- ◦ API- ▪ REST- ▪ GraphQL- ◦ DB-• Frontend-```--### Ordered List: `ol`-```haskell-ol ["Setup", ol ["Install deps", ol ["npm", "pip"], "Configure"], "Deploy"]-```-```-1. Setup- a. Install deps- i. npm- ii. pip- b. Configure-2. Deploy-```--### Tree: `tree`, `branch`, `leaf`-```haskell-tree "Project"- [ branch "src" [leaf "main.hs", leaf "test.hs"]- , branch "docs" [leaf "README.md"]- ]-```-```-Project-├── src-│ ├── main.hs-│ └── test.hs-└── docs- └── README.md-```--### Progress Bar: `inlineBar`+#### Progress & spinners ```haskell inlineBar "Download" 0.75-```-```-Download [███████████████─────] 75%-```+-- Download [███████████████─────] 75% -### Chart: `chart`-```haskell chart [("Web", 10), ("Mobile", 20), ("API", 15)]-```-```-Web │████████████████████────────────────────│ 10-Mobile │████████████████████████████████████████│ 20-API │██████████████████████████████──────────│ 15-```+-- Web │████████████████████────────────────────│ 10+-- Mobile │████████████████████████████████████████│ 20+-- API │██████████████████████████████──────────│ 15 -### Spinner: `spinner`-4 built-in styles:-```haskell spinner "Loading" frame SpinnerDots -- ⠋ ⠙ ⠹ ⠸ ⠼ ⠴ ⠦ ⠧ ⠇ ⠏ spinner "Loading" frame SpinnerLine -- | / - \ spinner "Loading" frame SpinnerClock -- 🕐 🕑 🕒 🕓 🕔 🕕 🕖 🕗 🕘 🕙 🕚 🕛 spinner "Loading" frame SpinnerBounce -- ⠁ ⠂ ⠄ ⠂+spinner "Loading" frame SpinnerEarth -- 🌍 🌎 🌏+spinner "Loading" frame SpinnerMoon -- 🌑 🌒 🌓 🌔 🌕 🌖 🌗 🌘+spinner "Loading" frame SpinnerGrow -- ▏ ▎ ▍ ▌ ▋ ▊ ▉ █ ▉ ▊ ▋ ▌ ▍ ▎+spinner "Loading" frame SpinnerArrow -- ← ↖ ↑ ↗ → ↘ ↓ ↙ ``` -### Alignment: `center`, `alignLeft`, `alignRight`, `justify`, `wrap`-```haskell-center $ text "Auto-centered" -- width from siblings-center' 30 $ text "Fixed width"-alignLeft 30 "Left"-alignRight 30 "Right"-justify 30 "Spaces are distributed evenly"-wrap 20 "Long text wrapped at word boundaries"-```+#### Inline Images -### Underline: `underline`, `underline'`, `underlineColored`+Inline raster images via the [kitty graphics protocol](https://sw.kovidgoyal.net/kitty/graphics-protocol/).+A `KittyImage` measures exactly `cols`×`rows` cells, so it composes with every other+element: drop it into boxes, rows, tables, `center`, etc.+ ```haskell-underline $ text "Title"-underline' "=" $ text "Double"-underlineColored "~" ColorCyan $ text "Fancy"-```-```-Title-─────+img <- kittyImageFile "pix/sakuraba.png" 35 14 -- PNG sized to 35×14 cells -Double-======+putStrLn $ render $ row+ [ withBorder BorderRound $ box "the gracie hunter" [img]+ , box "stats" [kv [("flying", "yes"), ("opponent", "grounded"), ("rules", "PRIDE")]]+ ] ```+<p align="center">+ <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/layoutz-hs/pix/haskell-kitty-1.png" width="600">+</p> -### Margin: `margin`+Build straight from bytes or raw pixels:+ ```haskell-margin "[error]" [text "Oops", text "fix it"]-```-```-[error] Oops-[error] fix it+kittyImage bytes 35 14 -- PNG bytes -> cols rows+kittyRGB pixels w h 18 9 -- raw RGB pxW pxH -> cols rows+kittyRGBA pixels w h 18 9 -- raw RGBA pxW pxH -> cols rows ``` -### Padding: `pad` ```haskell-pad 2 $ text "Padded content"+let (w, h) = (96, 96)+ pixels = [ channel i | i <- [0 .. w * h * 4 - 1] ]+ channel i =+ let p = i `div` 4; x = p `mod` w; y = p `div` w+ in fromIntegral $ case i `mod` 4 of+ 0 -> x * 255 `div` w+ 1 -> y * 255 `div` h+ 2 -> 255 - (x * 255 `div` w)+ _ -> 255++putStrLn $ render $ box "gradient" [kittyRGBA pixels w h 18 9] ```+<p align="center">+ <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/layoutz-hs/pix/haskell-kitty-2.png" width="600">+</p> +Needs a kitty-graphics-capable terminal (kitty, WezTerm, Ghostty). Inside a+`LayoutzApp`, each distinct image is transmitted once and re-placed cheaply on+every frame.+ ## Charts & Plots See also [Granite](https://github.com/mchav/granite) for terminal plots in Haskell.@@ -539,7 +584,7 @@ ColorMagenta ColorCyan ColorWhite-ColorBrightBlack -- Bright 8+ColorBrightBlack -- Bright 8 ColorBrightRed ColorBrightGreen ColorBrightYellow@@ -547,14 +592,14 @@ ColorBrightMagenta ColorBrightCyan ColorBrightWhite-ColorFull 196 -- 256-color palette (0-255)-ColorTrue 255 128 0 -- 24-bit RGB-ColorDefault -- Conditional no-op+ColorFull 196 -- 256-color palette (0-255)+ColorTrue 255 128 0 -- 24-bit RGB+ColorDefault -- Conditional no-op ``` ### Color Gradients -Create beautiful gradients with extended colors:+Create gradients with extended colors: ```haskell let palette = tightRow $ map (\i -> withColor (ColorFull i) $ text "█") [16, 19..205]@@ -624,7 +669,7 @@ withColor ColorBrightYellow $ withStyle (StyleBold <> StyleItalic) $ text "The quick brown fox..." ``` -## Custom Components+## Custom Elements Create your own components by implementing the `Element` typeclass @@ -662,6 +707,38 @@ └────────────┘ ``` +## Collections+```haskell+import Data.List (groupBy, sortOn)+import Data.Function (on)++data User = User { userName :: String, userRole :: String }++users :: [User]+users =+ [ User "Alice" "Admin"+ , User "Bob" "User"+ , User "Tom" "User"+ ]++putStrLn $ render $ section "Users by Role"+ [ layout+ [ box (userRole (head grp)) [ul [text (userName u) | u <- grp]]+ | grp <- groupBy ((==) `on` userRole) (sortOn userRole users)+ ]+ ]+```+```+=== Users by Role ===+┌──Admin──┐+│ • Alice │+└─────────┘+┌──User──┐+│ • Bob │+│ • Tom │+└────────┘+```+ ## REPL Drop into GHCi to experiment:@@ -687,7 +764,7 @@ ## Interactive Apps `LayoutzApp` uses the [Elm Architecture](https://guide.elm-lang.org/architecture/) where your-view is simply a `layoutz` `Element`.+view is a `layoutz` `Element`. ```haskell data LayoutzApp state msg = LayoutzApp@@ -719,9 +796,9 @@ ### Subscriptions ```haskell-subKeyPress (\key -> ...) -- Keyboard input-subEveryMs 100 msg -- Periodic ticks (interval in ms)-subBatch [sub1, sub2, ...] -- Combine subscriptions+subKeyPress (\key -> ...) -- Keyboard input+subEveryMs 100 msg -- Periodic ticks (interval in ms)+subBatch [sub1, sub2, ...] -- Combine subscriptions ``` ### Commands@@ -766,41 +843,242 @@ ```haskell -- Printable-KeyChar Char -- 'a', '1', ' '+KeyChar Char -- 'a', '1', ' ' -- Editing-KeyEnter -- Enter/Return-KeyBackspace -- Backspace-KeyTab -- Tab-KeyEscape -- Escape-KeyDelete -- Delete+KeyEnter+KeyBackspace+KeyTab+KeyEscape+KeyDelete -- Navigation-KeyUp -- Arrow up-KeyDown -- Arrow down-KeyLeft -- Arrow left-KeyRight -- Arrow right+KeyUp+KeyDown+KeyLeft+KeyRight+KeyPageUp+KeyPageDown+KeyHome+KeyEnd -- Modifiers-KeyCtrl Char -- Ctrl+'C', Ctrl+'Q', etc.-KeySpecial String -- Other unrecognized sequences+KeyCtrl Char -- Ctrl+'C', Ctrl+'Q', etc.+KeySpecial String -- Other unrecognized sequences ``` +## Prompts (Ask)++You often just want a one-shot CLI prompt (a spinner, a filter, a file picker)+without dropping into "Elm-territory" and thinking about a whole flipbook each time.++**layoutz** offers one-shot interactive actions with the `ask*` family. Each takes+over the tty briefly, returns a value, and leaves a single committed line behind.+`Nothing` means the user cancelled (Esc / Ctrl-C / Ctrl-D).++```haskell+import Layoutz+import Control.Concurrent (threadDelay)++main :: IO ()+main = do+ name <- askInput "Name › " "anonymous" ""+ ok <- askConfirm "Venture on the quest?" True "Yes" "No"+ realm <- askChoose "Choose a realm" ["The Shire", "Rivendell", "Mirkwood", "Lake-town", "Erebor"] id+ packs <- askChooseMany "Pack provisions" ["lembas", "pipe-weed", "waybread", "miruvor", "rope"] 3 id+ riddle <- askWrite "Pose a multi-line riddle" "This thing all things devours…" "" "Ctrl-D to save"+ member <- askFilter "Search > " ["Bilbo", "Balin", "Dwalin", "Thorin", "Gandalf"] 8 id+ path <- askFile "." 12+ askPager longString 0 True+ answer <- askSpin "Awaking Smaug…" SpinnerDots (do threadDelay 1500000; pure (42 :: Int))+ pure ()+```++<p align="center">+ <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/demos/ask-mini.gif" width="650">+</p>++Each `ask*` returns in `IO`... and a `Maybe` if the user can cancel midway:++```haskell+askInput prompt placeholder initial -- IO (Maybe String)+askConfirm question default yes no -- IO Bool+askChoose prompt items render -- IO (Maybe a)+askChooseMany prompt items limit render -- IO (Maybe [a])+askWrite prompt placeholder initial hint -- IO (Maybe String)+askFilter prompt items height render -- IO (Maybe a)+askFile start height -- IO (Maybe String)+askPager content height lineNumbers -- IO ()+askSpin label style task -- IO a+```++## Progress (loader)++Wrap any list with `loader` to get a live progress bar while you process it: map+an `IO` action over each item. Unbounded work gets `loaderStream`, a spinner+with a running count.++```haskell+_ <- loader "Resizing" imageFiles resize+_ <- loader "Inserting" rows insertRow+_ <- loaderStream "Tailing" logLines indexLine+```++Pick a `LoaderStyle` with `loaderStyled` / `loaderStreamStyled`+```+styleBlocks -- (default)+styleBar+styleAscii+styleDots+styleLine+stylePipes+LoaderStyle { .. } -- (custom)+```++```haskell+_ <- loaderStyled styleAscii "Reindexing" docIds reindex+_ <- loaderStyled stylePipes "Crawling" urls fetch+```++Every built-in style, then an unbounded stream:++```haskell+import Layoutz+import Control.Concurrent (threadDelay)++main :: IO ()+main = do+ _ <- loaderStyled styleBlocks "Blocks " [1..60] (const (threadDelay 16000))+ _ <- loaderStyled styleDots "Dots " [1..60] (const (threadDelay 16000))+ _ <- loaderStyled styleLine "Line " [1..60] (const (threadDelay 16000))+ _ <- loaderStyled stylePipes "Pipes " [1..60] (const (threadDelay 16000))+ _ <- loaderStyled styleBar "Bar " [1..60] (const (threadDelay 16000))+ _ <- loaderStyled styleAscii "Ascii " [1..60] (const (threadDelay 16000))+ _ <- loaderStream "Streaming" [1..90] (const (threadDelay 45000))+ pure ()+```++<p align="center">+ <img src="https://raw.githubusercontent.com/mattlianje/layoutz/refs/heads/master/demos/loader.gif" width="600">+</p>+ ## Examples-- [ShowcaseApp.hs](examples/ShowcaseApp.hs) - Tours every layoutz element and visualization across 7 scenes-- [SimpleGame.hs](SimpleGame.hs) - Grid game where you collect gems and dodge enemies with WASD-- [InlineBar.hs](examples/InlineBar.hs) - Renders a gradient progress bar in-place-- [InlineLoadingDemo.hs](examples/InlineLoadingDemo.hs) - Chained inline progress bars in a simulated build script +Small, copy-pasteable snippets for everyday CLI chores.++<details>+<summary>Print a deploy / status summary (<code>section</code> + <code>statusCard</code> + <code>kv</code>)</summary>++```haskell+import Layoutz++main :: IO ()+main = putStrLn $ render $ section "Deploy"+ [ row+ [ withColor ColorGreen $ statusCard "build" "OK"+ , withColor ColorGreen $ statusCard "tests" "142 ✓"+ , withColor ColorYellow $ statusCard "deploy" "staging"+ ]+ , kv [("commit", "a1b2c3d"), ("branch", "master"), ("by", "matt")]+ ]+```+</details>++<details>+<summary>Compiler-style error message (<code>margin</code> + <code>underline'</code>)</summary>++```haskell+import Layoutz++main :: IO ()+main = putStrLn $ render $ margin "error:"+ [ text "type mismatch"+ , row [text "let x: Int = ", underline' "^" (text "getString()")]+ , text " expected Int, found String"+ ]+-- error: type mismatch+-- error: let x: Int = getString()+-- ^^^^^^^^^^^^+-- error: expected Int, found String+```+</details>++<details>+<summary>Render a table straight from records (<code>table</code>)</summary>++```haskell+import Layoutz++data Svc = Svc { svcName :: String, svcStatus :: String, svcCpu :: String }++svcs :: [Svc]+svcs =+ [ Svc "api" "up" "23%"+ , Svc "db" "up" "61%"+ , Svc "cache" "down" "0%"+ ]++main :: IO ()+main = putStrLn $ render $ table ["Service", "Status", "CPU"]+ [ [text (svcName s), text (svcStatus s), text (svcCpu s)] | s <- svcs ]+```+</details>++<details>+<summary>Progress bar over a batch of work (<code>loader</code>)</summary>++```haskell+import Layoutz+import Control.Concurrent (threadDelay)++main :: IO ()+main = do+ let files = ["a.png", "b.png", "c.png"]+ _ <- loader "Resizing" files $ \f -> threadDelay 200000 -- your IO per item+ putStrLn "done"+```+</details>++<details>+<summary>Gate a destructive action behind a confirm (<code>askConfirm</code>)</summary>++```haskell+import Layoutz++main :: IO ()+main = do+ ok <- askConfirm "Drop production table?" False "Yes" "No"+ if ok then putStrLn "dropping…" else putStrLn "cancelled"+```+</details>++<details>+<summary>Wrap a slow query in a spinner (<code>askSpin</code>)</summary>++```haskell+import Layoutz+import Control.Concurrent (threadDelay)++main :: IO ()+main = do+ rows <- askSpin "Querying…" SpinnerDots runQuery+ putStrLn $ render $ section "Result" [text $ show rows <> " rows"]+ where+ runQuery = do+ threadDelay 1500000 -- stand-in for your slow IO+ pure (1234 :: Int)+```+</details>+ ## Contributing You need [GHC](https://www.haskell.org/ghcup/) (8.10+) and [Cabal](https://www.haskell.org/cabal/). ```bash-make build # build library-make test # run tests-make repl # GHCi with layoutz loaded-make clean # clean build artifacts+make build # build library+make test # run tests+make repl # GHCi with layoutz loaded+make clean # clean build artifacts ``` Fork, make your change, `make test`, open a PR. Keep it zero-dep.
+ examples/AskDemo.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Ask demo - a tour of the one-shot @ask*@ prompts. Each takes over the tty+briefly, returns a value, and leaves a single committed line behind.++Run with: cabal run ask-demo+-}++module Main where++import Layoutz+import Control.Concurrent (threadDelay)+import Control.Monad (void)+import Text.Printf (printf)++companions :: [String]+companions =+ [ "Bilbo", "Balin", "Dwalin", "Thorin"+ , "Gandalf", "Kili", "Fili", "Bombur"+ , "Bofur", "Gloin", "Oin", "Dori"+ ]++realms :: [String]+realms = ["The Shire", "Rivendell", "Mirkwood", "Lake-town", "Erebor"]++gap :: IO ()+gap = putStrLn ""++main :: IO ()+main = do+ putStr "\ESC[2J\ESC[H"++ _ <- askInput "Name › " "anonymous" ""+ gap+ _ <- askChoose "Choose a realm" realms id+ gap+ _ <- askChooseMany "Pack provisions (up to 3)"+ ["lembas", "pipe-weed", "waybread", "miruvor", "rope", "athelas"] 3 id+ gap+ _ <- askFilter "Search a companion › " companions 8 id+ gap+ _ <- askWrite "Pose a riddle" "This thing all things devours…" "" "Ctrl-D to save"+ gap+ _ <- askFile "." 12+ gap+ _ <- askConfirm "Venture on the quest?" True "Yes" "No"+ gap+ askPager roster 8 True+ gap+ void $ askSpin "Awaking Smaug…" SpinnerDots (threadDelay 1500000 >> pure ("ready" :: String))+ where+ roster = unlines+ [ printf "%2d. %-12s %s"+ (i + 1) (companions !! (i `mod` length companions))+ (realms !! (i `mod` length realms))+ | i <- [0 .. 39 :: Int] ]
+ examples/RayMarcher.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Main where++import Layoutz+import Data.List (intercalate)+import Text.Printf (printf)++-- | 3D vector+data V3 = V3 !Double !Double !Double++vzero, vup :: V3+vzero = V3 0 0 0+vup = V3 0 1 0++vadd, vsub, vcross :: V3 -> V3 -> V3+vadd (V3 ax ay az) (V3 bx by bz) = V3 (ax + bx) (ay + by) (az + bz)+vsub (V3 ax ay az) (V3 bx by bz) = V3 (ax - bx) (ay - by) (az - bz)+vcross (V3 ax ay az) (V3 bx by bz) =+ V3 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx)++vscale :: V3 -> Double -> V3+vscale (V3 x y z) s = V3 (x * s) (y * s) (z * s)++vdot :: V3 -> V3 -> Double+vdot (V3 ax ay az) (V3 bx by bz) = ax * bx + ay * by + az * bz++vlen :: V3 -> Double+vlen v = sqrt (vdot v v)++vneg :: V3 -> V3+vneg (V3 x y z) = V3 (-x) (-y) (-z)++vnorm :: V3 -> V3+vnorm v =+ let l = vlen v+ in if l < 1e-10 then vzero else vscale v (1.0 / l)++-- | One screen cell with character + 24-bit color+data Pixel = Pixel !Char !Int !Int !Int++-- | Render a list of pixels into a single ANSI string of width @w@+renderFrameBuffer :: [Pixel] -> Int -> String+renderFrameBuffer pixels w = intercalate "\n" (rowsOf pixels)+ where+ rowsOf [] = []+ rowsOf ps =+ let (rowPixels, rest) = splitAt w ps+ in renderRow rowPixels : rowsOf rest+ renderRow ps = concatMap pixelToAnsi ps ++ "\ESC[0m"+ pixelToAnsi (Pixel ch r g b) =+ "\ESC[38;2;" ++ show r ++ ";" ++ show g ++ ";" ++ show b ++ "m" ++ [ch]++data RayState = RayState+ { rsTheta :: !Double+ , rsPhi :: !Double+ , rsDist :: !Double+ , rsMorph :: !Double+ , rsMorphTarget :: !Double+ , rsAutoRotate :: !Bool+ , rsTick :: !Int+ }++initialState :: RayState+initialState = RayState+ { rsTheta = 0.0+ , rsPhi = 0.35+ , rsDist = 3.8+ , rsMorph = 0.0+ , rsMorphTarget = 0.0+ , rsAutoRotate = True+ , rsTick = 0+ }++data RayMsg+ = RTick+ | RotL | RotR | RotU | RotD+ | ZoomIn | ZoomOut+ | ToggleAuto+ | NextShape+ deriving (Show, Eq)++-- Render config+fbW, fbH :: Int+fbW = 60+fbH = 28++maxSteps :: Int+maxSteps = 50++maxDist, eps, morphSpeed :: Double+maxDist = 20.0+eps = 0.005+morphSpeed = 0.06++ramp :: String+ramp = " .'`^\",:;Il!i><~+_-?][}{1)(|/tfjrxnuvczXYUJCLQ0OZmwqpdbkhao*#MW&8%B@$"++shapeNames :: [String]+shapeNames = ["sphere", "torus", "cube"]++clampD :: Double -> Double -> Double -> Double+clampD lo hi x = max lo (min hi x)++mixD :: Double -> Double -> Double -> Double+mixD a b t = a * (1.0 - t) + b * t++smoothstep :: Double -> Double -> Double -> Double+smoothstep lo hi x =+ let t = clampD 0.0 1.0 ((x - lo) / (hi - lo))+ in t * t * (3.0 - 2.0 * t)++-- Signed-distance functions+sdSphere :: V3 -> Double -> Double+sdSphere p r = vlen p - r++sdTorus :: V3 -> Double -> Double -> Double+sdTorus (V3 x y z) bigR r =+ let qx = sqrt (x * x + z * z) - bigR+ in sqrt (qx * qx + y * y) - r++sdRoundBox :: V3 -> V3 -> Double -> Double+sdRoundBox (V3 px py pz) (V3 bx by bz) r =+ let qx = abs px - bx+ qy = abs py - by+ qz = abs pz - bz+ outer = vlen (V3 (max qx 0) (max qy 0) (max qz 0))+ inner = min (max qx (max qy qz)) 0.0+ in outer + inner - r++scene :: V3 -> Double -> Double+scene p morph =+ let t = let m = morph - fromIntegral (3 * floor (morph / 3.0) :: Int)+ in if m < 0 then m + 3 else m+ sph = sdSphere p 1.05+ tor = sdTorus p 0.9 0.38+ cub = sdRoundBox p (V3 0.72 0.72 0.72) 0.12+ in if t < 1.0 then mixD sph tor (smoothstep 0 1 t)+ else if t < 2.0 then mixD tor cub (smoothstep 0 1 (t - 1))+ else mixD cub sph (smoothstep 0 1 (t - 2))++calcNormal :: V3 -> Double -> V3+calcNormal (V3 x y z) morph =+ let e = 0.001+ in vnorm $ V3+ (scene (V3 (x + e) y z) morph - scene (V3 (x - e) y z) morph)+ (scene (V3 x (y + e) z) morph - scene (V3 x (y - e) z) morph)+ (scene (V3 x y (z + e)) morph - scene (V3 x y (z - e)) morph)++march :: V3 -> V3 -> Double -> Double+march ro rd morph = go 0.0 0+ where+ go !t !i+ | i >= maxSteps || t >= maxDist = -1.0+ | otherwise =+ let d = scene (vadd ro (vscale rd t)) morph+ in if d < eps then t else go (t + d) (i + 1)++lightDir :: V3+lightDir = vnorm (V3 0.8 1.0 (-0.6))++bgPixel :: V3 -> Pixel+bgPixel (V3 _ y _) =+ let vy = y * 0.5 + 0.5+ bg = max 4 (floor (18.0 - (1.0 - vy) * 8.0) :: Int)+ in Pixel ' ' bg bg (bg + 6)++shade :: V3 -> V3 -> Double -> Pixel+shade ro rd morph =+ let t = march ro rd morph+ in if t < 0+ then bgPixel rd+ else+ let hit = vadd ro (vscale rd t)+ n = calcNormal hit morph+ diff = max (vdot n lightDir) 0.0+ refl = vsub (vscale n (2.0 * vdot n lightDir)) lightDir+ spec = (max (vdot refl (vneg rd)) 0.0) ** 32.0 * 0.6+ ao = 1.0 - clampD 0.0 0.4 (scene (vadd hit (vscale n 0.1)) morph * 5.0)+ lum = clampD 0.0 1.0 ((0.08 + diff * 0.85 + spec) * ao)+ rampLen = length ramp+ idx = floor (clampD 0 (fromIntegral rampLen - 1) (lum * fromIntegral (rampLen - 1))) :: Int+ ch = ramp !! idx+ V3 nx ny nz = n+ nx' = nx * 0.5 + 0.5+ ny' = ny * 0.5 + 0.5+ nz' = nz * 0.5 + 0.5+ rC = floor (clampD 0 255 ((nx' * 0.55 + lum * 0.45) * 235 + 20)) :: Int+ gC = floor (clampD 0 255 ((ny' * 0.45 + lum * 0.55) * 215 + 15)) :: Int+ bC = floor (clampD 0 255 ((nz' * 0.50 + lum * 0.50 + 0.05) * 200 + 30)) :: Int+ in Pixel ch rC gC bC++renderFrame :: RayState -> L+renderFrame s =+ let theta = rsTheta s+ phi = rsPhi s+ dist = rsDist s+ morph = rsMorph s+ ro = V3 (dist * sin theta * cos phi)+ (dist * sin phi)+ (dist * cos theta * cos phi)+ fwd = vnorm (vneg ro)+ right = vnorm (vcross fwd vup)+ up = vcross right fwd+ aspect = fromIntegral fbW / fromIntegral fbH * 0.48+ pixels = [ shade ro rd morph+ | py <- [0 .. fbH - 1]+ , let v = 0.5 - fromIntegral py / fromIntegral fbH+ , px <- [0 .. fbW - 1]+ , let u = (fromIntegral px / fromIntegral fbW - 0.5) * aspect+ , let rd = vnorm (vadd (vadd fwd (vscale right u)) (vscale up v))+ ]+ in text (renderFrameBuffer pixels fbW)++-- | Update state in response to a message+updateRay :: RayMsg -> RayState -> RayState+updateRay msg s = case msg of+ RTick ->+ let newTheta = if rsAutoRotate s then rsTheta s + 0.035 else rsTheta s+ diff = rsMorphTarget s - rsMorph s+ newMorph = if abs diff < 0.01+ then rsMorphTarget s+ else rsMorph s + diff * morphSpeed+ in s { rsTheta = newTheta, rsMorph = newMorph, rsTick = rsTick s + 1 }+ RotL -> s { rsTheta = rsTheta s - 0.15, rsAutoRotate = False }+ RotR -> s { rsTheta = rsTheta s + 0.15, rsAutoRotate = False }+ RotU -> s { rsPhi = min (rsPhi s + 0.1) 1.3 }+ RotD -> s { rsPhi = max (rsPhi s - 0.1) (-1.3) }+ ZoomIn -> s { rsDist = max (rsDist s - 0.25) 2.0 }+ ZoomOut -> s { rsDist = min (rsDist s + 0.25) 8.0 }+ ToggleAuto -> s { rsAutoRotate = not (rsAutoRotate s) }+ NextShape ->+ let next = (round (rsMorphTarget s) + 1) `mod` 3 :: Int+ in s { rsMorphTarget = fromIntegral next }++-- | Build the visible UI for one frame+viewRay :: RayState -> L+viewRay s =+ let fb = renderFrame s+ targetIdx = (round (rsMorphTarget s) `mod` 3 + 3) `mod` 3+ settled = abs (rsMorph s - rsMorphTarget s) < 0.02+ shapeName =+ if settled+ then shapeNames !! targetIdx+ else+ let fromIdx = (round (rsMorph s) `mod` 3 + 3) `mod` 3+ in (shapeNames !! fromIdx) ++ " -> " ++ (shapeNames !! targetIdx)++ sparkData =+ [ 8.0 + 4.0 * sin (fromIntegral (rsTick s + i) * 0.4)+ | i <- [0 .. 29 :: Int]+ ]++ twoPi = 2 * pi :: Double++ cameraStats = withColor ColorBrightBlue $ kv+ [ ("th", printf "%.2f" (rsTheta s - twoPi * fromIntegral (floor (rsTheta s / twoPi) :: Int)))+ , ("ph", printf "%.2f" (rsPhi s))+ , ("zoom", printf "%.1f" (rsDist s))+ ]++ rotateLine = tightRow+ [ withColor ColorBrightBlack (text "rotate: ")+ , if rsAutoRotate s+ then withStyle StyleBold (withColor ColorBrightGreen (text "auto"))+ else withColor ColorBrightYellow (text "manual")+ ]++ controls = withStyle StyleDim $ layout+ [ withColor ColorBrightYellow (text "<-^v> orbit")+ , withColor ColorBrightYellow (text "+/- zoom")+ , withColor ColorBrightYellow (text "m shape")+ , withColor ColorBrightYellow (text "a auto")+ ]++ camera = layout+ [ cameraStats+ , br+ , rotateLine+ , br+ , withColor ColorBrightYellow (text "~12 fps")+ , withColor ColorBrightCyan (plotSparkline sparkData)+ , br+ , withColor ColorBrightMagenta (kv [("shape", shapeName)])+ , br+ , withColor ColorBrightCyan (spinner "render" (rsTick s `div` 2) SpinnerDots)+ , withColor ColorBrightGreen (spinner "scene" (rsTick s `div` 3) SpinnerClock)+ , withColor ColorBrightYellow(spinner "light" (rsTick s `div` 2) SpinnerBounce)+ , br+ , controls+ ]++ cameraBox = withColor ColorBrightMagenta $ setBorder BorderRound $ box "Camera" [camera]++ title = withStyle StyleBold (withColor ColorBrightCyan (text "Ray Marcher"))+ in row [layout [title, fb], cameraBox]++rayMarcher :: LayoutzApp RayState RayMsg+rayMarcher = LayoutzApp+ { appInit = (initialState, CmdNone)+ , appUpdate = \msg state -> (updateRay msg state, CmdNone)+ , appSubscriptions = \_ -> subBatch+ [ subEveryMs 80 RTick+ , subKeyPress $ \case+ KeyLeft -> Just RotL+ KeyRight -> Just RotR+ KeyUp -> Just RotU+ KeyDown -> Just RotD+ KeyChar '+' -> Just ZoomIn+ KeyChar '=' -> Just ZoomIn+ KeyChar '-' -> Just ZoomOut+ KeyChar 'a' -> Just ToggleAuto+ KeyChar 'A' -> Just ToggleAuto+ KeyChar 'm' -> Just NextShape+ KeyChar 'M' -> Just NextShape+ _ -> Nothing+ ]+ , appView = viewRay+ }++main :: IO ()+main = runApp rayMarcher
examples/ShowcaseApp.hs view
@@ -4,8 +4,8 @@ Showcase demo – tours every layoutz element and visualization. Controls:-- ←/→ switch scenes (1–7)-- 1–7 jump to scene+- ←/→ switch scenes (1–8)+- 1–8 jump to scene - ESC quit Scene-specific keys are shown in the footer.@@ -17,7 +17,7 @@ import Text.Printf (printf) import Data.Char (isAlphaNum) --- State -----------------------------------------------------------------------+-- State data ShowcaseState = ShowcaseState { scene :: Int@@ -36,6 +36,11 @@ , ballVy :: Double , gravity :: Int , ballTrail :: [Double]+ , rayTheta :: Double+ , rayPhi :: Double+ , rayDist :: Double+ , rayMorph :: Double+ , rayMorphTarget:: Double } initialState :: ShowcaseState@@ -45,24 +50,27 @@ , lineOffset = 0, tableRow = 0, tableSelected = [] , barMode = 0, ballY = 10.0, ballVy = 0.0, gravity = 5 , ballTrail = replicate 80 10.0+ , rayTheta = 0.6, rayPhi = 0.35, rayDist = 3.8+ , rayMorph = 0.0, rayMorphTarget = 0.0 } --- Messages --------------------------------------------------------------------+-- Messages data Msg = NextScene | PrevScene | GoScene Int | Tick | TypeChar Char | Backspace | SubmitItem | ToggleSelect | CursorUp | CursorDown | AdjustUp | AdjustDown | ToggleBarMode | KickBall+ | RayRotL | RayRotR | RayRotU | RayRotD | RayNextShape --- Constants -------------------------------------------------------------------+-- Constants totalScenes :: Int-totalScenes = 7+totalScenes = 8 sceneNames :: [String] sceneNames =- [ "Physics Game", "Text Input & Lists", "Borders & Styles"+ [ "Ray Marcher", "Physics Game", "Text Input & Lists", "Borders & Styles" , "Tables", "Charts & Plots", "Bar Charts & Sparklines" , "Selections & Heatmap" ] @@ -84,7 +92,7 @@ toggleIn :: Int -> [Int] -> [Int] toggleIn x xs = if x `elem` xs then filter (/= x) xs else x : xs --- Update ----------------------------------------------------------------------+-- Update update :: Msg -> ShowcaseState -> (ShowcaseState, Cmd Msg) update msg s = case msg of@@ -107,7 +115,12 @@ rawY = ballY s1 + newVy * 0.3 (ny, vy) = bounce rawY newVy trail = drop (max 0 (length (ballTrail s1) - 79)) (ballTrail s1) ++ [ny]- in (s1 { tick = tick s1 + 1, ballY = ny, ballVy = vy, ballTrail = trail }, CmdNone)+ -- Ray marcher shape morph easing+ mDiff = rayMorphTarget s1 - rayMorph s1+ newMorph = if abs mDiff < 0.01 then rayMorphTarget s1+ else rayMorph s1 + mDiff * 0.06+ in (s1 { tick = tick s1 + 1, ballY = ny, ballVy = vy, ballTrail = trail+ , rayMorph = newMorph }, CmdNone) TypeChar c | not (addingItem s) -> (s { textValue = textValue s ++ [c] }, CmdNone) TypeChar _ -> (s, CmdNone)@@ -121,32 +134,42 @@ SubmitItem -> (s, CmdNone) ToggleSelect- | scene s == 3 -> (s { tableSelected = toggleIn (tableRow s) (tableSelected s) }, CmdNone)- | scene s == 6 -> (s { selected = toggleIn (cursor s) (selected s) }, CmdNone)+ | scene s == 4 -> (s { tableSelected = toggleIn (tableRow s) (tableSelected s) }, CmdNone)+ | scene s == 7 -> (s { selected = toggleIn (cursor s) (selected s) }, CmdNone) | otherwise -> (s, CmdNone) CursorUp- | scene s == 3 -> (s { tableRow = (tableRow s - 1 + length services) `mod` length services }, CmdNone)- | scene s == 6 -> (s { cursor = (cursor s - 1 + 7) `mod` 7 }, CmdNone)+ | scene s == 4 -> (s { tableRow = (tableRow s - 1 + length services) `mod` length services }, CmdNone)+ | scene s == 7 -> (s { cursor = (cursor s - 1 + 7) `mod` 7 }, CmdNone) | otherwise -> (s, CmdNone) CursorDown- | scene s == 3 -> (s { tableRow = (tableRow s + 1) `mod` length services }, CmdNone)- | scene s == 6 -> (s { cursor = (cursor s + 1) `mod` 7 }, CmdNone)+ | scene s == 4 -> (s { tableRow = (tableRow s + 1) `mod` length services }, CmdNone)+ | scene s == 7 -> (s { cursor = (cursor s + 1) `mod` 7 }, CmdNone) | otherwise -> (s, CmdNone) AdjustUp- | scene s == 0 -> (s { gravity = min (gravity s + 1) 15 }, CmdNone)+ | scene s == 1 -> (s { gravity = min (gravity s + 1) 15 }, CmdNone)+ | scene s == 0 -> (s { rayDist = max (rayDist s - 0.25) 2.0 }, CmdNone) | otherwise -> (s { lineOffset = min (lineOffset s + 1) 10 }, CmdNone) AdjustDown- | scene s == 0 -> (s { gravity = max (gravity s - 1) 1 }, CmdNone)+ | scene s == 1 -> (s { gravity = max (gravity s - 1) 1 }, CmdNone)+ | scene s == 0 -> (s { rayDist = min (rayDist s + 0.25) 8.0 }, CmdNone) | otherwise -> (s { lineOffset = max (lineOffset s - 1) (-10) }, CmdNone) ToggleBarMode -> (s { barMode = (barMode s + 1) `mod` 2 }, CmdNone) KickBall -> (s { ballVy = 5.0 }, CmdNone) + RayRotL -> (s { rayTheta = rayTheta s - 0.15 }, CmdNone)+ RayRotR -> (s { rayTheta = rayTheta s + 0.15 }, CmdNone)+ RayRotU -> (s { rayPhi = min (rayPhi s + 0.1) 1.3 }, CmdNone)+ RayRotD -> (s { rayPhi = max (rayPhi s - 0.1) (-1.3) }, CmdNone)+ RayNextShape ->+ let next = (round (rayMorphTarget s) + 1) `mod` 2 :: Int+ in (s { rayMorphTarget = fromIntegral next }, CmdNone)+ bounce :: Double -> Double -> (Double, Double) bounce y vy | y <= 0 = (0, abs vy * 0.82)@@ -162,17 +185,22 @@ , subKeyPress $ \key -> case key of KeyRight -> Just NextScene KeyLeft -> Just PrevScene+ KeyChar 'a' | scene s == 0 -> Just RayRotL+ KeyChar 'd' | scene s == 0 -> Just RayRotR+ KeyChar 'w' | scene s == 0 -> Just RayRotU+ KeyChar 's' | scene s == 0 -> Just RayRotD KeyChar '+' -> Just AdjustUp KeyChar '-' -> Just AdjustDown- KeyChar ' ' | scene s == 0 -> Just KickBall- KeyChar ' ' | scene s == 3 || scene s == 6 -> Just ToggleSelect- KeyTab | scene s == 5 -> Just ToggleBarMode- KeyEnter | scene s == 1 -> Just SubmitItem+ KeyChar ' ' | scene s == 0 -> Just RayNextShape+ KeyChar ' ' | scene s == 1 -> Just KickBall+ KeyChar ' ' | scene s == 4 || scene s == 7 -> Just ToggleSelect+ KeyTab | scene s == 6 -> Just ToggleBarMode+ KeyEnter | scene s == 2 -> Just SubmitItem KeyUp -> Just CursorUp KeyDown -> Just CursorDown KeyBackspace -> Just Backspace- KeyChar c | scene s == 1 && (isAlphaNum c || c == ' ') -> Just (TypeChar c)- KeyChar c | c >= '1' && c <= '7' -> Just (GoScene (fromEnum c - fromEnum '1'))+ KeyChar c | scene s == 2 && (isAlphaNum c || c == ' ') -> Just (TypeChar c)+ KeyChar c | c >= '1' && c <= '8' -> Just (GoScene (fromEnum c - fromEnum '1')) _ -> Nothing ] @@ -182,13 +210,14 @@ view s = let header = renderHeader s content = case scene s of- 0 -> scenePhysicsGame s- 1 -> sceneTextInput s- 2 -> sceneBordersStyles s- 3 -> sceneTables s- 4 -> sceneChartsPlots s- 5 -> sceneBarChartsSparklines s- 6 -> sceneSelectionsHeatmap s+ 0 -> sceneRayMarcher s+ 1 -> scenePhysicsGame s+ 2 -> sceneTextInput s+ 3 -> sceneBordersStyles s+ 4 -> sceneTables s+ 5 -> sceneChartsPlots s+ 6 -> sceneBarChartsSparklines s+ 7 -> sceneSelectionsHeatmap s _ -> text "Unknown scene" footer = renderFooter s in alignLeft sceneWidth $ render $ layout [header, br, content, br, footer]@@ -217,16 +246,17 @@ renderFooter :: ShowcaseState -> L renderFooter s = let hints = case scene s of- 0 -> " </> scenes Space kick +/- gravity ESC quit"- 1 -> " </> scenes type + Enter to add ESC quit"- 3 -> " </> scenes ^/v navigate Space select ESC quit"- 4 -> " </> scenes +/- move threshold ESC quit"- 5 -> " </> scenes Tab cycle chart mode ESC quit"- 6 -> " </> scenes ^/v navigate Space toggle ESC quit"+ 0 -> " </> scenes wasd orbit +/- zoom Space shape ESC quit"+ 1 -> " </> scenes Space kick +/- gravity ESC quit"+ 2 -> " </> scenes type + Enter to add ESC quit"+ 4 -> " </> scenes ^/v navigate Space select ESC quit"+ 5 -> " </> scenes +/- move threshold ESC quit"+ 6 -> " </> scenes Tab cycle chart mode ESC quit"+ 7 -> " </> scenes ^/v navigate Space toggle ESC quit" _ -> " </> scenes ESC quit" in withStyle StyleDim $ withColor ColorBrightBlack $ text hints --- Scene 1: Physics Game+-- Scene 2: Physics Game scenePhysicsGame :: ShowcaseState -> L scenePhysicsGame s =@@ -261,8 +291,36 @@ ] ] --- Scene 2: Text Input & Lists+-- Scene 1: Ray Marcher +sceneRayMarcher :: ShowcaseState -> L+sceneRayMarcher s =+ let fb = renderRayFrame (rayTheta s) (rayPhi s) (rayDist s) (rayMorph s)+ twoPi = 2 * pi :: Double+ thetaWrapped = rayTheta s - twoPi * fromIntegral (floor (rayTheta s / twoPi) :: Int)+ cameraStats = withColor ColorBrightBlue $ kv+ [ ("th", printf "%.2f" thetaWrapped)+ , ("ph", printf "%.2f" (rayPhi s))+ , ("zoom", printf "%.1f" (rayDist s))+ ]+ controls = withStyle StyleDim $ layout+ [ withColor ColorBrightYellow $ text "wasd orbit"+ , withColor ColorBrightYellow $ text "+/- zoom"+ , withColor ColorBrightYellow $ text "Space shape"+ ]+ camera = alignLeft 20 $ render $ layout+ [ cameraStats+ , br+ , withColor ColorBrightCyan $ spinner "render" (tick s `div` 2) SpinnerDots+ , withColor ColorBrightYellow $ spinner "light" (tick s `div` 2) SpinnerBounce+ , br+ , controls+ ]+ cameraBox = withColor ColorBrightMagenta $ withBorder BorderRound $ box "Camera" [camera]+ in row [text fb, cameraBox]++-- Scene 3: Text Input & Lists+ sceneTextInput :: ShowcaseState -> L sceneTextInput s = let inputLine =@@ -316,7 +374,7 @@ ] ] --- Scene 3: Borders & Styles+-- Scene 4: Borders & Styles sceneBordersStyles :: ShowcaseState -> L sceneBordersStyles _ =@@ -347,7 +405,7 @@ ] ] --- Scene 4: Tables+-- Scene 5: Tables sceneTables :: ShowcaseState -> L sceneTables s =@@ -376,7 +434,7 @@ ] ] --- Scene 5: Charts & Plots+-- Scene 6: Charts & Plots sceneChartsPlots :: ShowcaseState -> L sceneChartsPlots s =@@ -406,7 +464,7 @@ ] ] --- Scene 6: Bar Charts & Sparklines+-- Scene 7: Bar Charts & Sparklines sceneBarChartsSparklines :: ShowcaseState -> L sceneBarChartsSparklines s =@@ -446,7 +504,7 @@ ] ] --- Scene 7: Selections & Heatmap+-- Scene 8: Selections & Heatmap sceneSelectionsHeatmap :: ShowcaseState -> L sceneSelectionsHeatmap s =@@ -491,6 +549,165 @@ , withBorder BorderRound $ box "Weekly Activity" [ plotHeatmap' 5 (HeatmapData heatData days hours) ] ]++-- Ray marcher helpers (Scene 1)++-- | 3D vector+data V3 = V3 !Double !Double !Double++vUp :: V3+vUp = V3 0 1 0++vadd, vsub, vcross :: V3 -> V3 -> V3+vadd (V3 ax ay az) (V3 bx by bz) = V3 (ax + bx) (ay + by) (az + bz)+vsub (V3 ax ay az) (V3 bx by bz) = V3 (ax - bx) (ay - by) (az - bz)+vcross (V3 ax ay az) (V3 bx by bz) =+ V3 (ay * bz - az * by) (az * bx - ax * bz) (ax * by - ay * bx)++vscale :: V3 -> Double -> V3+vscale (V3 x y z) k = V3 (x * k) (y * k) (z * k)++vdot :: V3 -> V3 -> Double+vdot (V3 ax ay az) (V3 bx by bz) = ax * bx + ay * by + az * bz++vlen :: V3 -> Double+vlen v = sqrt (vdot v v)++vneg :: V3 -> V3+vneg (V3 x y z) = V3 (-x) (-y) (-z)++vnorm :: V3 -> V3+vnorm v = let l = vlen v in if l < 1e-10 then V3 0 0 0 else vscale v (1.0 / l)++-- | One screen cell with character + 24-bit color+data Pixel = Pixel !Char !Int !Int !Int++-- | Render a list of pixels into an ANSI string of width @w@+renderFrameBuffer :: [Pixel] -> Int -> String+renderFrameBuffer pixels w = go pixels+ where+ go [] = ""+ go ps =+ let (rowPixels, rest) = splitAt w ps+ line = concatMap pixelToAnsi rowPixels ++ "\ESC[0m"+ in if null rest then line else line ++ "\n" ++ go rest+ pixelToAnsi (Pixel ch r g b) =+ "\ESC[38;2;" ++ show r ++ ";" ++ show g ++ ";" ++ show b ++ "m" ++ [ch]++rayW, rayH, rayMaxSteps :: Int+rayW = 46+rayH = 22+rayMaxSteps = 50++rayMaxDist, rayEps :: Double+rayMaxDist = 20.0+rayEps = 0.005++rayRamp :: String+rayRamp = " .'`^\",:;Il!i><~+_-?][}{1)(|/tfjrxnuvczXYUJCLQ0OZmwqpdbkhao*#MW&8%B@$"++clampD :: Double -> Double -> Double -> Double+clampD lo hi x = max lo (min hi x)++mixD :: Double -> Double -> Double -> Double+mixD a b t = a * (1.0 - t) + b * t++rSmoothstep :: Double -> Double -> Double -> Double+rSmoothstep lo hi x =+ let t = clampD 0.0 1.0 ((x - lo) / (hi - lo))+ in t * t * (3.0 - 2.0 * t)++sdTorus :: V3 -> Double -> Double -> Double+sdTorus (V3 x y z) bigR r =+ let qx = sqrt (x * x + z * z) - bigR+ in sqrt (qx * qx + y * y) - r++sdRoundBox :: V3 -> V3 -> Double -> Double+sdRoundBox (V3 px py pz) (V3 bx by bz) r =+ let qx = abs px - bx+ qy = abs py - by+ qz = abs pz - bz+ outer = vlen (V3 (max qx 0) (max qy 0) (max qz 0))+ inner = min (max qx (max qy qz)) 0.0+ in outer + inner - r++rayScene :: V3 -> Double -> Double+rayScene p morph =+ let tor = sdTorus p 0.9 0.38+ cub = sdRoundBox p (V3 0.72 0.72 0.72) 0.12+ in mixD tor cub (rSmoothstep 0 1 (clampD 0.0 1.0 morph))++calcNormal :: V3 -> Double -> V3+calcNormal (V3 x y z) morph =+ let e = 0.001+ in vnorm $ V3+ (rayScene (V3 (x + e) y z) morph - rayScene (V3 (x - e) y z) morph)+ (rayScene (V3 x (y + e) z) morph - rayScene (V3 x (y - e) z) morph)+ (rayScene (V3 x y (z + e)) morph - rayScene (V3 x y (z - e)) morph)++march :: V3 -> V3 -> Double -> Double+march ro rd morph = go 0.0 (0 :: Int)+ where+ go t i+ | i >= rayMaxSteps || t >= rayMaxDist = -1.0+ | otherwise =+ let d = rayScene (vadd ro (vscale rd t)) morph+ in if d < rayEps then t else go (t + d) (i + 1)++rayLightDir, rayFillDir :: V3+rayLightDir = vnorm (V3 0.8 1.0 (-0.6))+rayFillDir = vnorm (V3 (-0.6) 0.4 0.7)++rayBgPixel :: V3 -> Pixel+rayBgPixel (V3 _ y _) =+ let vy = y * 0.5 + 0.5+ bg = max 4 (floor (18.0 - (1.0 - vy) * 8.0) :: Int)+ in Pixel ' ' bg bg (bg + 6)++rayShade :: V3 -> V3 -> Double -> Pixel+rayShade ro rd morph =+ let t = march ro rd morph+ in if t < 0+ then rayBgPixel rd+ else+ let hit = vadd ro (vscale rd t)+ n = calcNormal hit morph+ diff = max (vdot n rayLightDir) 0.0+ fill = max (vdot n rayFillDir) 0.0 * 0.35+ refl = vsub (vscale n (2.0 * vdot n rayLightDir)) rayLightDir+ spec = (max (vdot refl (vneg rd)) 0.0) ** 32.0 * 0.6+ ao = 1.0 - clampD 0.0 0.4 (rayScene (vadd hit (vscale n 0.1)) morph * 5.0)+ -- Floor keeps hit surfaces above the ramp's whitespace glyphs+ lum = clampD 0.0 1.0 (max ((0.12 + diff * 0.7 + fill + spec) * ao) 0.18)+ rampLen = length rayRamp+ idx = floor (clampD 0 (fromIntegral rampLen - 1) (lum * fromIntegral (rampLen - 1))) :: Int+ ch = rayRamp !! idx+ V3 nx ny nz = n+ nx' = nx * 0.5 + 0.5+ ny' = ny * 0.5 + 0.5+ nz' = nz * 0.5 + 0.5+ rC = floor (clampD 0 255 ((nx' * 0.55 + lum * 0.45) * 235 + 20)) :: Int+ gC = floor (clampD 0 255 ((ny' * 0.45 + lum * 0.55) * 215 + 15)) :: Int+ bC = floor (clampD 0 255 ((nz' * 0.50 + lum * 0.50 + 0.05) * 200 + 30)) :: Int+ in Pixel ch rC gC bC++renderRayFrame :: Double -> Double -> Double -> Double -> String+renderRayFrame theta phi dist morph =+ let ro = V3 (dist * sin theta * cos phi)+ (dist * sin phi)+ (dist * cos theta * cos phi)+ fwd = vnorm (vneg ro)+ right = vnorm (vcross fwd vUp)+ up = vcross right fwd+ aspect = fromIntegral rayW / fromIntegral rayH * 0.48+ pixels = [ rayShade ro rd morph+ | py <- [0 .. rayH - 1]+ , let v = 0.5 - fromIntegral py / fromIntegral rayH+ , px <- [0 .. rayW - 1]+ , let u = (fromIntegral px / fromIntegral rayW - 0.5) * aspect+ , let rd = vnorm (vadd (vadd fwd (vscale right u)) (vscale up v))+ ]+ in renderFrameBuffer pixels rayW -- App
layoutz.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: layoutz-version: 0.3.4.0+version: 0.4.0.0 synopsis: Simple, beautiful CLI output description: Zero-dep, compositional terminal output homepage: https://github.com/mattlianje/layoutz@@ -27,10 +27,20 @@ exposed-modules: Layoutz build-depends: base >= 4.7 && < 5 , text+ , containers+ , directory hs-source-dirs: . default-language: Haskell2010 ghc-options: -Wall +executable ask-demo+ main-is: AskDemo.hs+ build-depends: base >= 4.7 && < 5+ , layoutz+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -Wall+ executable inline-bar main-is: InlineBar.hs build-depends: base >= 4.7 && < 5@@ -54,6 +64,14 @@ hs-source-dirs: examples default-language: Haskell2010 ghc-options: -Wall++executable raymarcher+ main-is: RayMarcher.hs+ build-depends: base >= 4.7 && < 5+ , layoutz+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -Wall -O2 test-suite layoutz-tests type: exitcode-stdio-1.0
+ pix/haskell-kitty-1.png view
binary file changed (absent → 618801 bytes)
+ pix/haskell-kitty-2.png view
binary file changed (absent → 304237 bytes)
test/Test.hs view
@@ -34,6 +34,29 @@ , styleTests , commandTests , visualizationTests+ , columnsTruncateBannerTests+ ]++-- columns / truncate / banner+columnsTruncateBannerTests :: TestTree+columnsTruncateBannerTests = testGroup "Columns, Truncate & Banner"+ [ testCase "columns places elements side by side" $+ render (columns [layout ["A", "B"], layout ["C", "D"]]) @?= "A C\nB D"++ , testCase "columns' custom spacing" $+ render (columns' 1 [layout ["A"], layout ["B"]]) @?= "A B"++ , testCase "truncate' leaves short text untouched" $+ render (truncate' 15 (text "short")) @?= "short"++ , testCase "truncate' cuts long text with default ellipsis" $+ render (truncate' 15 (text "Very long text that will be cut off")) @?= "Very long te..."++ , testCase "truncate'' custom ellipsis" $+ render (truncate'' 20 "…" (text "Custom ellipsis example text here")) @?= "Custom ellipsis exa…"++ , testCase "banner is a titleless double-bordered box" $+ render (banner ["System Dashboard"]) @?= "╔══════════════════╗\n║ System Dashboard ║\n╚══════════════════╝" ] -- Basic element tests