diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Layoutz.hs b/Layoutz.hs --- a/Layoutz.hs +++ b/Layoutz.hs @@ -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=\@ 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 () diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,7 @@ +
+ part of d4 +
+

@@ -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

- +
ShowcaseApp.hs

@@ -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 @@

-**(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 @@

+**(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 () +``` +

+ +
+ AskDemo.hs +

+ ## 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")]] + ] ``` +

+ +

-### 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] ``` +

+ +

+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 () +``` + +

+ +

+ +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 () +``` + +

+ +

+ ## 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. + +
+Print a deploy / status summary (section + statusCard + kv) + +```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")] + ] +``` +
+ +
+Compiler-style error message (margin + underline') + +```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 +``` +
+ +
+Render a table straight from records (table) + +```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 ] +``` +
+ +
+Progress bar over a batch of work (loader) + +```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" +``` +
+ +
+Gate a destructive action behind a confirm (askConfirm) + +```haskell +import Layoutz + +main :: IO () +main = do + ok <- askConfirm "Drop production table?" False "Yes" "No" + if ok then putStrLn "dropping…" else putStrLn "cancelled" +``` +
+ +
+Wrap a slow query in a spinner (askSpin) + +```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) +``` +
+ ## 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. diff --git a/examples/AskDemo.hs b/examples/AskDemo.hs new file mode 100644 --- /dev/null +++ b/examples/AskDemo.hs @@ -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] ] diff --git a/examples/RayMarcher.hs b/examples/RayMarcher.hs new file mode 100644 --- /dev/null +++ b/examples/RayMarcher.hs @@ -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 diff --git a/examples/ShowcaseApp.hs b/examples/ShowcaseApp.hs --- a/examples/ShowcaseApp.hs +++ b/examples/ShowcaseApp.hs @@ -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 diff --git a/layoutz.cabal b/layoutz.cabal --- a/layoutz.cabal +++ b/layoutz.cabal @@ -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 diff --git a/pix/haskell-kitty-1.png b/pix/haskell-kitty-1.png new file mode 100644 Binary files /dev/null and b/pix/haskell-kitty-1.png differ diff --git a/pix/haskell-kitty-2.png b/pix/haskell-kitty-2.png new file mode 100644 Binary files /dev/null and b/pix/haskell-kitty-2.png differ diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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