module Graphics.Ueberzug
    ( Ueberzug ()
    , newUeberzug
    , draw
    , clear
    , Actions (..)
    , Scalers (..)
    , UbConf (..)
    , defaultUbConf
    ) where

import System.Process (createProcess, proc, CreateProcess (std_in, std_out), StdStream (CreatePipe))
import GHC.IO.Handle (hPutStr, Handle, hFlush)
import Control.Exception (tryJust, IOException)
import System.IO.Error (isFullError, isPermissionError)

-- | The main struct storing a handle to the ueberzug process
newtype Ueberzug = Ueberzug {Ueberzug -> Handle
process :: Handle}

-- | Create a new ueberzug process
newUeberzug :: IO Ueberzug
newUeberzug :: IO Ueberzug
newUeberzug = do
  (Just Handle
stdin_h, Maybe Handle
_, Maybe Handle
_, ProcessHandle
_) <-
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"ueberzug" [FilePath
"layer", FilePath
"--silent"])
      { std_in :: StdStream
std_in = StdStream
CreatePipe
      , std_out :: StdStream
std_out = StdStream
CreatePipe
      }
  Ueberzug -> IO Ueberzug
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ueberzug -> IO Ueberzug) -> Ueberzug -> IO Ueberzug
forall a b. (a -> b) -> a -> b
$ Ueberzug :: Handle -> Ueberzug
Ueberzug { process :: Handle
process = Handle
stdin_h }

-- | Draw an image using the @ub@ instance with config @config@
draw :: Ueberzug -> UbConf -> IO (Either String ())
draw :: Ueberzug -> UbConf -> IO (Either FilePath ())
draw Ueberzug
ub UbConf
config =
  case UbConf -> Either FilePath FilePath
toJson UbConf
config of
    Right FilePath
cmd -> Ueberzug -> FilePath -> IO (Either FilePath ())
run Ueberzug
ub FilePath
cmd
    Left  FilePath
xx  -> Either FilePath () -> IO (Either FilePath ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left FilePath
xx)

-- | Clear an image with identifier @identifier_@.
clear :: Ueberzug -> String -> IO (Either String ())
clear :: Ueberzug -> FilePath -> IO (Either FilePath ())
clear Ueberzug
ub FilePath
identifier_ = do
  case UbConf -> Either FilePath FilePath
toJson UbConf
config of
    Right FilePath
cmd -> Ueberzug -> FilePath -> IO (Either FilePath ())
run Ueberzug
ub FilePath
cmd
    Left  FilePath
xx  -> Either FilePath () -> IO (Either FilePath ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left FilePath
xx)
  where
    config :: UbConf
config = UbConf
defaultUbConf { action :: Actions
action = Actions
Remove, identifier :: FilePath
identifier = FilePath
identifier_ }

hExceptions :: IOException -> Maybe String
hExceptions :: IOException -> Maybe FilePath
hExceptions IOException
e =
  case IOException
e of
    IOException
ex | IOException -> Bool
isFullError IOException
ex       -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"Device is full"
    IOException
ex | IOException -> Bool
isPermissionError IOException
ex -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"Permission Error"
    IOException
_                         -> Maybe FilePath
forall a. Maybe a
Nothing

-- | Pipe the command @cmd@ to the process stored in @ub@
run :: Ueberzug -> String -> IO (Either String ())
run :: Ueberzug -> FilePath -> IO (Either FilePath ())
run Ueberzug
ub FilePath
cmd = do
  let stdin :: Handle
stdin = Ueberzug -> Handle
process Ueberzug
ub
  Either FilePath ()
a <- (IOException -> Maybe FilePath) -> IO () -> IO (Either FilePath ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust IOException -> Maybe FilePath
hExceptions (Handle -> FilePath -> IO ()
hPutStr Handle
stdin FilePath
cmd)
  case Either FilePath ()
a of
    Left FilePath
e -> Either FilePath () -> IO (Either FilePath ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath () -> IO (Either FilePath ()))
-> Either FilePath () -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left FilePath
e
    Either FilePath ()
_ -> do
      Either FilePath ()
b <- (IOException -> Maybe FilePath) -> IO () -> IO (Either FilePath ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust IOException -> Maybe FilePath
hExceptions (Handle -> IO ()
hFlush Handle
stdin)
      case Either FilePath ()
b of
        Left FilePath
e -> Either FilePath () -> IO (Either FilePath ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath () -> IO (Either FilePath ()))
-> Either FilePath () -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left FilePath
e
        Either FilePath ()
_ -> Either FilePath () -> IO (Either FilePath ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath () -> IO (Either FilePath ()))
-> Either FilePath () -> IO (Either FilePath ())
forall a b. (a -> b) -> a -> b
$ () -> Either FilePath ()
forall a b. b -> Either a b
Right ()

-- | The available actions on the ueberzug image
data Actions = Add | Remove

-- | The available scalers to scale the image
data Scalers = Crop
             | Distort
             | FitContain
             | Contain
             | ForcedCover
             | Cover

instance Show Scalers where
  show :: Scalers -> FilePath
show Scalers
Crop        = FilePath
"crop"
  show Scalers
Distort     = FilePath
"distort"
  show Scalers
FitContain  = FilePath
"fit_contain"
  show Scalers
Contain     = FilePath
"contain"
  show Scalers
ForcedCover = FilePath
"forced_cover"
  show Scalers
Cover       = FilePath
"cover"

-- | The ueberzug configuration record. Contains all the data needed to draw the image
data UbConf =
  UbConf
    { UbConf -> Actions
action             :: Actions
    , UbConf -> FilePath
identifier         :: String
    , UbConf -> Int
x                  :: Int
    , UbConf -> Int
y                  :: Int
    , UbConf -> FilePath
path               :: FilePath
    , UbConf -> Maybe Int
width              :: Maybe Int
    , UbConf -> Maybe Int
height             :: Maybe Int
    , UbConf -> Maybe Scalers
scaler             :: Maybe Scalers
    , UbConf -> Maybe Bool
should_draw        :: Maybe Bool
    , UbConf -> Maybe Bool
synchronously_draw :: Maybe Bool
    , UbConf -> Maybe Float
scaling_position_x :: Maybe Float
    , UbConf -> Maybe Float
scaling_position_y :: Maybe Float
    }

-- | Default config with approx. "mempty" values for convenience
defaultUbConf :: UbConf
defaultUbConf :: UbConf
defaultUbConf =
  UbConf :: Actions
-> FilePath
-> Int
-> Int
-> FilePath
-> Maybe Int
-> Maybe Int
-> Maybe Scalers
-> Maybe Bool
-> Maybe Bool
-> Maybe Float
-> Maybe Float
-> UbConf
UbConf
    { action :: Actions
action             = Actions
Add
    , identifier :: FilePath
identifier         = FilePath
""
    , x :: Int
x                  = Int
0
    , y :: Int
y                  = Int
0
    , path :: FilePath
path               = FilePath
""
    , width :: Maybe Int
width              = Maybe Int
forall a. Maybe a
Nothing
    , height :: Maybe Int
height             = Maybe Int
forall a. Maybe a
Nothing
    , scaler :: Maybe Scalers
scaler             = Maybe Scalers
forall a. Maybe a
Nothing
    , should_draw :: Maybe Bool
should_draw        = Maybe Bool
forall a. Maybe a
Nothing
    , synchronously_draw :: Maybe Bool
synchronously_draw = Maybe Bool
forall a. Maybe a
Nothing
    , scaling_position_x :: Maybe Float
scaling_position_x = Maybe Float
forall a. Maybe a
Nothing
    , scaling_position_y :: Maybe Float
scaling_position_y = Maybe Float
forall a. Maybe a
Nothing
    }

-- | Converts the ueberzug config to JSON, so that it can be passed into
-- | the ueberzug process
toJson :: UbConf -> Either String String
toJson :: UbConf -> Either FilePath FilePath
toJson UbConf
conf = do
  FilePath
iden <-
    case UbConf -> FilePath
identifier UbConf
conf of
      FilePath
"" -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
"Incomplete Information : Identifier Not Found"
      FilePath
a -> FilePath -> Either FilePath FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
a
  case UbConf -> Actions
action UbConf
conf of
    Actions
Remove ->
      FilePath -> Either FilePath FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
"{\"action\":\"remove\",\"identifier\":\"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
iden FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\"}\n")
    Actions
Add -> do
      FilePath
path_ <-
        case UbConf -> FilePath
path UbConf
conf of
           FilePath
"" -> FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
"Incomplete Information : Path Not Found"
           FilePath
a -> FilePath -> Either FilePath FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
a
      FilePath -> Either FilePath FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Either FilePath FilePath)
-> FilePath -> Either FilePath FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> ShowS
jsn FilePath
path_ FilePath
iden
  where
    jsn :: FilePath -> ShowS
jsn FilePath
path_ FilePath
iden =
        FilePath
"{\"action\": \"add"
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\", \"path\": \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path_
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\", \"identifier\": \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
iden
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\", \"x\": \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show (UbConf -> Int
x UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\", \"y\": \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show (UbConf -> Int
y UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Int -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"width" (UbConf -> Maybe Int
width UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Int -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"height" (UbConf -> Maybe Int
height UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Scalers -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"scaler" (UbConf -> Maybe Scalers
scaler UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Bool -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"draw" (UbConf -> Maybe Bool
should_draw UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Bool -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"sync" (UbConf -> Maybe Bool
synchronously_draw UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Float -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"scaling_position_x" (UbConf -> Maybe Float
scaling_position_x UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath -> Maybe Float -> FilePath
forall a. Show a => FilePath -> Maybe a -> FilePath
ifJust FilePath
"scaling_position_y" (UbConf -> Maybe Float
scaling_position_y UbConf
conf)
        FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\"}\n"

ifJust :: Show a => String -> Maybe a -> String
ifJust :: FilePath -> Maybe a -> FilePath
ifJust FilePath
name = FilePath -> (a -> FilePath) -> Maybe a -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (\a
a -> FilePath
"\", \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
name FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\": \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> FilePath
forall a. Show a => a -> FilePath
show a
a)