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
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 ::
    -- | 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 <- 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 ->
    -- | PNG image
    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