Types.hs

-- | Text attributes and positions, hidden from other packages: the public
-- parts are re-exported by "Lipstick.Mod", "Lipstick.Block",
-- "Lipstick.Grid" and "Lipstick.Ansi".
module Lipstick.Internal.Types
  ( -- * Text attributes
    Attrs (..)
  , Underline (..)
  , Flag (..)
  , setFlag
  , getFlag
  , fillAttrs
  , escapeUri

    -- * Positions
  , Position (..)
  , position
  , left
  , center
  , right
  , top
  , bottom
  , splitExtra
  ) where

import Control.Applicative ((<|>))
import Data.ByteString qualified as BS
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Lipstick.Internal.Color (Color)
import Text.Printf (printf)

-- | Underline styles, for 'Lipstick.Mod.underlineStyle'. 'NoUnderline'
-- turns off an underline an enclosing style sets.
data Underline
  = NoUnderline
  | SingleUnderline
  | DoubleUnderline
  | CurlyUnderline
  | DottedUnderline
  | DashedUnderline
  deriving (Eq, Ord, Show, Enum, Bounded)

-- | Boolean text attributes.
data Flag = Bold | Faint | Italic | Blink | Reverse | Strikethrough
  deriving (Eq, Ord, Show, Enum, Bounded)

-- | Partial text attributes. 'Nothing' means "not set here": when attributes
-- are layered with '<>', set fields on the right win and unset ones let the
-- left show through.
data Attrs = Attrs
  { attrFg :: !(Maybe Color)
  , attrBg :: !(Maybe Color)
  , attrUnderlineColor :: !(Maybe Color)
  , attrBold :: !(Maybe Bool)
  , attrFaint :: !(Maybe Bool)
  , attrItalic :: !(Maybe Bool)
  , attrBlink :: !(Maybe Bool)
  , attrReverse :: !(Maybe Bool)
  , attrStrikethrough :: !(Maybe Bool)
  , attrUnderline :: !(Maybe Underline)
  , attrLink :: !(Maybe Text)
  }
  deriving (Eq, Show)

instance Semigroup Attrs where
  a <> b =
    Attrs
      { attrFg = attrFg b <|> attrFg a
      , attrBg = attrBg b <|> attrBg a
      , attrUnderlineColor = attrUnderlineColor b <|> attrUnderlineColor a
      , attrBold = attrBold b <|> attrBold a
      , attrFaint = attrFaint b <|> attrFaint a
      , attrItalic = attrItalic b <|> attrItalic a
      , attrBlink = attrBlink b <|> attrBlink a
      , attrReverse = attrReverse b <|> attrReverse a
      , attrStrikethrough = attrStrikethrough b <|> attrStrikethrough a
      , attrUnderline = attrUnderline b <|> attrUnderline a
      , attrLink = attrLink b <|> attrLink a
      }

instance Monoid Attrs where
  mempty = Attrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

setFlag :: Flag -> Maybe Bool -> Attrs -> Attrs
setFlag f v a = case f of
  Bold -> a {attrBold = v}
  Faint -> a {attrFaint = v}
  Italic -> a {attrItalic = v}
  Blink -> a {attrBlink = v}
  Reverse -> a {attrReverse = v}
  Strikethrough -> a {attrStrikethrough = v}

getFlag :: Flag -> Attrs -> Maybe Bool
getFlag f = case f of
  Bold -> attrBold
  Faint -> attrFaint
  Italic -> attrItalic
  Blink -> attrBlink
  Reverse -> attrReverse
  Strikethrough -> attrStrikethrough

-- | The attributes used for whitespace a style adds around content
-- (alignment, padding): only the background and reverse video carry over.
fillAttrs :: Attrs -> Attrs
fillAttrs a = mempty {attrBg = attrBg a, attrReverse = attrReverse a}

-- | A URI made safe for an OSC 8 hyperlink: every character other than
-- printable, non-space ASCII is percent-encoded as UTF-8, including the
-- controls that would end the escape sequence early. @%@ is kept, so
-- existing escapes survive and applying it twice changes nothing.
escapeUri :: Text -> Text
escapeUri = T.concatMap escape
  where
    escape c
      | c > ' ' && c < '\DEL' = T.singleton c
      | otherwise = T.pack (concatMap (printf "%%%02X") (BS.unpack (T.encodeUtf8 (T.singleton c))))

-- | A position along an axis: 0 is left/top, 1 is right/bottom.
newtype Position = Position Double
  deriving (Eq, Ord)

-- | Shown with 'position', since the constructor is hidden.
instance Show Position where
  showsPrec d (Position x) = showParen (d > 10) (showString "position " . showsPrec 11 x)

-- | A position, clamped to [0, 1].
position :: Double -> Position
position = Position . max 0 . min 1

-- | The left edge: position 0.
left :: Position
left = Position 0

-- | The middle, on either axis: position 0.5.
center :: Position
center = Position 0.5

-- | The right edge: position 1.
right :: Position
right = Position 1

-- | The top edge: position 0.
top :: Position
top = Position 0

-- | The bottom edge: position 1.
bottom :: Position
bottom = Position 1

-- | Split @extra@ columns (or rows) of space into the amounts before and
-- after content placed at a position, as @(before, after)@. @before@
-- rounds down, so at 'center' the odd column goes after.
splitExtra :: Position -> Int -> (Int, Int)
splitExtra (Position p) extra =
  let e = max 0 extra
      before = floor (fromIntegral e * max 0 (min 1 p))
   in (before, e - before)