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)
newtype Ueberzug = Ueberzug {Ueberzug -> Maybe Handle
process :: Maybe Handle}
newUeberzug :: Ueberzug
newUeberzug :: Ueberzug
newUeberzug = Ueberzug :: Maybe Handle -> Ueberzug
Ueberzug { process :: Maybe Handle
process = Maybe Handle
forall a. Maybe a
Nothing }
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 :: 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
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
data Actions = Add | Remove
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"
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
}
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
}
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)