{- | Runtime detection of which terminal graphics protocol to use for
notation rendering.

No single protocol covers all target terminals: Kitty implements only its own
graphics protocol (no Sixel), while iTerm2 supports Sixel but not the Kitty
protocol. WezTerm and Ghostty support the Kitty protocol; iTerm2, foot, and
xterm support Sixel. We therefore pick a backend at runtime and share the same
rendered image buffer between them.

Detection is env-based (cheap, side-effect-free beyond reading the
environment). A terminal Device Attributes (DA) probe for Sixel is a future
refinement; for now an explicit @TERMTAB_GRAPHICS@ override covers the cases
env heuristics miss.
-}
module Termtab.Graphics.Detect (
    GraphicsProtocol (..),
    detectProtocol,
    classifyProtocol,
    classifyProtocolReason,
    DetectionInfo (..),
    detectProtocolInfo,
) where

import Data.Char (toLower)
import Data.List (isInfixOf)
import System.Environment (lookupEnv)

{- | Which terminal graphics protocol (if any) to render notation images
through, chosen once at startup by 'detectProtocol' and stored in
'Termtab.UI.Types.asProtocol'.
-}
data GraphicsProtocol
    = -- | Kitty graphics protocol (Kitty, WezTerm, Ghostty)
      Kitty
    | -- | Sixel (iTerm2, WezTerm, foot, xterm, mlterm, contour)
      Sixel
    | -- | No graphics support: fall back to the Unicode text staff
      TextOnly
    deriving (Int -> GraphicsProtocol -> ShowS
[GraphicsProtocol] -> ShowS
GraphicsProtocol -> [Char]
(Int -> GraphicsProtocol -> ShowS)
-> (GraphicsProtocol -> [Char])
-> ([GraphicsProtocol] -> ShowS)
-> Show GraphicsProtocol
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GraphicsProtocol -> ShowS
showsPrec :: Int -> GraphicsProtocol -> ShowS
$cshow :: GraphicsProtocol -> [Char]
show :: GraphicsProtocol -> [Char]
$cshowList :: [GraphicsProtocol] -> ShowS
showList :: [GraphicsProtocol] -> ShowS
Show, GraphicsProtocol -> GraphicsProtocol -> Bool
(GraphicsProtocol -> GraphicsProtocol -> Bool)
-> (GraphicsProtocol -> GraphicsProtocol -> Bool)
-> Eq GraphicsProtocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GraphicsProtocol -> GraphicsProtocol -> Bool
== :: GraphicsProtocol -> GraphicsProtocol -> Bool
$c/= :: GraphicsProtocol -> GraphicsProtocol -> Bool
/= :: GraphicsProtocol -> GraphicsProtocol -> Bool
Eq)

{- | Detect the graphics protocol from the environment.

Precedence:

1. @TERMTAB_GRAPHICS@ override (@kitty@ | @sixel@ | @text@)
2. Kitty-protocol terminals (@KITTY_WINDOW_ID@, @TERM=*kitty*@, WezTerm, Ghostty)
3. Sixel terminals (iTerm2, @TERM=*sixel*@)
4. 'TextOnly'
-}
detectProtocol :: IO GraphicsProtocol
detectProtocol :: IO GraphicsProtocol
detectProtocol = do
    override <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TERMTAB_GRAPHICS"
    term <- lookupEnv "TERM"
    termProgram <- lookupEnv "TERM_PROGRAM"
    kittyId <- lookupEnv "KITTY_WINDOW_ID"
    pure (classifyProtocol override term termProgram kittyId)

{- | Pure classification core (unit-testable).

Arguments, in order: @TERMTAB_GRAPHICS@, @TERM@, @TERM_PROGRAM@,
@KITTY_WINDOW_ID@.
-}
classifyProtocol ::
    Maybe String -> Maybe String -> Maybe String -> Maybe String -> GraphicsProtocol
classifyProtocol :: Maybe [Char]
-> Maybe [Char] -> Maybe [Char] -> Maybe [Char] -> GraphicsProtocol
classifyProtocol Maybe [Char]
override Maybe [Char]
term Maybe [Char]
termProgram Maybe [Char]
kittyId =
    (GraphicsProtocol, [Char]) -> GraphicsProtocol
forall a b. (a, b) -> a
fst (Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> (GraphicsProtocol, [Char])
classifyProtocolReason Maybe [Char]
override Maybe [Char]
term Maybe [Char]
termProgram Maybe [Char]
kittyId)

{- | Like 'classifyProtocol' but also returns a human-readable explanation of
which signal drove the decision (used by @--health@).
-}
classifyProtocolReason ::
    Maybe String ->
    Maybe String ->
    Maybe String ->
    Maybe String ->
    (GraphicsProtocol, String)
classifyProtocolReason :: Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> Maybe [Char]
-> (GraphicsProtocol, [Char])
classifyProtocolReason Maybe [Char]
override Maybe [Char]
term Maybe [Char]
termProgram Maybe [Char]
kittyId =
    case ShowS -> Maybe [Char] -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) Maybe [Char]
override of
        Just [Char]
"kitty" -> (GraphicsProtocol
Kitty, [Char]
"TERMTAB_GRAPHICS override set to \"kitty\"")
        Just [Char]
"sixel" -> (GraphicsProtocol
Sixel, [Char]
"TERMTAB_GRAPHICS override set to \"sixel\"")
        Just [Char]
"text" -> (GraphicsProtocol
TextOnly, [Char]
"TERMTAB_GRAPHICS override set to \"text\"")
        Maybe [Char]
_
            | Just [Char]
_ <- Maybe [Char]
kittyId ->
                (GraphicsProtocol
Kitty, [Char]
"KITTY_WINDOW_ID is set (Kitty graphics protocol)")
            | [Char]
"kitty" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
term' ->
                (GraphicsProtocol
Kitty, [Char]
"TERM contains \"kitty\"")
            | [Char]
"ghostty" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
term' ->
                (GraphicsProtocol
Kitty, [Char]
"TERM contains \"ghostty\"")
            | [Char]
"wezterm" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
prog' ->
                (GraphicsProtocol
Kitty, [Char]
"TERM_PROGRAM is WezTerm (supports the Kitty graphics protocol)")
            | [Char]
"ghostty" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
prog' ->
                (GraphicsProtocol
Kitty, [Char]
"TERM_PROGRAM is Ghostty")
            | [Char]
"iterm" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
prog' ->
                (GraphicsProtocol
Sixel, [Char]
"TERM_PROGRAM is iTerm (supports Sixel)")
            | [Char]
"sixel" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
term' ->
                (GraphicsProtocol
Sixel, [Char]
"TERM advertises Sixel")
            | [Char]
"mlterm" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
term' ->
                (GraphicsProtocol
Sixel, [Char]
"TERM is mlterm (supports Sixel)")
            | [Char]
"foot" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
term' ->
                (GraphicsProtocol
Sixel, [Char]
"TERM is foot (supports Sixel)")
            | Bool
otherwise ->
                (GraphicsProtocol
TextOnly, [Char]
"no graphics-capable terminal detected; using the Unicode text staff")
  where
    term' :: [Char]
term' = [Char] -> ShowS -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) Maybe [Char]
term
    prog' :: [Char]
prog' = [Char] -> ShowS -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) Maybe [Char]
termProgram

{- | The full result of graphics detection, including the raw environment
signals that were consulted. Rendered by @--health@.
-}
data DetectionInfo = DetectionInfo
    { DetectionInfo -> GraphicsProtocol
diProtocol :: GraphicsProtocol
    , DetectionInfo -> [Char]
diReason :: String
    , DetectionInfo -> Maybe [Char]
diOverride :: Maybe String
    -- ^ @TERMTAB_GRAPHICS@
    , DetectionInfo -> Maybe [Char]
diTerm :: Maybe String
    -- ^ @TERM@
    , DetectionInfo -> Maybe [Char]
diTermProgram :: Maybe String
    -- ^ @TERM_PROGRAM@
    , DetectionInfo -> Maybe [Char]
diKittyWindowId :: Maybe String
    -- ^ @KITTY_WINDOW_ID@
    }
    deriving (Int -> DetectionInfo -> ShowS
[DetectionInfo] -> ShowS
DetectionInfo -> [Char]
(Int -> DetectionInfo -> ShowS)
-> (DetectionInfo -> [Char])
-> ([DetectionInfo] -> ShowS)
-> Show DetectionInfo
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DetectionInfo -> ShowS
showsPrec :: Int -> DetectionInfo -> ShowS
$cshow :: DetectionInfo -> [Char]
show :: DetectionInfo -> [Char]
$cshowList :: [DetectionInfo] -> ShowS
showList :: [DetectionInfo] -> ShowS
Show, DetectionInfo -> DetectionInfo -> Bool
(DetectionInfo -> DetectionInfo -> Bool)
-> (DetectionInfo -> DetectionInfo -> Bool) -> Eq DetectionInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DetectionInfo -> DetectionInfo -> Bool
== :: DetectionInfo -> DetectionInfo -> Bool
$c/= :: DetectionInfo -> DetectionInfo -> Bool
/= :: DetectionInfo -> DetectionInfo -> Bool
Eq)

-- | Detect the protocol and capture the environment signals behind the decision.
detectProtocolInfo :: IO DetectionInfo
detectProtocolInfo :: IO DetectionInfo
detectProtocolInfo = do
    override <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TERMTAB_GRAPHICS"
    term <- lookupEnv "TERM"
    termProgram <- lookupEnv "TERM_PROGRAM"
    kittyId <- lookupEnv "KITTY_WINDOW_ID"
    let (proto, reason) = classifyProtocolReason override term termProgram kittyId
    pure
        DetectionInfo
            { diProtocol = proto
            , diReason = reason
            , diOverride = override
            , diTerm = term
            , diTermProgram = termProgram
            , diKittyWindowId = kittyId
            }