layoutz-0.2.0.0: Layoutz.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{- |
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(..)
-- * Border utilities
, withBorder
-- * Color utilities
, withColor
-- * Style utilities
, withStyle
-- * Rendering
, render
-- * TUI Runtime
, LayoutzApp(..)
, Key(..)
, Cmd(..)
, cmd
, cmdMsg
, executeCmd
, Sub(..)
, runApp
-- * Subscriptions
, onKeyPress
, onTick
, batch
) where
import Data.List (intercalate, transpose)
import Data.String (IsString(..))
import Data.Char (ord, chr)
import Text.Printf (printf)
import System.IO
import System.Exit (exitSuccess)
import Control.Exception (catch, AsyncException(..))
import System.Timeout (timeout)
import Control.Monad (when, forever)
import Control.Concurrent (forkIO, threadDelay, killThread, Chan, 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
-- | 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 | 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 = ColorNoColor | 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 ColorNoColor = ""
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 = StyleNoStyle | StyleBold | StyleDim | StyleItalic | StyleUnderline
| StyleBlink | StyleReverse | StyleHidden | StyleStrikethrough
| StyleCombined [Style] -- ^ Combine multiple styles
deriving (Show, Eq)
-- | Combine styles using ++
instance Semigroup Style where
StyleNoStyle <> other = other
other <> StyleNoStyle = 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 = StyleNoStyle
-- | Get ANSI style code
styleCode :: Style -> String
styleCode StyleNoStyle = ""
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"
borderChars :: Border -> (String, String, String, String, String, String, String, String, String)
borderChars BorderNormal = ("┌", "┐", "└", "┘", "─", "│", "├", "┤", "┼")
borderChars BorderDouble = ("╔", "╗", "╚", "╝", "═", "║", "╠", "╣", "╬")
borderChars BorderThick = ("┏", "┓", "┗", "┛", "━", "┃", "┣", "┫", "╋")
borderChars BorderRound = ("╭", "╮", "╰", "╯", "─", "│", "├", "┤", "┼")
borderChars BorderNone = (" ", " ", " ", " ", " ", " ", " ", " ", " ")
-- 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 length contentLines)
titleWidth = if null title then 0 else length title + 2
innerWidth = max contentWidth titleWidth
totalWidth = innerWidth + 4
(topLeft, topRight, bottomLeft, bottomRight, horizontal, vertical, _, _, _) = borderChars border
hChar = head horizontal
topBorder
| null title = topLeft ++ replicate (totalWidth - 2) hChar ++ topRight
| otherwise = let titlePadding = totalWidth - length title - 2
leftPad = titlePadding `div` 2
rightPad = titlePadding - leftPad
in topLeft ++ replicate leftPad hChar ++ title ++ replicate rightPad hChar ++ topRight
bottomBorder = bottomLeft ++ replicate (totalWidth - 2) hChar ++ bottomRight
paddedContent = map (\line -> vertical ++ " " ++ padRight innerWidth line ++ " " ++ vertical) 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 length allLines)
contentWidth = maxWidth + 2
(topLeft, topRight, bottomLeft, bottomRight, horizontal, vertical, _, _, _) = borderChars border
hChar = head horizontal
topBorder = topLeft ++ replicate (contentWidth + 2) hChar ++ topRight
bottomBorder = bottomLeft ++ replicate (contentWidth + 2) hChar ++ bottomRight
createCardLine line = vertical ++ " " ++ padRight contentWidth line ++ " " ++ vertical
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
(topLeft, topRight, bottomLeft, bottomRight, horizontal, vertical, leftTee, rightTee, cross) = borderChars border
hChar = head horizontal
-- Fixed border construction with proper connectors
topConnector = case border of
BorderRound -> "┬"
BorderNormal -> "┬"
BorderDouble -> "╦"
BorderThick -> "┳"
BorderNone -> " "
topParts = map (\w -> replicate w hChar) columnWidths
topBorder = topLeft ++ [hChar] ++ intercalate ([hChar] ++ topConnector ++ [hChar]) topParts ++ [hChar] ++ topRight
-- Create proper separator with tee connectors
separatorParts = map (\w -> replicate w hChar) columnWidths
separatorBorder = leftTee ++ [hChar] ++ intercalate ([hChar] ++ cross ++ [hChar]) separatorParts ++ [hChar] ++ rightTee
-- Create proper bottom border with bottom connectors
bottomConnector = case border of
BorderRound -> "┴" -- Special case for round borders
BorderNormal -> "┴"
BorderDouble -> "╩"
BorderThick -> "┻"
BorderNone -> " "
bottomParts = map (\w -> replicate w hChar) columnWidths
bottomBorder = bottomLeft ++ [hChar] ++ intercalate ([hChar] ++ bottomConnector ++ [hChar]) bottomParts ++ [hChar] ++ bottomRight
-- Create header row
headerCells = zipWith padRight columnWidths headers
headerRow = vertical ++ " " ++ intercalate (" " ++ vertical ++ " ") headerCells ++ " " ++ vertical
-- Create data rows
dataRows = concatMap (renderTableRow columnWidths vertical) 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 -> [L] -> [String]
renderTableRow widths vChars 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 -> vChars ++ " " ++ intercalate (" " ++ vChars ++ " ") rowCells ++ " " ++ vChars) 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
--
-- Example usage:
-- 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
--
-- Example usage:
-- 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
--
-- Example usage:
-- withBorder BorderDouble $ table ["Name"] [[text "Alice"]]
withBorder :: Border -> L -> L
withBorder = setBorder
-- | Apply a color to an element
--
-- Example usage:
-- withColor ColorBrightYellow $ box "Warning" [text "Check logs"]
withColor :: Color -> L -> L
withColor = Colored
-- | Apply a style to an element
-- Example usage:
-- 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)
-- ============================================================================
-- TUI Runtime - Simple event loop for interactive terminal applications
-- ============================================================================
-- | Keyboard input representation
data Key
= CharKey Char -- ^ Regular character keys: 'a', '1', ' ', etc.
| EnterKey -- ^ Enter/Return key
| BackspaceKey -- ^ Backspace key
| TabKey -- ^ Tab key
| EscapeKey -- ^ Escape key
| DeleteKey -- ^ Delete key
| ArrowUpKey -- ^ Up arrow
| ArrowDownKey -- ^ Down arrow
| ArrowLeftKey -- ^ Left arrow
| ArrowRightKey -- ^ Right arrow
| SpecialKey String -- ^ Ctrl+X, etc.
deriving (Show, Eq)
-- | Commands - side effects the runtime will execute after each update
data Cmd msg
= None -- ^ No effect
| Cmd (IO (Maybe msg)) -- ^ Run IO, optionally produce a message
| Batch [Cmd msg] -- ^ Combine multiple commands
-- | Create a command from an IO action (fire and forget)
cmd :: IO () -> Cmd msg
cmd io = Cmd (io >> pure Nothing)
-- | Create a command that produces a message after IO completes
cmdMsg :: IO msg -> Cmd msg
cmdMsg io = Cmd (Just <$> io)
-- | Execute a command and return any resulting message
executeCmd :: Cmd msg -> IO (Maybe msg)
executeCmd None = pure Nothing
executeCmd (Cmd io) = io
executeCmd (Batch cmds) = do
results <- mapM executeCmd cmds
pure $ foldr pickFirst Nothing results
where
pickFirst (Just m) _ = Just m
pickFirst Nothing r = r
-- | Subscriptions - event sources your app listens to
data Sub msg
= SubNone -- ^ No subscriptions
| SubKeyPress (Key -> Maybe msg) -- ^ Subscribe to keyboard input
| SubTick msg -- ^ Subscribe to periodic ticks (~100ms)
| SubBatch [Sub msg] -- ^ Combine multiple subscriptions
-- | Combine multiple subscriptions
batch :: [Sub msg] -> Sub msg
batch = SubBatch
-- | Subscribe to keyboard events
onKeyPress :: (Key -> Maybe msg) -> Sub msg
onKeyPress = SubKeyPress
-- | Subscribe to periodic ticks for animations
onTick :: msg -> Sub msg
onTick = SubTick
-- | 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, None)
-- , appUpdate = \\msg count -> case msg of
-- Inc -> (count + 1, None)
-- Dec -> (count - 1, None)
-- , appSubscriptions = \\_ -> onKeyPress $ \\key -> case key of
-- CharKey '+' -> Just Inc
-- CharKey '-' -> 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
}
-- | Run an interactive TUI application
--
-- This function:
-- * Sets up raw terminal mode (no echo, no buffering)
-- * Clears screen and hides cursor
-- * Renders initial view
-- * 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 LayoutzApp{..} = do
oldBuffering <- hGetBuffering stdin
oldEcho <- hGetEcho stdin
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
hSetEcho stdin False
enterAltScreen
clearScreen
hideCursor
let (initialState, initialCmd) = appInit
stateRef <- newIORef initialState
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)
case cmdToRun of
None -> pure ()
_ -> writeChan cmdChan cmdToRun
-- Command thread: executes commands async, feeds results back
cmdThread <- forkIO $ forever $ do
cmdToRun <- readChan cmdChan
maybeMsg <- executeCmd cmdToRun
case maybeMsg of
Just msg -> updateState msg -- Feed message back into app
Nothing -> pure ()
-- Execute initial command
case initialCmd of
None -> 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
-- Move cursor home, then write each line with clear-to-end-of-line
output = "\ESC[H" ++ concatMap (\l -> l ++ "\ESC[K\n") renderedLines -- TODO refactor
++ concat (replicate (max 0 (prevLineCount - currentLineCount)) "\ESC[K\n") -- clears lines from previous render
putStr output
hFlush stdout
writeIORef lastRendered rendered
writeIORef lastLineCount currentLineCount
threadDelay 33333
let hasTick sub = case sub of
SubTick _ -> True
SubBatch subs -> any hasTick subs
_ -> False
getKeyHandler sub = case sub of
SubKeyPress handler -> Just handler
SubBatch subs -> case [h | SubKeyPress h <- subs] of
(h:_) -> Just h
[] -> Nothing
_ -> Nothing
getTickMsg sub = case sub of
SubTick msg -> Just msg
SubBatch subs -> case [msg | SubTick msg <- subs] of
(msg:_) -> Just msg
[] -> Nothing
_ -> Nothing
let killThreads = killThread renderThread >> killThread cmdThread
inputLoop = do
state <- readIORef stateRef
let subs = appSubscriptions state
hasTickSub = hasTick subs
keyHandler = getKeyHandler subs
tickMsg = getTickMsg subs
maybeKey <- if hasTickSub
then timeout 100000 readKey
else Just <$> readKey
case maybeKey of
Nothing -> do
case tickMsg of
Just msg -> updateState msg >> inputLoop
Nothing -> inputLoop
Just key -> case key of
EscapeKey -> killThreads >> cleanup oldBuffering oldEcho
SpecialKey "Ctrl+C" -> killThreads >> cleanup oldBuffering oldEcho
SpecialKey "Ctrl+D" -> killThreads >> cleanup oldBuffering oldEcho
_ -> case keyHandler of
Just handler -> case handler key of
Just msg -> updateState msg >> inputLoop
Nothing -> inputLoop
Nothing -> inputLoop
inputLoop `catch` \ex -> case ex of
UserInterrupt -> killThreads >> cleanup oldBuffering oldEcho
_ -> killThreads >> cleanup oldBuffering oldEcho
-- | Clean up terminal and exit
cleanup :: BufferMode -> Bool -> IO ()
cleanup oldBuffering oldEcho = do
showCursor
exitAltScreen
hFlush stdout
hSetBuffering stdin oldBuffering
hSetEcho stdin oldEcho
exitSuccess
-- | 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 EnterKey -- LF (Unix)
13 -> return EnterKey -- CR (Windows/Mac)
27 -> readEscapeSequence -- ESC - might be arrow key
9 -> return TabKey
127 -> return BackspaceKey -- DEL (often used as backspace)
8 -> return BackspaceKey -- BS
n | n >= 32 && n <= 126 -> return $ CharKey (chr n) -- Printable ASCII
| n < 32 -> return $ SpecialKey ("Ctrl+" ++ [chr (n + 64)]) -- Ctrl+Key
| otherwise -> return $ CharKey (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 EscapeKey -- Timeout - just ESC key pressed
Just '[' -> do
-- It's an escape sequence, read the command character
c2 <- getChar
case c2 of
'A' -> return ArrowUpKey
'B' -> return ArrowDownKey
'C' -> return ArrowRightKey
'D' -> return ArrowLeftKey
'3' -> do
c3 <- getChar -- Read the '~'
if c3 == '~'
then return DeleteKey
else return EscapeKey
_ -> return EscapeKey
Just _ -> return EscapeKey -- Some other character after ESC