Block.hs

-- | Blocks of styled text and how to combine them.
--
-- A 'Block' does not have a width until it is laid out: text in it wraps,
-- and things that 'Lipstick.Mod.grow' take spare columns, to fit the width
-- it gets. Output functions lay blocks out in the output's width (see
-- 'Lipstick.Ansi.envWidth'); 'layout' does it explicitly.
--
-- == Examples
--
-- A block of text has a natural width, the narrowest it can be without
-- breaking words, and a height at its natural width:
--
-- >>> let para = text "A block takes the width it is given."
-- >>> (blockWidth para, blockMinWidth para, blockHeight para)
-- (36,6,1)
--
-- Laid out in less width, the text wraps:
--
-- >>> putBlock (fromGrid (layout (Just 16) para))
-- A block takes
-- the width it is
-- given.
--
-- Blocks side by side, aligned by a 'Position':
--
-- >>> let tall = render (border normalBorder) "one\ntwo\nthree"
-- >>> let short = render (border normalBorder) "four"
-- >>> putBlock (joinHorizontal top [tall, short])
-- ┌─────┐┌────┐
-- │one  ││four│
-- │two  │└────┘
-- │three│
-- └─────┘
-- >>> putBlock (joinHorizontal center [tall, short])
-- ┌─────┐
-- │one  │┌────┐
-- │two  ││four│
-- │three│└────┘
-- └─────┘
--
-- Stacked:
--
-- >>> putBlock (joinVertical right [tall, short])
-- ┌─────┐
-- │one  │
-- │two  │
-- │three│
-- └─────┘
--  ┌────┐
--  │four│
--  └────┘
--
-- A block that 'Lipstick.Mod.fillWidth's takes the spare columns of its
-- row, and one that 'Lipstick.Mod.stretchHeight's is as tall as the row:
--
-- >>> let stretchy = render (border normalBorder <> fillWidth <> stretchHeight) "fills"
-- >>> putBlock (fromGrid (layout (Just 30) (hcat [tall, stretchy])))
-- ┌─────┐┌─────────────────────┐
-- │one  ││fills                │
-- │two  ││                     │
-- │three││                     │
-- └─────┘└─────────────────────┘
--
-- Text with several styles is 'Inline', built with 'styled' and '<>'
-- (the output is shown without its attributes):
--
-- >>> putBlock (render (width 20) (styled bold "Error: " <> "the file " <> styled italic "notes.txt" <> " was not found"))
-- Error: the file
-- notes.txt was not
-- found
module Lipstick.Block
  ( -- * Blocks
    Block
  , blockWidth
  , blockHeight
  , blockMinWidth
  , blockGrows
  , emptyBlock
  , text
  , fromInline

    -- * Laying out
  , layout
  , Grid
  , gridWidth
  , gridHeight
  , fromGrid

    -- * Inline text
  , Inline
  , plain
  , styled
  , styleRanges
  , styleIndices

    -- * Joining
  , joinHorizontal
  , joinVertical
  , hcat
  , vcat
  , Position
  , position
  , left
  , center
  , right
  , top
  , bottom
  ) where

import Data.IntSet qualified as IntSet
import Data.Text (Text)
import Data.Text qualified as T
import Lipstick.Grid (Grid, gridHeight, gridWidth)
import Lipstick.Internal.Grid hiding (Grid (..))
import Lipstick.Internal.Layout
import Lipstick.Internal.Types
import Lipstick.Internal.Mod (Mod, Props (..), propsOf, runMod)

-- $setup
-- >>> import Lipstick

-- | The natural width of a block: the 'Lipstick.Mod.width' of a box that
-- has one, or else as wide as it is with nothing wrapped.
blockWidth :: Block -> Int
blockWidth = reqMax . blockRequest . measure

-- | The height of a block at its natural width.
blockHeight :: Block -> Int
blockHeight b = snd (blockLayout (measure b) (Assign (blockWidth b) 0))

-- | The least width a block gets when width is shared out: the
-- 'Lipstick.Mod.width' of a box that has one, or else the narrowest it can
-- be without breaking a word. Given less, it still shrinks.
blockMinWidth :: Block -> Int
blockMinWidth = reqMin . blockRequest . measure

-- | Whether a block takes spare width (see 'Lipstick.Mod.grow'), as an
-- adapter needs to know to size it.
blockGrows :: Block -> Bool
blockGrows = (> 0) . reqGrow . blockRequest . measure

-- | Unstyled text; lines are split on newlines, and wrap to the width the
-- block is given.
text :: Text -> Block
text = fromInline . plain

-- | Inline text as a block, without any box around it. Lines wrap to the
-- width the block is given.
fromInline :: Inline -> Block
fromInline = textBlock

-- | Text with attributes, for building 'Inline' text with '<>'. Only the
-- text attributes of the modifier apply.
--
-- >>> putBlock (fromInline (styled bold "Error: " <> "file not found"))
-- Error: file not found
styled :: Mod Inline -> Text -> Inline
styled m t = Inline [(propAttrs (snd (runMod m mempty)), t)]

-- | Place blocks side by side. Spare columns go to blocks that
-- 'Lipstick.Mod.grow'; when there are too few columns, the widest blocks
-- shrink first, and what does not fit even at one column each is cut off
-- on the right. The position aligns shorter blocks vertically ('top',
-- 'center', 'bottom'); blocks that 'Lipstick.Mod.stretchHeight' take the
-- row's height instead.
joinHorizontal :: Position -> [Block] -> Block
joinHorizontal p bs = Block $ \ctx ->
  let ns = map (measureIn ctx) bs
      rs = map blockRequest ns
   in rowNode p ns rs

rowNode :: Position -> [Measured] -> [Request] -> Measured
rowNode p ns rs = Measured req run
  where
    req =
      Request
        { reqMin = sum (map reqMin rs)
        , reqMax = sum (map reqMax rs)
        , reqGrow = sum (map reqGrow rs)
        , reqLimit = addLimits rs
        , reqStretch = any reqStretch rs
        , reqFill = False
        }
    run (Assign w h) = (fitWidth w (joinGridsH p (map fst results)), natural)
      where
        ws = allocateWithin w [(reqMin r, reqMax r, reqGrow r, reqLimit r) | r <- rs]
        -- The row height goes into the calls that give the natural heights
        -- it is computed from: a block's natural height never depends on
        -- the height it is asked to stretch to.
        results = [blockLayout n (Assign bw rowH) | (n, bw) <- zip ns ws]
        natural = maximum (0 : map snd results)
        rowH = if reqStretch req then max h natural else natural

-- | Stack blocks. Each takes as much of the column's width as it can use
-- (all of it if it grows without a limit), and the position aligns them
-- horizontally ('left', 'center', 'right').
joinVertical :: Position -> [Block] -> Block
joinVertical p bs = Block $ \ctx ->
  let ns = map (measureIn ctx) bs
      rs = map blockRequest ns
   in columnNode p ns rs

columnNode :: Position -> [Measured] -> [Request] -> Measured
columnNode p ns rs = Measured req run
  where
    req =
      Request
        { reqMin = maximum (0 : map reqMin rs)
        , reqMax = maximum (0 : map reqMax rs)
        , reqGrow = maximum (0 : map reqGrow rs)
        , reqLimit = maxLimit rs
        , reqStretch = False
        , reqFill = False
        }
    run (Assign w _) = (joinGridsV p w (map fst results), sum (map snd results))
      where
        results = [blockLayout n (Assign (takenWidth r w) 0) | (n, r) <- zip ns rs]

-- | Side by side, aligned to the top.
hcat :: [Block] -> Block
hcat = joinHorizontal top

-- | Stacked, aligned to the left.
vcat :: [Block] -> Block
vcat = joinVertical left

-- | Add attributes to ranges of display columns @[start, end)@, counted
-- from the start of the text and continuing across lines (a newline takes
-- no columns); a cluster is styled when its first column is in a range.
-- A tab counts as four columns, the default 'Lipstick.Style.tabWidth':
-- where the text ends up, and so its tab width, is not known yet. The
-- range attributes go on top of the text's own.
--
-- >>> toAnsi defaultRenderEnv (fromInline (styleRanges [(0, 3, bold <> fg red)] "foobar"))
-- "\ESC[0;1;31mfoo\ESC[0mbar"
styleRanges :: [(Int, Int, Mod Inline)] -> Inline -> Inline
styleRanges ranges = restyle $ \col _ ->
  mconcat [propAttrs (propsOf m) | (s, e, m) <- ranges, col >= s, col < e]

-- | Add attributes to the characters (grapheme clusters, not counting
-- newlines) at the given indices, and other attributes to the rest. Handy
-- for highlighting fuzzy-search matches.
--
-- >>> toAnsi defaultRenderEnv (fromInline (styleIndices [0, 3] underline mempty "foobar"))
-- "\ESC[0;4mf\ESC[0moo\ESC[0;4mb\ESC[0mar"
styleIndices :: [Int] -> Mod Inline -> Mod Inline -> Inline -> Inline
styleIndices indices matched unmatched = restyle $ \_ i ->
  if IntSet.member i chosen then on else off
  where
    chosen = IntSet.fromList indices
    on = propAttrs (propsOf matched)
    off = propAttrs (propsOf unmatched)

-- | Layer extra attributes over each cluster, given its starting column and
-- its index.
restyle :: (Int -> Int -> Attrs) -> Inline -> Inline
restyle extra (Inline segs) = Inline (merge (go 0 0 (styledClusters segs)))
  where
    go _ _ [] = []
    go col i ((a, c, cw) : rest)
      | T.any (== '\n') c = (a, c) : go col i rest
      | c == T.singleton '\t' = (a <> extra col i, c) : go (col + textTabWidth defTextStyle) (i + 1) rest
      | otherwise = (a <> extra col i, c) : go (col + cw) (i + 1) rest
    -- Runs of clusters with the same attributes, each joined once.
    merge ((a, t) : rest) =
      let (same, rest') = span ((== a) . fst) rest
       in (a, T.concat (t : map snd same)) : merge rest'
    merge [] = []