module OS.Window.X11 (
Window,
findByName,
setTitle,
setIcon,
) where
import Codec.Picture
import Control.Applicative
import Control.Arrow
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, Int -> Window -> ShowS
[Window] -> ShowS
Window -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Window] -> ShowS
$cshowList :: [Window] -> ShowS
show :: Window -> String
$cshow :: Window -> String
showsPrec :: Int -> Window -> ShowS
$cshowsPrec :: Int -> Window -> ShowS
Show)
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)
[(Word64, Text)]
ws <- 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
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text
name ==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Word64, Text)]
ws forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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) [(Word64, Text)]
ws
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 -> Either String DynamicImage
decodePng forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error \case
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
..} -> Int
-> Int
-> Vector Word8
-> ([Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8]))
-> IO ()
rgb Int
imageWidth Int
imageHeight Vector (PixelBaseComponent PixelRGBA8)
imageData \case
Word8
r : Word8
g : Word8
b : Word8
a : [Word8]
ps -> forall a. a -> Maybe a
Just ((Word8
r, Word8
g, Word8
b, Word8
a), [Word8]
ps)
[] -> forall a. Maybe a
Nothing
[Word8]
_ -> forall a. HasCallStack => String -> a
error String
"vector length not a multiple of 4"
ImageRGB8 Image{Int
Vector (PixelBaseComponent PixelRGB8)
imageData :: Vector (PixelBaseComponent PixelRGB8)
imageHeight :: Int
imageWidth :: Int
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..} -> Int
-> Int
-> Vector Word8
-> ([Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8]))
-> IO ()
rgb Int
imageWidth Int
imageHeight Vector (PixelBaseComponent PixelRGB8)
imageData \case
Word8
r : Word8
g : Word8
b : [Word8]
ps -> forall a. a -> Maybe a
Just ((Word8
r, Word8
g, Word8
b, forall a. Bounded a => a
maxBound), [Word8]
ps)
[] -> forall a. Maybe a
Nothing
[Word8]
_ -> forall a. HasCallStack => String -> a
error String
"vector length not a multiple of 3"
ImageY8{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageY8"
ImageY16{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageY16"
ImageY32{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageY32"
ImageYF{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYF"
ImageYA8{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYA8"
ImageYA16{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYA16"
ImageRGB16{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageRGB16"
ImageRGBF{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageRGBF"
ImageRGBA16{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageRGBA16"
ImageYCbCr8{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYCbCr8"
ImageCMYK8{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageCMYK8"
ImageCMYK16{} -> forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageCMYK16"
where
rgb :: Int -> Int -> Vec.Vector Word8 -> ([Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8])) -> IO ()
rgb :: Int
-> Int
-> Vector Word8
-> ([Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8]))
-> IO ()
rgb Int
imageWidth Int
imageHeight Vector Word8
imageData [Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8])
unconsPixels = 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 Word8
imageData)
Display -> IO ()
flush Display
d
where
groupPixels :: [Word8] -> [Word64]
groupPixels :: [Word8] -> [Word64]
groupPixels =
[Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8])
unconsPixels forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] \((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