module OS.Window.X11 (
Window,
findByName,
setTitle,
setIcon,
) where
import Codec.Picture
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.List
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding
import Data.Traversable
import Data.Vector.Storable qualified as Vec
import Data.Word
import Graphics.X11 hiding (Window)
import Graphics.X11 qualified as X11
import Graphics.X11.Xlib.Extras
data Window = Window X11.Window Display
deriving (Window -> Window -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Window -> Window -> Bool
$c/= :: Window -> Window -> Bool
== :: Window -> Window -> Bool
$c== :: Window -> Window -> Bool
Eq, Eq Window
Window -> Window -> Bool
Window -> Window -> Ordering
Window -> Window -> Window
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Window -> Window -> Window
$cmin :: Window -> Window -> Window
max :: Window -> Window -> Window
$cmax :: Window -> Window -> Window
>= :: Window -> Window -> Bool
$c>= :: Window -> Window -> Bool
> :: Window -> Window -> Bool
$c> :: Window -> Window -> Bool
<= :: Window -> Window -> Bool
$c<= :: Window -> Window -> Bool
< :: Window -> Window -> Bool
$c< :: Window -> Window -> Bool
compare :: Window -> Window -> Ordering
$ccompare :: Window -> Window -> Ordering
Ord)
findByName ::
Text ->
IO Window
findByName :: Text -> IO Window
findByName Text
name = do
Display
d <- String -> IO Display
openDisplay String
""
Just (Word64
w, Text
_) <- do
Word64
nET_CLIENT_LIST <- Display -> String -> Bool -> IO Word64
internAtom Display
d String
"_NET_CLIENT_LIST" Bool
True
Just [CLong]
ids <- Display -> Word64 -> Word64 -> IO (Maybe [CLong])
getWindowProperty32 Display
d Word64
nET_CLIENT_LIST (Display -> Word64
defaultRootWindow Display
d)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text
name `T.isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CLong]
ids \(forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Word64
i) -> do
Just [CChar]
cs <- Display -> Word64 -> Word64 -> IO (Maybe [CChar])
getWindowProperty8 Display
d Word64
wM_NAME Word64
i
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64
i, ByteString -> Text
decodeLatin1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [CChar]
cs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word64 -> Display -> Window
Window Word64
w Display
d
setTitle :: Window -> Text -> IO ()
setTitle :: Window -> Text -> IO ()
setTitle (Window Word64
w Display
d) Text
t = do
Word64
nET_WM_NAME <- Display -> String -> Bool -> IO Word64
internAtom Display
d String
"_NET_WM_NAME" Bool
True
Word64
uTF8_STRING <- Display -> String -> Bool -> IO Word64
internAtom Display
d String
"UTF8_STRING" Bool
True
Display -> Word64 -> Word64 -> Word64 -> CInt -> [CChar] -> IO ()
changeProperty8 Display
d Word64
w Word64
nET_WM_NAME Word64
uTF8_STRING CInt
propModeReplace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t
Display -> IO ()
flush Display
d
setIcon ::
Window ->
ByteString ->
IO ()
setIcon :: Window -> ByteString -> IO ()
setIcon (Window Word64
w Display
d) ByteString
img = do
case ByteString -> Either String DynamicImage
decodePng ByteString
img of
Left String
e -> forall a. HasCallStack => String -> a
error String
e
Right (ImageRGBA8 Image{Int
Vector (PixelBaseComponent PixelRGBA8)
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData :: Vector (PixelBaseComponent PixelRGBA8)
imageHeight :: Int
imageWidth :: Int
..}) -> do
Word64
nET_WM_ICON <- Display -> String -> Bool -> IO Word64
internAtom Display
d String
"_NET_WM_ICON" Bool
True
Display -> Word64 -> Word64 -> Word64 -> CInt -> [CLong] -> IO ()
changeProperty32 Display
d Word64
w Word64
nET_WM_ICON Word64
cARDINAL CInt
propModeReplace forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int
imageWidth, Int
imageHeight]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word64]
groupPixels forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Vector a -> [a]
Vec.toList Vector (PixelBaseComponent PixelRGBA8)
imageData)
Display -> IO ()
flush Display
d
where
groupPixels :: [Word8] -> [Word64]
groupPixels :: [Word8] -> [Word64]
groupPixels = \case
Word8
r : Word8
g : Word8
b : Word8
a : [Word8]
ps ->
( forall a. Bits a => a -> Int -> a
shift (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a) Int
24
forall a. Bits a => a -> a -> a
.|. forall a. Bits a => a -> Int -> a
shift (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r) Int
16
forall a. Bits a => a -> a -> a
.|. forall a. Bits a => a -> Int -> a
shift (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g) Int
8
forall a. Bits a => a -> a -> a
.|. forall a. Bits a => a -> Int -> a
shift (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Int
0
)
forall a. a -> [a] -> [a]
: [Word8] -> [Word64]
groupPixels [Word8]
ps
[] -> []
[Word8]
_ -> forall a. HasCallStack => String -> a
error String
"vector length not a multiple of 4"
Either String DynamicImage
_ -> forall a. HasCallStack => String -> a
error String
"wrong pixel type"