{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Strict #-}

{- |
Module      : Granite.Color
Copyright   : (c) 2025
License     : MIT
Maintainer  : mschavinda@gmail.com

Color primitives shared by the terminal and SVG backends.

'Color' is a 24-bit RGB value. The classic ANSI palette names ('Black',
'BrightBlue', 'Default', …) are provided as bidirectional pattern synonyms
that expand to fixed RGB triples, so they may be used both as expressions
and in patterns exactly as before.

The two backends deliberately diverge on how a colour is realised:

  * the SVG backend renders the RGB exactly via 'colorHex';
  * the terminal backend approximates via 'ansiCode', which maps an
    arbitrary colour to the nearest of the 16 ANSI slots.

Because 'Color' is now a plain RGB triple, its /derived/ 'Show' prints
@Color r g b@ rather than the alias name.
-}
module Granite.Color (
    Color (
        ..,
        Black,
        Red,
        Green,
        Yellow,
        Blue,
        Magenta,
        Cyan,
        White,
        BrightBlack,
        BrightRed,
        BrightGreen,
        BrightYellow,
        BrightBlue,
        BrightMagenta,
        BrightCyan,
        BrightWhite,
        Default
    ),
    parseHex,
    ansiCode,
    ansiOn,
    ansiOff,
    paint,
    colorHex,
    paletteColors,
    pieColors,
) where

import Data.Char (digitToInt, isHexDigit)
import Data.List (minimumBy)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Word (Word8)
import Numeric (showHex)

-- | A 24-bit RGB colour.
data Color = Color !Word8 !Word8 !Word8
    deriving (Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
/= :: Color -> Color -> Bool
Eq, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Color -> ShowS
showsPrec :: Int -> Color -> ShowS
$cshow :: Color -> String
show :: Color -> String
$cshowList :: [Color] -> ShowS
showList :: [Color] -> ShowS
Show, ReadPrec [Color]
ReadPrec Color
Int -> ReadS Color
ReadS [Color]
(Int -> ReadS Color)
-> ReadS [Color]
-> ReadPrec Color
-> ReadPrec [Color]
-> Read Color
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Color
readsPrec :: Int -> ReadS Color
$creadList :: ReadS [Color]
readList :: ReadS [Color]
$creadPrec :: ReadPrec Color
readPrec :: ReadPrec Color
$creadListPrec :: ReadPrec [Color]
readListPrec :: ReadPrec [Color]
Read)

-- The classic ANSI palette, as bidirectional pattern-synonym aliases over
-- fixed RGB triples (the historical 'colorHex' values).

pattern Black :: Color
pattern $mBlack :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBlack :: Color
Black = Color 0x2c 0x3e 0x50

pattern Red :: Color
pattern $mRed :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bRed :: Color
Red = Color 0xc0 0x39 0x2b

pattern Green :: Color
pattern $mGreen :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bGreen :: Color
Green = Color 0x27 0xae 0x60

pattern Yellow :: Color
pattern $mYellow :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bYellow :: Color
Yellow = Color 0xf3 0x9c 0x12

pattern Blue :: Color
pattern $mBlue :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBlue :: Color
Blue = Color 0x29 0x80 0xb9

pattern Magenta :: Color
pattern $mMagenta :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bMagenta :: Color
Magenta = Color 0x8e 0x44 0xad

pattern Cyan :: Color
pattern $mCyan :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bCyan :: Color
Cyan = Color 0x16 0xa0 0x85

pattern White :: Color
pattern $mWhite :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bWhite :: Color
White = Color 0xec 0xf0 0xf1

pattern BrightBlack :: Color
pattern $mBrightBlack :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightBlack :: Color
BrightBlack = Color 0x7f 0x8c 0x8d

pattern BrightRed :: Color
pattern $mBrightRed :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightRed :: Color
BrightRed = Color 0xe7 0x4c 0x3c

pattern BrightGreen :: Color
pattern $mBrightGreen :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightGreen :: Color
BrightGreen = Color 0x2e 0xcc 0x71

pattern BrightYellow :: Color
pattern $mBrightYellow :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightYellow :: Color
BrightYellow = Color 0xf1 0xc4 0x0f

pattern BrightBlue :: Color
pattern $mBrightBlue :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightBlue :: Color
BrightBlue = Color 0x34 0x98 0xdb

pattern BrightMagenta :: Color
pattern $mBrightMagenta :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightMagenta :: Color
BrightMagenta = Color 0x9b 0x59 0xb6

pattern BrightCyan :: Color
pattern $mBrightCyan :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightCyan :: Color
BrightCyan = Color 0x1a 0xbc 0x9c

pattern BrightWhite :: Color
pattern $mBrightWhite :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bBrightWhite :: Color
BrightWhite = Color 0xbd 0xc3 0xc7

pattern Default :: Color
pattern $mDefault :: forall {r}. Color -> ((# #) -> r) -> ((# #) -> r) -> r
$bDefault :: Color
Default = Color 0x55 0x55 0x55

{- | ANSI escape code for a colour. The 16 named slots (plus 'Default') return
their canonical code; any other colour maps to the nearest ANSI slot.
-}
ansiCode :: Color -> Int
ansiCode :: Color -> Int
ansiCode Color
Black = Int
30
ansiCode Color
Red = Int
31
ansiCode Color
Green = Int
32
ansiCode Color
Yellow = Int
33
ansiCode Color
Blue = Int
34
ansiCode Color
Magenta = Int
35
ansiCode Color
Cyan = Int
36
ansiCode Color
White = Int
37
ansiCode Color
BrightBlack = Int
90
ansiCode Color
BrightRed = Int
91
ansiCode Color
BrightGreen = Int
92
ansiCode Color
BrightYellow = Int
93
ansiCode Color
BrightBlue = Int
94
ansiCode Color
BrightMagenta = Int
95
ansiCode Color
BrightCyan = Int
96
ansiCode Color
BrightWhite = Int
97
ansiCode Color
Default = Int
39
ansiCode (Color Word8
r Word8
g Word8
b) = Word8 -> Word8 -> Word8 -> Int
nearestAnsiCode Word8
r Word8
g Word8
b

{- | Map an arbitrary RGB colour to the nearest of the 16 ANSI slots, using the
canonical (VGA) ANSI palette as anchors — kept consistent with the terminal
chrome quantisation in "Granite.Render.Chrome".
-}
nearestAnsiCode :: Word8 -> Word8 -> Word8 -> Int
nearestAnsiCode :: Word8 -> Word8 -> Word8 -> Int
nearestAnsiCode Word8
r Word8
g Word8
b =
    (Int, Int) -> Int
forall a b. (a, b) -> b
snd
        (((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> a
fst) [((Int, Int, Int) -> Int
dist (Int, Int, Int)
anchor, Int
code) | ((Int, Int, Int)
anchor, Int
code) <- [((Int, Int, Int), Int)]
ansiAnchors])
  where
    ri :: Int
ri = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r :: Int
    gi :: Int
gi = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g
    bi :: Int
bi = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
    dist :: (Int, Int, Int) -> Int
dist (Int
ar, Int
ag, Int
ab) = Int -> Int
forall {a}. Num a => a -> a
sq (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ri) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall {a}. Num a => a -> a
sq (Int
ag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
gi) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall {a}. Num a => a -> a
sq (Int
ab Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bi)
    sq :: a -> a
sq a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x

ansiAnchors :: [((Int, Int, Int), Int)]
ansiAnchors :: [((Int, Int, Int), Int)]
ansiAnchors =
    [ ((Int
0, Int
0, Int
0), Int
30)
    , ((Int
170, Int
0, Int
0), Int
31)
    , ((Int
0, Int
170, Int
0), Int
32)
    , ((Int
170, Int
85, Int
0), Int
33)
    , ((Int
0, Int
0, Int
170), Int
34)
    , ((Int
170, Int
0, Int
170), Int
35)
    , ((Int
0, Int
170, Int
170), Int
36)
    , ((Int
170, Int
170, Int
170), Int
37)
    , ((Int
85, Int
85, Int
85), Int
90)
    , ((Int
255, Int
85, Int
85), Int
91)
    , ((Int
85, Int
255, Int
85), Int
92)
    , ((Int
255, Int
255, Int
85), Int
93)
    , ((Int
85, Int
85, Int
255), Int
94)
    , ((Int
255, Int
85, Int
255), Int
95)
    , ((Int
85, Int
255, Int
255), Int
96)
    , ((Int
255, Int
255, Int
255), Int
97)
    ]

-- | Opening ANSI escape sequence selecting a colour (its nearest ANSI slot).
ansiOn :: Color -> Text
ansiOn :: Color -> Text
ansiOn Color
c = Text
"\ESC[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Color -> Int
ansiCode Color
c)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m"

-- | ANSI reset escape sequence.
ansiOff :: Text
ansiOff :: Text
ansiOff = Text
"\ESC[0m"

-- | Wrap a character in ANSI on/off sequences. Spaces pass through unchanged.
paint :: Color -> Char -> Text
paint :: Color -> Char -> Text
paint Color
c Char
ch = if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Text
" " else Color -> Text
ansiOn Color
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
ch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ansiOff

-- | Exact @#rrggbb@ rendering of a colour, used by the SVG backend.
colorHex :: Color -> Text
colorHex :: Color -> Text
colorHex (Color Word8
r Word8
g Word8
b) = Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
hex2 Word8
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
hex2 Word8
g Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word8 -> Text
hex2 Word8
b
  where
    hex2 :: Word8 -> Text
    hex2 :: Word8 -> Text
hex2 Word8
w =
        let s :: String
s = Word8 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word8
w String
""
         in String -> Text
Text.pack (if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Char
'0' Char -> ShowS
forall a. a -> [a] -> [a]
: String
s else String
s)

{- | Parse a @"#rrggbb"@ (or @"rrggbb"@) string into a 'Color'. Returns
'Nothing' on malformed input.
-}
parseHex :: Text -> Maybe Color
parseHex :: Text -> Maybe Color
parseHex Text
t =
    case Text -> String
Text.unpack ((Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') Text
t) of
        cs :: String
cs@[Char
r1, Char
r2, Char
g1, Char
g2, Char
b1, Char
b2]
            | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit String
cs ->
                Color -> Maybe Color
forall a. a -> Maybe a
Just (Word8 -> Word8 -> Word8 -> Color
Color (Char -> Char -> Word8
forall {b}. Num b => Char -> Char -> b
byte Char
r1 Char
r2) (Char -> Char -> Word8
forall {b}. Num b => Char -> Char -> b
byte Char
g1 Char
g2) (Char -> Char -> Word8
forall {b}. Num b => Char -> Char -> b
byte Char
b1 Char
b2))
        String
_ -> Maybe Color
forall a. Maybe a
Nothing
  where
    byte :: Char -> Char -> b
byte Char
hi Char
lo = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
lo)

-- | Default palette for layered charts (scatter, line, bars, …).
paletteColors :: [Color]
paletteColors :: [Color]
paletteColors =
    [ Color
BrightBlue
    , Color
BrightMagenta
    , Color
BrightCyan
    , Color
BrightGreen
    , Color
BrightYellow
    , Color
BrightRed
    , Color
BrightWhite
    , Color
BrightBlack
    ]

-- | Palette used by pie / box plots (categorical, more saturated).
pieColors :: [Color]
pieColors :: [Color]
pieColors =
    [ Color
BrightRed
    , Color
BrightGreen
    , Color
BrightYellow
    , Color
BrightBlue
    , Color
BrightMagenta
    , Color
BrightCyan
    , Color
BrightWhite
    , Color
BrightBlack
    ]