module OS.Window.X11 (
    Window, -- it's important that the implementation is hidden here, since it will vary between platforms
    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
(Window -> Window -> Bool)
-> (Window -> Window -> Bool) -> Eq Window
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Window -> Window -> Bool
== :: Window -> Window -> Bool
$c/= :: Window -> Window -> Bool
/= :: Window -> Window -> Bool
Eq, Eq Window
Eq Window =>
(Window -> Window -> Ordering)
-> (Window -> Window -> Bool)
-> (Window -> Window -> Bool)
-> (Window -> Window -> Bool)
-> (Window -> Window -> Bool)
-> (Window -> Window -> Window)
-> (Window -> Window -> Window)
-> Ord 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
$ccompare :: Window -> Window -> Ordering
compare :: Window -> Window -> Ordering
$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
>= :: Window -> Window -> Bool
$cmax :: Window -> Window -> Window
max :: Window -> Window -> Window
$cmin :: Window -> Window -> Window
min :: Window -> Window -> Window
Ord, Int -> Window -> ShowS
[Window] -> ShowS
Window -> String
(Int -> Window -> ShowS)
-> (Window -> String) -> ([Window] -> ShowS) -> Show Window
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Window -> ShowS
showsPrec :: Int -> Window -> ShowS
$cshow :: Window -> String
show :: Window -> String
$cshowList :: [Window] -> ShowS
showList :: [Window] -> ShowS
Show)

findByName ::
    -- | substring which must appear in the window title
    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 <- [CLong] -> (CLong -> IO (Word64, Text)) -> IO [(Word64, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [CLong]
ids \(CLong -> Word64
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
            (Word64, Text) -> IO (Word64, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64
i, ByteString -> Text
decodeLatin1 (ByteString -> Text) -> ([Word8] -> ByteString) -> [Word8] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> Text) -> [Word8] -> Text
forall a b. (a -> b) -> a -> b
$ (CChar -> Word8) -> [CChar] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map CChar -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral [CChar]
cs)
        Maybe (Word64, Text) -> IO (Maybe (Word64, Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Word64, Text) -> IO (Maybe (Word64, Text)))
-> Maybe (Word64, Text) -> IO (Maybe (Word64, Text))
forall a b. (a -> b) -> a -> b
$ ((Word64, Text) -> Bool)
-> [(Word64, Text)] -> Maybe (Word64, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text
name ==) (Text -> Bool)
-> ((Word64, Text) -> Text) -> (Word64, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, Text) -> Text
forall a b. (a, b) -> b
snd) [(Word64, Text)]
ws Maybe (Word64, Text)
-> Maybe (Word64, Text) -> Maybe (Word64, Text)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Word64, Text) -> Bool)
-> [(Word64, Text)] -> Maybe (Word64, Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text
name `T.isInfixOf`) (Text -> Bool)
-> ((Word64, Text) -> Text) -> (Word64, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, Text) -> Text
forall a b. (a, b) -> b
snd) [(Word64, Text)]
ws
    Window -> IO Window
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Window -> IO Window) -> Window -> IO Window
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 ([CChar] -> IO ())
-> (ByteString -> [CChar]) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> CChar) -> [Word8] -> [CChar]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> CChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [CChar])
-> (ByteString -> [Word8]) -> ByteString -> [CChar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t
    Display -> IO ()
flush Display
d

setIcon ::
    Window ->
    -- | PNG image
    ByteString ->
    IO ()
setIcon :: Window -> ByteString -> IO ()
setIcon (Window Word64
w Display
d) =
    ByteString -> Either String DynamicImage
decodePng (ByteString -> Either String DynamicImage)
-> (Either String DynamicImage -> IO ()) -> ByteString -> IO ()
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (String -> IO ())
-> (DynamicImage -> IO ()) -> Either String DynamicImage -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO ()
forall a. HasCallStack => String -> a
error \case
        ImageRGBA8 Image{Int
Vector (PixelBaseComponent PixelRGBA8)
imageWidth :: Int
imageHeight :: Int
imageData :: Vector (PixelBaseComponent PixelRGBA8)
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 Word8
Vector (PixelBaseComponent PixelRGBA8)
imageData \case
            Word8
r : Word8
g : Word8
b : Word8
a : [Word8]
ps -> ((Word8, Word8, Word8, Word8), [Word8])
-> Maybe ((Word8, Word8, Word8, Word8), [Word8])
forall a. a -> Maybe a
Just ((Word8
r, Word8
g, Word8
b, Word8
a), [Word8]
ps)
            [] -> Maybe ((Word8, Word8, Word8, Word8), [Word8])
forall a. Maybe a
Nothing
            [Word8]
_ -> String -> Maybe ((Word8, Word8, Word8, Word8), [Word8])
forall a. HasCallStack => String -> a
error String
"vector length not a multiple of 4"
        ImageRGB8 Image{Int
Vector (PixelBaseComponent PixelRGB8)
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageWidth :: Int
imageHeight :: Int
imageData :: Vector (PixelBaseComponent PixelRGB8)
..} -> Int
-> Int
-> Vector Word8
-> ([Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8]))
-> IO ()
rgb Int
imageWidth Int
imageHeight Vector Word8
Vector (PixelBaseComponent PixelRGB8)
imageData \case
            Word8
r : Word8
g : Word8
b : [Word8]
ps -> ((Word8, Word8, Word8, Word8), [Word8])
-> Maybe ((Word8, Word8, Word8, Word8), [Word8])
forall a. a -> Maybe a
Just ((Word8
r, Word8
g, Word8
b, Word8
forall a. Bounded a => a
maxBound), [Word8]
ps)
            [] -> Maybe ((Word8, Word8, Word8, Word8), [Word8])
forall a. Maybe a
Nothing
            [Word8]
_ -> String -> Maybe ((Word8, Word8, Word8, Word8), [Word8])
forall a. HasCallStack => String -> a
error String
"vector length not a multiple of 3"
        ImageY8{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageY8"
        ImageY16{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageY16"
        ImageY32{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageY32"
        ImageYF{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYF"
        ImageYA8{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYA8"
        ImageYA16{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYA16"
        ImageRGB16{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageRGB16"
        ImageRGBF{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageRGBF"
        ImageRGBA16{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageRGBA16"
        ImageYCbCr8{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageYCbCr8"
        ImageCMYK8{} -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"unexpected pixel type: ImageCMYK8"
        ImageCMYK16{} -> String -> IO ()
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 ([CLong] -> IO ()) -> [CLong] -> IO ()
forall a b. (a -> b) -> a -> b
$
            (Int -> CLong) -> [Int] -> [CLong]
forall a b. (a -> b) -> [a] -> [b]
map Int -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int
imageWidth, Int
imageHeight]
                [CLong] -> [CLong] -> [CLong]
forall a. [a] -> [a] -> [a]
++ (Word64 -> CLong) -> [Word64] -> [CLong]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word64]
groupPixels ([Word8] -> [Word64]) -> [Word8] -> [Word64]
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> [Word8]
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 ([Word8] -> Maybe ((Word8, Word8, Word8, Word8), [Word8]))
-> (Maybe ((Word8, Word8, Word8, Word8), [Word8]) -> [Word64])
-> [Word8]
-> [Word64]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Word64]
-> (((Word8, Word8, Word8, Word8), [Word8]) -> [Word64])
-> Maybe ((Word8, Word8, Word8, Word8), [Word8])
-> [Word64]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] \((Word8
r, Word8
g, Word8
b, Word8
a), [Word8]
ps) ->
                ( Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shift (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a) Int
24
                    Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shift (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r) Int
16
                    Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shift (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g) Int
8
                    Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shift (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Int
0
                )
                    Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: [Word8] -> [Word64]
groupPixels [Word8]
ps