Common.hs

module YMonad.Core.Common (
  WorkspaceId (..),
  ScreenId (..),
  ViewId (..),
  OutputId (..),
  Point (..),
  Size (..),
  Rect (..),
  Dimension (..),
  RgbaColor (..),
  TitleBarMode (..),
  opaqueRgb8,
  parseColorString,
) where

import Data.Char qualified as Char
import Data.List qualified as List
import Data.Map.Strict qualified as M
import Data.Text qualified as T
import Numeric (readHex)

newtype WorkspaceId = WorkspaceId {unWorkspaceId :: Text}
  deriving stock (Eq, Ord, Show, Read)

newtype ScreenId = ScreenId {unScreenId :: Int}
  deriving stock (Eq, Ord, Show, Read)

newtype ViewId = ViewId {unViewId :: Int}
  deriving stock (Eq, Ord, Show, Read)

newtype OutputId = OutputId {unOutputId :: Int}
  deriving stock (Eq, Ord, Show, Read)

newtype Dimension = Dimension {unDimension :: Int}
  deriving stock (Eq, Ord, Show, Read)
  deriving newtype (Num)

data Point = Point
  { pointX :: Int
  , pointY :: Int
  }
  deriving stock (Eq, Ord, Show, Read)

data Size = Size
  { sizeWidth :: Int
  , sizeHeight :: Int
  }
  deriving stock (Eq, Ord, Show, Read)

data Rect = Rect
  { rectX :: Int
  , rectY :: Int
  , rectWidth :: Int
  , rectHeight :: Int
  }
  deriving stock (Eq, Ord, Show, Read)

data RgbaColor = RgbaColor
  { rgbaRed :: Word32
  , rgbaGreen :: Word32
  , rgbaBlue :: Word32
  , rgbaAlpha :: Word32
  }
  deriving stock (Eq, Ord, Show, Read)

data TitleBarMode
  = NoTitleBar
  | ServerSideTitleBar
  deriving stock (Eq, Ord, Show, Read)

opaqueRgb8 :: Word8 -> Word8 -> Word8 -> RgbaColor
opaqueRgb8 red green blue = rgbaFrom8Bit red green blue 255

parseColorString :: String -> Maybe RgbaColor
parseColorString raw =
  case List.stripPrefix "#" text of
    Just digits -> parseHexColor digits
    Nothing -> namedColor text
  where
    text = map Char.toLower raw

namedColor :: String -> Maybe RgbaColor
namedColor name = do
  (red, green, blue) <- M.lookup (T.pack name) namedPalette
  pure (opaqueRgb8 red green blue)

namedPalette :: Map Text (Word8, Word8, Word8)
namedPalette =
  M.fromList
    [ ("black", (0, 0, 0))
    , ("white", (255, 255, 255))
    , ("red", (255, 0, 0))
    , ("green", (0, 255, 0))
    , ("blue", (0, 0, 255))
    , ("gray", (128, 128, 128))
    , ("grey", (128, 128, 128))
    , ("yellow", (255, 255, 0))
    , ("magenta", (255, 0, 255))
    , ("cyan", (0, 255, 255))
    ]

parseHexColor :: String -> Maybe RgbaColor
parseHexColor digits =
  case digits of
    [r, g, b] -> rgbaFrom8Bit <$> dupHex r <*> dupHex g <*> dupHex b <*> pure 255
    [r, g, b, a] -> rgbaFrom8Bit <$> dupHex r <*> dupHex g <*> dupHex b <*> dupHex a
    [r1, r2, g1, g2, b1, b2] -> rgbaFrom8Bit <$> byte [r1, r2] <*> byte [g1, g2] <*> byte [b1, b2] <*> pure 255
    [r1, r2, g1, g2, b1, b2, a1, a2] -> rgbaFrom8Bit <$> byte [r1, r2] <*> byte [g1, g2] <*> byte [b1, b2] <*> byte [a1, a2]
    _other -> Nothing
  where
    dupHex ch = byte [ch, ch]
    byte chars = case readHex chars of
      [(value, "")] -> Just (fromIntegral (value :: Int))
      _ -> Nothing

rgbaFrom8Bit :: Word8 -> Word8 -> Word8 -> Word8 -> RgbaColor
rgbaFrom8Bit red green blue alpha =
  RgbaColor
    { rgbaRed = expand8Bit (premultiply red alpha)
    , rgbaGreen = expand8Bit (premultiply green alpha)
    , rgbaBlue = expand8Bit (premultiply blue alpha)
    , rgbaAlpha = expand8Bit alpha
    }

expand8Bit :: Word8 -> Word32
expand8Bit value = fromIntegral value * 0x01010101

premultiply :: Word8 -> Word8 -> Word8
premultiply channel alpha =
  fromIntegral (((fromIntegral channel :: Word32) * fromIntegral alpha + 127) `div` 255)