{- | Query the terminal's foreground color so rasterized notation can be drawn
in the user's theme color instead of a hardcoded one.

A terminal graphics image is raw pixels and cannot inherit terminal color
attributes the way text cells do. To make the notation "use the terminal's text
color" we ask the terminal for its foreground RGB via the @OSC 10@ query
(@ESC ] 10 ; ? BEL@) and paint the ink with the reply. If the terminal does not
answer (or stdin/stdout is not a TTY), we fall back to a neutral light ink.
-}
module Termtab.Graphics.TermColor (
    queryForegroundColor,
    foregroundOrDefault,
    defaultInk,
    parseOSCColor,
) where

import Codec.Picture (PixelRGBA8 (..))
import Control.Exception (SomeException, bracket, try)
import Data.Char (digitToInt, isHexDigit)
import Data.List (isPrefixOf)
import Data.Word (Word8)
import System.IO
import System.Timeout (timeout)

{- | Ink used when the terminal foreground can't be determined: opaque light
gray, legible on a dark background.
-}
defaultInk :: PixelRGBA8
defaultInk :: PixelRGBA8
defaultInk = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
0xD0 Word8
0xD0 Word8
0xD0 Word8
0xFF

-- | The terminal foreground as opaque ink, or 'defaultInk' if unavailable.
foregroundOrDefault :: IO PixelRGBA8
foregroundOrDefault :: IO PixelRGBA8
foregroundOrDefault = do
    m <- IO (Maybe (Word8, Word8, Word8))
queryForegroundColor
    pure $ case m of
        Just (Word8
r, Word8
g, Word8
b) -> Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
0xFF
        Maybe (Word8, Word8, Word8)
Nothing -> PixelRGBA8
defaultInk

{- | Query the terminal foreground color via OSC 10. Returns 'Nothing' if
stdin/stdout is not a terminal or no reply arrives in time.
-}
queryForegroundColor :: IO (Maybe (Word8, Word8, Word8))
queryForegroundColor :: IO (Maybe (Word8, Word8, Word8))
queryForegroundColor = do
    inTty <- Handle -> IO Bool
hIsTerminalDevice Handle
stdin
    outTty <- hIsTerminalDevice stdout
    if not (inTty && outTty)
        then pure Nothing
        else do
            result <-
                try (withRawStdin queryOnce) ::
                    IO (Either SomeException (Maybe (Word8, Word8, Word8)))
            pure (either (const Nothing) id result)

-- | Temporarily disable echo and line buffering on stdin, restoring after.
withRawStdin :: IO a -> IO a
withRawStdin :: forall a. IO a -> IO a
withRawStdin IO a
act = IO (Bool, BufferMode)
-> ((Bool, BufferMode) -> IO ())
-> ((Bool, BufferMode) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Bool, BufferMode)
save (Bool, BufferMode) -> IO ()
restore (IO a -> (Bool, BufferMode) -> IO a
forall a b. a -> b -> a
const IO a
act)
  where
    save :: IO (Bool, BufferMode)
save = do
        echo <- Handle -> IO Bool
hGetEcho Handle
stdin
        buf <- hGetBuffering stdin
        hSetEcho stdin False
        hSetBuffering stdin NoBuffering
        pure (echo, buf)
    restore :: (Bool, BufferMode) -> IO ()
restore (Bool
echo, BufferMode
buf) = do
        Handle -> Bool -> IO ()
hSetEcho Handle
stdin Bool
echo
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
buf

queryOnce :: IO (Maybe (Word8, Word8, Word8))
queryOnce :: IO (Maybe (Word8, Word8, Word8))
queryOnce = do
    Handle -> [Char] -> IO ()
hPutStr Handle
stdout [Char]
"\ESC]10;?\a"
    Handle -> IO ()
hFlush Handle
stdout
    [Char] -> Maybe (Word8, Word8, Word8)
parseOSCColor ([Char] -> Maybe (Word8, Word8, Word8))
-> IO [Char] -> IO (Maybe (Word8, Word8, Word8))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
readResponse

-- | Read the OSC reply until BEL, a short per-char timeout, or a length cap.
readResponse :: IO String
readResponse :: IO [Char]
readResponse = [Char] -> Int -> IO [Char]
forall {t}. (Ord t, Num t) => [Char] -> t -> IO [Char]
go [] (Int
0 :: Int)
  where
    go :: [Char] -> t -> IO [Char]
go [Char]
acc t
n
        | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
64 = [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
acc)
        | Bool
otherwise = do
            mc <- Int -> IO Char -> IO (Maybe Char)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
150000 (Handle -> IO Char
hGetChar Handle
stdin)
            case mc of
                Maybe Char
Nothing -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
acc)
                Just Char
'\a' -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
acc)
                Just Char
c -> [Char] -> t -> IO [Char]
go (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
acc) (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

{- | Parse an OSC 10 color reply, e.g. @ESC]10;rgb:eaea/ebeb/f0f0 BEL@, into an
8-bit RGB triple. Each hex group may be 1-4 digits and is scaled to 0-255.
-}
parseOSCColor :: String -> Maybe (Word8, Word8, Word8)
parseOSCColor :: [Char] -> Maybe (Word8, Word8, Word8)
parseOSCColor [Char]
s = do
    body <- [Char] -> Maybe [Char]
afterRgb [Char]
s
    let (g1, r1) = span isHexDigit body
    r1' <- stripSlash r1
    let (g2, r2) = span isHexDigit r1'
    r2' <- stripSlash r2
    let g3 = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHexDigit [Char]
r2'
    if not (null g1) && not (null g2) && not (null g3)
        then Just (scaleHex g1, scaleHex g2, scaleHex g3)
        else Nothing
  where
    stripSlash :: [Char] -> Maybe [Char]
stripSlash (Char
'/' : [Char]
t) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
t
    stripSlash [Char]
_ = Maybe [Char]
forall a. Maybe a
Nothing

{- | Skip to just past an @rgb:@ marker anywhere in the string, used by
'parseOSCColor' to tolerate whatever escape-sequence prefix precedes it.
-}
afterRgb :: String -> Maybe String
afterRgb :: [Char] -> Maybe [Char]
afterRgb [Char]
xs
    | [Char]
"rgb:" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
xs = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
4 [Char]
xs)
afterRgb (Char
_ : [Char]
rest) = [Char] -> Maybe [Char]
afterRgb [Char]
rest
afterRgb [] = Maybe [Char]
forall a. Maybe a
Nothing

-- | Parse a hex group and scale it from its own bit width down to 8 bits.
scaleHex :: String -> Word8
scaleHex :: [Char] -> Word8
scaleHex [Char]
hex =
    let v :: Int
v = (Int -> Char -> Int) -> Int -> [Char] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
a Char
c -> Int
a 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
c) Int
0 [Char]
hex
        maxv :: Int
maxv = Int
16 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
hex Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
     in Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
255 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxv)