--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

module Patat.Images.WezTerm
    ( backend
    ) where


--------------------------------------------------------------------------------
import           Codec.Picture           (DynamicImage,
                                          Image (imageHeight, imageWidth),
                                          decodeImage, dynamicMap)
import           Control.Exception       (throwIO)
import           Control.Monad           (unless, when)
import qualified Data.Aeson              as A
import qualified Data.ByteString         as B
import qualified Data.ByteString.Base64  as B64
import qualified Data.Text.Lazy          as TL
import           Data.Text.Lazy.Encoding (encodeUtf8)
import           Patat.Cleanup           (Cleanup)
import qualified Patat.Images.Internal   as Internal
import           System.Directory        (findExecutable)
import           System.Environment      (lookupEnv)
import           System.Process          (readProcess)


--------------------------------------------------------------------------------
backend :: Internal.Backend
backend :: Backend
backend = (Config Config -> IO Handle) -> Backend
forall a. FromJSON a => (Config a -> IO Handle) -> Backend
Internal.Backend Config Config -> IO Handle
new


--------------------------------------------------------------------------------
data Config = Config deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq)
instance A.FromJSON Config where parseJSON :: Value -> Parser Config
parseJSON Value
_ = Config -> Parser Config
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
Config


--------------------------------------------------------------------------------
data Pane =
    Pane { Pane -> Size
paneSize     :: Size
         , Pane -> Bool
paneIsActive :: Bool
         } deriving (Int -> Pane -> ShowS
[Pane] -> ShowS
Pane -> String
(Int -> Pane -> ShowS)
-> (Pane -> String) -> ([Pane] -> ShowS) -> Show Pane
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pane -> ShowS
showsPrec :: Int -> Pane -> ShowS
$cshow :: Pane -> String
show :: Pane -> String
$cshowList :: [Pane] -> ShowS
showList :: [Pane] -> ShowS
Show)

instance A.FromJSON Pane where
    parseJSON :: Value -> Parser Pane
parseJSON = String -> (Object -> Parser Pane) -> Value -> Parser Pane
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Pane" ((Object -> Parser Pane) -> Value -> Parser Pane)
-> (Object -> Parser Pane) -> Value -> Parser Pane
forall a b. (a -> b) -> a -> b
$ \Object
o -> Size -> Bool -> Pane
Pane
        (Size -> Bool -> Pane) -> Parser Size -> Parser (Bool -> Pane)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Size
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"size"
        Parser (Bool -> Pane) -> Parser Bool -> Parser Pane
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"is_active"


--------------------------------------------------------------------------------
data Size =
    Size { Size -> Int
sizePixelWidth  :: Int
         , Size -> Int
sizePixelHeight :: Int
         } deriving (Int -> Size -> ShowS
[Size] -> ShowS
Size -> String
(Int -> Size -> ShowS)
-> (Size -> String) -> ([Size] -> ShowS) -> Show Size
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Size -> ShowS
showsPrec :: Int -> Size -> ShowS
$cshow :: Size -> String
show :: Size -> String
$cshowList :: [Size] -> ShowS
showList :: [Size] -> ShowS
Show)

instance A.FromJSON Size where
    parseJSON :: Value -> Parser Size
parseJSON = String -> (Object -> Parser Size) -> Value -> Parser Size
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Size" ((Object -> Parser Size) -> Value -> Parser Size)
-> (Object -> Parser Size) -> Value -> Parser Size
forall a b. (a -> b) -> a -> b
$ \Object
o -> Int -> Int -> Size
Size
        (Int -> Int -> Size) -> Parser Int -> Parser (Int -> Size)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"pixel_width"
        Parser (Int -> Size) -> Parser Int -> Parser Size
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"pixel_height"


--------------------------------------------------------------------------------
new :: Internal.Config Config -> IO Internal.Handle
new :: Config Config -> IO Handle
new Config Config
config = do
    Bool -> Cleanup -> Cleanup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config Config
config Config Config -> Config Config -> Bool
forall a. Eq a => a -> a -> Bool
== Config Config
forall a. Config a
Internal.Auto) (Cleanup -> Cleanup) -> Cleanup -> Cleanup
forall a b. (a -> b) -> a -> b
$ do
        termProgram <- String -> IO (Maybe String)
lookupEnv String
"TERM_PROGRAM"
        unless (termProgram == Just "WezTerm") $ throwIO $
            Internal.BackendNotSupported "TERM_PROGRAM not WezTerm"

    Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Internal.Handle {hDrawImage :: String -> IO Cleanup
Internal.hDrawImage = String -> IO Cleanup
drawImage}


--------------------------------------------------------------------------------
drawImage :: FilePath -> IO Cleanup
drawImage :: String -> IO Cleanup
drawImage String
path = do
    content <- String -> IO ByteString
B.readFile String
path

    wez <- wezExecutable
    resp <- fmap (encodeUtf8 . TL.pack) $ readProcess wez ["cli", "list", "--format", "json"] []
    let panes = (ByteString -> Maybe [Pane]
forall a. FromJSON a => ByteString -> Maybe a
A.decode ByteString
resp :: Maybe [Pane])

    Internal.withEscapeSequence $ do
        putStr "1337;File=inline=1;doNotMoveCursor=1;"
        case decodeImage content of
            Left String
_    -> () -> Cleanup
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Right DynamicImage
img -> String -> Cleanup
putStr (String -> Cleanup) -> String -> Cleanup
forall a b. (a -> b) -> a -> b
$ Double -> Double -> String
wezArString (DynamicImage -> Double
imageAspectRatio DynamicImage
img) (Maybe [Pane] -> Double
activePaneAspectRatio Maybe [Pane]
panes)
        putStr ":"
        B.putStr (B64.encode content)
    return mempty


--------------------------------------------------------------------------------
wezArString  :: Double -> Double -> String
wezArString :: Double -> Double -> String
wezArString Double
i Double
p | Double
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
p     = String
"width=auto;height=95%;"
                | Bool
otherwise = String
"width=100%;height=auto;"


--------------------------------------------------------------------------------
wezExecutable :: IO String
wezExecutable :: IO String
wezExecutable = do
    w <- String -> IO (Maybe String)
findExecutable String
"wezterm.exe"
    case w of
        Maybe String
Nothing -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"wezterm"
        Just String
x  -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x


--------------------------------------------------------------------------------
imageAspectRatio  :: DynamicImage -> Double
imageAspectRatio :: DynamicImage -> Double
imageAspectRatio DynamicImage
i = DynamicImage -> Double
imgW DynamicImage
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ DynamicImage -> Double
imgH DynamicImage
i
    where
        imgH :: DynamicImage -> Double
imgH = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (DynamicImage -> Int) -> DynamicImage -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap Image pixel -> Int
forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageHeight)
        imgW :: DynamicImage -> Double
imgW = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (DynamicImage -> Int) -> DynamicImage -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap Image pixel -> Int
forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageWidth)


--------------------------------------------------------------------------------
paneAspectRatio :: Pane -> Double
paneAspectRatio :: Pane -> Double
paneAspectRatio Pane
p = Pane -> Double
paneW Pane
p Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Pane -> Double
paneH Pane
p
    where
        paneH :: Pane -> Double
paneH = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Pane -> Int) -> Pane -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Int
sizePixelHeight (Size -> Int) -> (Pane -> Size) -> Pane -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pane -> Size
paneSize
        paneW :: Pane -> Double
paneW = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Pane -> Int) -> Pane -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Int
sizePixelWidth (Size -> Int) -> (Pane -> Size) -> Pane -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pane -> Size
paneSize


--------------------------------------------------------------------------------
activePaneAspectRatio :: Maybe [Pane] -> Double
activePaneAspectRatio :: Maybe [Pane] -> Double
activePaneAspectRatio Maybe [Pane]
Nothing = Double
defaultAr -- This should never happen
activePaneAspectRatio (Just [Pane]
x) =
    case (Pane -> Bool) -> [Pane] -> [Pane]
forall a. (a -> Bool) -> [a] -> [a]
filter Pane -> Bool
paneIsActive [Pane]
x of
        [Pane
p] -> Pane -> Double
paneAspectRatio Pane
p
        [Pane]
_   -> Double
defaultAr                  -- This shouldn't either


--------------------------------------------------------------------------------
defaultAr :: Double
defaultAr :: Double
defaultAr = (Double
4 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3 :: Double)             -- Good enough for a VT100