--------------------------------------------------------------------------------
{-# LANGUAGE TemplateHaskell #-}
module Patat.Images.Kitty
    ( backend
    ) where


--------------------------------------------------------------------------------
import           Control.Exception     (throwIO)
import           Control.Monad         (unless, void, when)
import qualified Data.Aeson            as A
import           Data.Functor          (($>))
import qualified Data.List             as L
import           Patat.Cleanup         (Cleanup)
import qualified Patat.Images.Internal as Internal
import           System.Environment    (lookupEnv)
import qualified System.IO             as IO
import qualified System.Process        as Process


--------------------------------------------------------------------------------
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


--------------------------------------------------------------------------------
new :: Internal.Config Config -> IO Internal.Handle
new :: Config Config -> IO Handle
new Config Config
config = do
    Bool -> IO () -> IO ()
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) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        term <- String -> IO (Maybe String)
lookupEnv String
"TERM"
        unless (maybe False ("kitty" `L.isInfixOf`) term) $ throwIO $
            Internal.BackendNotSupported "TERM does not indicate kitty"

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


--------------------------------------------------------------------------------
drawImage :: FilePath -> IO Cleanup
drawImage :: String -> IO (IO ())
drawImage String
path = [String] -> IO ()
icat [String
"--align=center", String
path] IO () -> IO () -> IO (IO ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [String] -> IO ()
icat [String
"--clear"]
  where
    icat :: [String] -> IO ()
icat [String]
args = do
        (Just inh, _, _, ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess (String -> [String] -> CreateProcess
Process.proc String
"kitty"
            (String
"+kitten" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"icat" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--transfer-mode=stream" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--stdin=no" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args))
            { Process.std_in = Process.CreatePipe
            }
        IO.hClose inh
        void $ Process.waitForProcess ph