layoutz-0.1.1.0: Layoutz.hs
{-# LANGUAGE OverloadedStrings, ExistentialQuantification, FlexibleInstances #-}
{- |
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
-- * Border utilities
, withBorder
-- * Color utilities
, withColor
-- * Style utilities
, withStyle
-- * Rendering
, render
) where
import Data.List (intercalate, transpose)
import Data.String (IsString(..))
import Text.Printf (printf)
-- | 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 real terminal width of string (handles ANSI, emoji, CJK)
realLength :: String -> Int
realLength = sum . map charWidth . stripAnsi
-- | Calculate visible width (ignoring ANSI codes, handling wide chars)
visibleLength :: String -> Int
visibleLength = realLength
-- | 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) =
let rendered = render element
renderedLines = lines rendered
coloredLines = map (wrapAnsi color) renderedLines
-- Preserve whether original had trailing newline
hasTrailingNewline = not (null rendered) && last rendered == '\n'
in if hasTrailingNewline
then unlines coloredLines
else intercalate "\n" coloredLines
renderElement (Styled style element) =
let rendered = render element
renderedLines = lines rendered
styledLines = map (wrapStyle style) renderedLines
-- Preserve whether original had trailing newline
hasTrailingNewline = not (null rendered) && last rendered == '\n'
in if hasTrailingNewline
then unlines styledLines
else intercalate "\n" styledLines
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 0 255 n)
where clamp min' max' val = max min' (min max' val)
colorCode (ColorTrue r g b) = "38;2;" ++ show (clamp 0 255 r) ++ ";" ++ show (clamp 0 255 g) ++ ";" ++ show (clamp 0 255 b)
where clamp min' max' val = max min' (min max' val)
-- | 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
newtype 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)
underlinePattern = underlineChar
underlinePart = if length underlinePattern >= maxWidth
then take maxWidth underlinePattern
else let repeats = maxWidth `div` length underlinePattern
remainder = maxWidth `mod` length underlinePattern
in concat (replicate repeats underlinePattern) ++ take remainder underlinePattern
coloredUnderline = case maybeColor of
Nothing -> underlinePart
Just color -> wrapAnsi color underlinePart
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 (realLength . fst) pairs)
alignmentPosition = maxKeyLength + 2
in intercalate "\n" $ map (renderPair alignmentPosition) pairs
where
renderPair alignPos (key, value) =
let keyWithColon = key ++ ":"
spacesNeeded = alignPos - realLength 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
isUnorderedList :: L -> Bool
isUnorderedList (UL _) = True
isUnorderedList _ = False
getUnorderedListItems :: L -> [L]
getUnorderedListItems (UL items) = items
getUnorderedListItems _ = []
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 =
if isUnorderedList item
then renderAtLevel (level + 1) (getUnorderedListItems item)
else
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) =
if isOrderedList item
then renderAtLevel 1 (level + 1) (getOrderedListItems item)
else
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 level num =
case level `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 n = case n of
1 -> "i"
2 -> "ii"
3 -> "iii"
4 -> "iv"
5 -> "v"
6 -> "vi"
7 -> "vii"
8 -> "viii"
9 -> "ix"
10 -> "x"
_ -> show n -- fallback for numbers > 10
isOrderedList :: L -> Bool
isOrderedList (OL _) = True
isOrderedList _ = False
getOrderedListItems :: L -> [L]
getOrderedListItems (OL xs) = xs
getOrderedListItems _ = []
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 items = UL items
ol :: [L] -> L
ol items = OL items
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 BorderThick $ statusCard "API" "UP"
-- withBorder BorderDouble $ table ["Name"] [[text "Alice"]]
withBorder :: Border -> L -> L
withBorder = setBorder
-- | Apply a color to an element
--
-- Example usage:
-- withColor ColorRed $ text "Error!"
-- withColor ColorGreen $ statusCard "Status" "OK"
-- withColor ColorBrightYellow $ box "Warning" [text "Check logs"]
withColor :: Color -> L -> L
withColor color element = Colored color element
-- | Apply a style to an element
--
-- Example usage:
-- withStyle StyleBold $ text "Important!"
-- withStyle StyleItalic $ text "Emphasis"
-- withStyle StyleUnderline $ text "Notice"
withStyle :: Style -> L -> L
withStyle style element = Styled style element
-- | 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