window-utils (empty) → 0.1.0.0
raw patch · 6 files changed
+227/−0 lines, 6 filesdep +JuicyPixelsdep +Win32dep +X11
Dependencies added: JuicyPixels, Win32, X11, base, bytestring, text, vector
Files
- CHANGELOG.md +5/−0
- src/OS/Window.hs +5/−0
- src/OS/Window/Unsupported.hs +36/−0
- src/OS/Window/Win32.hs +61/−0
- src/OS/Window/X11.hs +73/−0
- window-utils.cabal +47/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for window-utils++## 0.1.0.0 -- 12-03-2023++* First version. Released on an unsuspecting world.
+ src/OS/Window.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++module OS.Window (module OS.Window.WIN) where++import OS.Window.WIN
+ src/OS/Window/Unsupported.hs view
@@ -0,0 +1,36 @@+module OS.Window.Unsupported (+ Window, -- it's important that the implementation is hidden here, since it will vary between platforms+ findByName,+ setTitle,+ setIcon,+) where++import Data.ByteString (ByteString)+import Data.Text (Text)+import System.IO++newtype Window = Window ()+ deriving (Eq, Ord)++findByName ::+ -- | substring which must appear in the window title+ Text ->+ IO Window+findByName _name = do+ warn+ pure $ Window ()++setTitle :: Window -> Text -> IO ()+setTitle (Window ()) _t =+ warn++setIcon ::+ Window ->+ -- | PNG image+ ByteString ->+ IO ()+setIcon (Window ()) _img = do+ warn++warn :: IO ()+warn = hPutStrLn stderr "Warning: window utilities unsupported on this OS"
+ src/OS/Window/Win32.hs view
@@ -0,0 +1,61 @@+module OS.Window.Win32 (+ 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.Monad+import Data.ByteString (ByteString, useAsCString)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector.Storable qualified as Vec+import Foreign.Ptr+import Graphics.Win32+import Unsafe.Coerce++newtype Window = Window HWND++findByName ::+ -- | substring which must appear in the window title+ Text ->+ IO Window+findByName name = do+ Just w <- findWindow Nothing . Just $ T.unpack name+ pure $ Window w++setTitle :: Window -> Text -> IO ()+setTitle (Window w) t = setWindowText w $ T.unpack t++setIcon ::+ Window ->+ -- | PNG image+ ByteString ->+ IO ()+setIcon (Window w) img = case decodePng img of+ Left e -> error e+ Right (ImageRGBA8 Image{..}) -> do+ let bs = BS.pack . reorderPixels $ Vec.toList imageData+ icon <- useAsCString bs $ createIcon nullPtr imageWidth imageHeight 1 32 nullPtr . castPtr+ void $ sendMessage w wM_SETICON iCON_BIG $ unsafeCoerce icon+ where+ reorderPixels = \case+ r : g : b : a : ps ->+ b : g : r : a : reorderPixels ps+ [] -> []+ _ -> error "vector length not a multiple of 4"+ _ -> error "wrong pixel type"++--TODO these should all be upstreamed to Win32 - see https://github.com/haskell/win32/pull/194+{- HLINT ignore "Use camelCase" -}+createIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON+createIcon instance_ width height planes bitsPixel andBits xorBits =+ failIfNull "CreateIcon" $ c_CreateIcon instance_ width height planes bitsPixel andBits xorBits+foreign import ccall unsafe "windows.h CreateIcon" -- when upstreaming, use WINDOWS_CCONV rather than ccall+ c_CreateIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON+wM_SETICON :: WindowMessage -- https://github.com/haskell/win32/blob/master/Graphics/Win32/Message.hsc+wM_SETICON = 128+iCON_BIG :: WPARAM -- not sure there's currently a relevant module for this (also, add `iCON_SMALL = 0`)+iCON_BIG = 1
+ src/OS/Window/X11.hs view
@@ -0,0 +1,73 @@+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 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 (Eq, Ord)++findByName ::+ -- | substring which must appear in the window title+ Text ->+ IO Window+findByName name = do+ d <- openDisplay ""+ Just (w, _) <- do+ nET_CLIENT_LIST <- internAtom d "_NET_CLIENT_LIST" True+ Just ids <- getWindowProperty32 d nET_CLIENT_LIST (defaultRootWindow d)+ find ((name `T.isInfixOf`) . snd) <$> for ids \(fromIntegral -> i) -> do+ Just cs <- getWindowProperty8 d wM_NAME i+ pure (i, decodeLatin1 . BS.pack $ map fromIntegral cs)+ pure $ Window w d++setTitle :: Window -> Text -> IO ()+setTitle (Window w d) t = do+ nET_WM_NAME <- internAtom d "_NET_WM_NAME" True+ uTF8_STRING <- internAtom d "UTF8_STRING" True+ changeProperty8 d w nET_WM_NAME uTF8_STRING propModeReplace . map fromIntegral . BS.unpack $ encodeUtf8 t+ flush d++setIcon ::+ Window ->+ -- | PNG image+ ByteString ->+ IO ()+setIcon (Window w d) img = do+ case decodePng img of+ Left e -> error e+ Right (ImageRGBA8 Image{..}) -> do+ nET_WM_ICON <- internAtom d "_NET_WM_ICON" True+ changeProperty32 d w nET_WM_ICON cARDINAL propModeReplace $+ map fromIntegral [imageWidth, imageHeight]+ ++ map fromIntegral (groupPixels $ Vec.toList imageData)+ flush d+ where+ groupPixels :: [Word8] -> [Word64]+ groupPixels = \case+ r : g : b : a : ps ->+ ( shift (fromIntegral a) 24+ .|. shift (fromIntegral r) 16+ .|. shift (fromIntegral g) 8+ .|. shift (fromIntegral b) 0+ )+ : groupPixels ps+ [] -> []+ _ -> error "vector length not a multiple of 4"+ _ -> error "wrong pixel type"
+ window-utils.cabal view
@@ -0,0 +1,47 @@+cabal-version: 3.0+name: window-utils+version: 0.1.0.0+license: BSD-3-Clause+author: George Thomas+maintainer: georgefsthomas@gmail.com+synopsis: OS window icon/name utilities+extra-source-files:+ CHANGELOG.md++library+ exposed-modules:+ OS.Window+ hs-source-dirs: src+ ghc-options:+ -Wall+ if os(linux)+ other-modules:+ OS.Window.X11+ cpp-options:+ -DWIN=X11+ build-depends:+ X11 ^>= 1.10.2,+ elif os(windows)+ other-modules:+ OS.Window.Win32+ cpp-options:+ -DWIN=Win32+ build-depends:+ Win32 ^>= 2.12,+ else+ other-modules:+ OS.Window.Unsupported+ cpp-options:+ -DWIN=Unsupported+ build-depends:+ base ^>= 4.16,+ bytestring ^>= 0.11,+ JuicyPixels ^>= 3.3.6,+ text ^>= 1.2.3,+ vector ^>= 0.12.3.1,+ default-language: GHC2021+ default-extensions:+ BlockArguments+ LambdaCase+ RecordWildCards+ ViewPatterns