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 Data.Maybe (fromJust)
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 -> Maybe Handle
process :: Maybe Handle}

-- | Create a new Ueberzug instance with an empty process handle
newUeberzug :: Ueberzug
newUeberzug :: Ueberzug
newUeberzug = Ueberzug :: Maybe Handle -> Ueberzug
Ueberzug { process :: Maybe Handle
process = Maybe Handle
forall a. Maybe a
Nothing }

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

-- | Clear an image with identifier @identifier_@. The @ub@ instance
-- should be the same one that @draw@ returned, when drawing that image.
clear :: Ueberzug -> String -> IO (Either String Ueberzug)
clear :: Ueberzug -> String -> IO (Either String Ueberzug)
clear Ueberzug
ub String
identifier_ = do
  case UbConf -> Either String String
toJson UbConf
config of
    Right String
cmd -> Ueberzug -> String -> IO (Either String Ueberzug)
run Ueberzug
ub String
cmd
    Left  String
xx  -> Either String Ueberzug -> IO (Either String Ueberzug)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String Ueberzug
forall a b. a -> Either a b
Left String
xx)
  where
    config :: UbConf
config = UbConf
defaultUbConf { action :: Actions
action = Actions
Remove, identifier :: String
identifier = String
identifier_ }

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

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

  where
    fst4 :: (a, b, c, d) -> a
fst4 (a
a, b
_, c
_, d
_) = a
a
    created_stdin_h :: IO (Maybe Handle)
created_stdin_h =
      (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> Maybe Handle
forall a b c d. (a, b, c, d) -> a
fst4 ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> Maybe Handle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
"ueberzug" [String
"layer", String
"--silent"])
          { std_in :: StdStream
std_in = StdStream
CreatePipe
          , std_out :: StdStream
std_out = StdStream
CreatePipe
          }
    stdin_h :: IO Handle
stdin_h =
      case Ueberzug -> Maybe Handle
process Ueberzug
ub of
        Maybe Handle
Nothing -> Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Handle -> Handle) -> IO (Maybe Handle) -> IO Handle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Handle)
created_stdin_h
        Just Handle
a -> Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
a

-- | 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 -> String
show Scalers
Crop        = String
"crop"
  show Scalers
Distort     = String
"distort"
  show Scalers
FitContain  = String
"fit_contain"
  show Scalers
Contain     = String
"contain"
  show Scalers
ForcedCover = String
"forced_cover"
  show Scalers
Cover       = String
"cover"

-- | The ueberzug configuration record. Contains all the data needed to draw the image
data UbConf =
  UbConf
    { UbConf -> Actions
action             :: Actions
    , UbConf -> String
identifier         :: String
    , UbConf -> Int
x                  :: Int
    , UbConf -> Int
y                  :: Int
    , UbConf -> String
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
-> String
-> Int
-> Int
-> String
-> Maybe Int
-> Maybe Int
-> Maybe Scalers
-> Maybe Bool
-> Maybe Bool
-> Maybe Float
-> Maybe Float
-> UbConf
UbConf
    { action :: Actions
action             = Actions
Add
    , identifier :: String
identifier         = String
""
    , x :: Int
x                  = Int
0
    , y :: Int
y                  = Int
0
    , path :: String
path               = String
""
    , 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 String String
toJson UbConf
conf = do
  String
iden <-
    case UbConf -> String
identifier UbConf
conf of
      String
"" -> String -> Either String String
forall a b. a -> Either a b
Left String
"Incomplete Information : Identifier Not Found"
      String
a -> String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
a
  case UbConf -> Actions
action UbConf
conf of
    Actions
Remove ->
      String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"{\"action\":\"remove\",\"identifier\":\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
iden String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"}\n")
    Actions
Add -> do
      String
path_ <-
        case UbConf -> String
path UbConf
conf of
           String
"" -> String -> Either String String
forall a b. a -> Either a b
Left String
"Incomplete Information : Path Not Found"
           String
a -> String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
a
      String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String -> ShowS
jsn String
path_ String
iden
  where
    jsn :: String -> ShowS
jsn String
path_ String
iden =
        String
"{\"action\": \"add"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\", \"path\": \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path_
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\", \"identifier\": \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
iden
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\", \"x\": \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (UbConf -> Int
x UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\", \"y\": \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (UbConf -> Int
y UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Int -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"width" (UbConf -> Maybe Int
width UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Int -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"height" (UbConf -> Maybe Int
height UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Scalers -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"scaler" (UbConf -> Maybe Scalers
scaler UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Bool -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"draw" (UbConf -> Maybe Bool
should_draw UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Bool -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"sync" (UbConf -> Maybe Bool
synchronously_draw UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Float -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"scaling_position_x" (UbConf -> Maybe Float
scaling_position_x UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe Float -> String
forall a. Show a => String -> Maybe a -> String
ifJust String
"scaling_position_y" (UbConf -> Maybe Float
scaling_position_y UbConf
conf)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"}\n"

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