xhb-ewmh (empty) → 0.1.0.0
raw patch · 7 files changed
+1344/−0 lines, 7 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, dlist, hashable, mtl, transformers, xhb, xhb-atom-cache
Files
- LICENSE +26/−0
- Setup.hs +2/−0
- src/Graphics/XHB/Ewmh.hs +598/−0
- src/Graphics/XHB/Ewmh/Atoms.hs +145/−0
- src/Graphics/XHB/Ewmh/Types.hs +359/−0
- src/Graphics/XHB/Ewmh/Values.hs +170/−0
- xhb-ewmh.cabal +44/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Jochen Keil+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Graphics/XHB/Ewmh.hs view
@@ -0,0 +1,598 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Graphics.XHB.Ewmh+ ( runEwmhT+ , getNetSupported+ , setNetSupported+ , getNetClientList+ , setNetClientList+ , getNetClientListStacking+ , setNetClientListStacking+ , getNetNumberOfDesktops+ , setNetNumberOfDesktops+ , requestNetNumberOfDesktops+ , getNetDesktopGeometry+ , setNetDesktopGeometry+ , requestNetDesktopGeometry+ , getNetDesktopViewport+ , setNetDesktopViewport+ , requestNetDesktopViewport+ , getNetCurrentDesktop+ , setNetCurrentDesktop+ , requestNetCurrentDesktop+ , getNetDesktopNames+ , setNetDesktopNames+ , getActiveWindow+ , setActiveWindow+ , requestNetActiveWindow+ , getNetWorkarea+ , setNetWorkarea+ , getNetSupportingWmCheck+ , setNetSupportingWmCheck+ , getNetVirtualRoots+ , setNetVirtualRoots+ , getNetDesktopLayout+ , setNetDesktopLayout+ , getNetShowingDesktop+ , setNetShowingDesktop+ , requestNetShowingDesktop+ , requestNetCloseWindow+ , requestNetMoveresizeWindow+ , requestNetWmMoveresize+ , requestNetRestackWindow+ , requestNetRequestFrameExtents+ , getNetWmName+ , setNetWmName+ , getNetWmVisibleName+ , setNetWmVisibleName+ , getNetWmIconName+ , setNetWmIconName+ , getNetWmVisibleIconName+ , setNetWmVisibleIconName+ , getNetWmDesktop+ , setNetWmDesktop+ , requestNetWmDesktop+ , getNetWmWindowType+ , setNetWmWindowType+ , getNetWmState+ , setNetWmState+ , requestNetWmState+ , getNetWmAllowedActions+ , setNetWmAllowedActions+ , getNetWmStrut+ , setNetWmStrut+ , getNetWmStrutPartial+ , setNetWmStrutPartial+ , getNetWmIconGeometry+ , setNetWmIconGeometry+ , getNetWmIcon+ , setNetWmIcon+ , getNetWmPID+ , setNetWmPID+ , getNetWmHandledIcons+ , setNetWmHandledIcons+ , getNetWmUserTime+ , setNetWmUserTime+ , getNetWmUserTimeWindow+ , setNetWmUserTimeWindow+ , getNetFrameExtents+ , setNetFrameExtents+ , getNetWmOpaqueRegion+ , setNetWmOpaqueRegion+ , getNetWmBypassCompositor+ , setNetWmBypassCompositor+ , requestNetWmPing+ , requestNetWmSyncRequest+ , requestNetWmFullscreenMonitors+ ) where++import Data.Bits ((.|.), shiftL)+import Data.Word (Word32)+import Data.Maybe (isJust, catMaybes, fromMaybe)+import Control.Monad (join, void)+import Control.Monad.Except (ExceptT(..), runExceptT)+import Control.Applicative (Applicative(..), (<$>))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.ByteString.Lazy.Char8 (pack)++import Foreign.C (CChar(..))+import Graphics.XHB (Connection, SomeError, WINDOW, ATOM, XidLike, Atom(..))+import Graphics.XHB (GetProperty(..), ChangeProperty(..), Window(..))+import Graphics.XHB (SendEvent(..), ClientMessageEvent(..), ClientMessageData(..))+import Graphics.XHB (PropMode(..), EventMask(..), Time(..), UnknownError(..))+import qualified Graphics.XHB as X+import Graphics.XHB.AtomCache+import Graphics.XHB.Ewmh.Values+import Graphics.XHB.Ewmh.Atoms+import Graphics.XHB.Ewmh.Types+import Graphics.XHB.Ewmh.Serialize++instance XidLike Atom where+ toXid a = X.toXid (X.toValue a :: Word32)+ fromXid a = X.fromValue (X.fromXid a :: Word32)++class PropertyType t where+ toPropertyType :: AtomCacheCtx m => t -> m ATOM++instance PropertyType Atom where+ toPropertyType = return . X.fromXid . X.toXid++instance PropertyType UTF8_STRING where+ toPropertyType = unsafeLookupATOM++type Prop p t r m = (AtomLike p, PropertyType t, Serialize r, EwmhCtx m)++type Request p d m = (AtomLike p, Serialize d, EwmhCtx m)++eitherToExcept :: Monad m => Either e a -> ExceptT e m a+eitherToExcept = ExceptT . return++runEwmhT :: (MonadIO m, Applicative m)+ => Connection -> EwmhT m a -> m (Either SomeError a)+runEwmhT c = runAtomCacheT+ . fmap (join . join . join . join)+ . seedAtoms c utf8+ . seedAtoms c ewmh+ . seedAtoms c states+ . seedAtoms c actions+ . seedAtoms c types+ where+ utf8 = [UTF8_STRING]+ ewmh = [NET_SUPPORTED .. NET_WM_FULL_PLACEMENT]+ states = [NET_WM_STATE_MODAL .. NET_WM_STATE_FOCUSED]+ actions = [NET_WM_ACTION_MOVE .. NET_WM_ACTION_BELOW]+ types = [NET_WM_WINDOW_TYPE_DESKTOP .. NET_WM_WINDOW_TYPE_NORMAL]++getProp :: Prop p t r m => Connection -> WINDOW -> p -> t -> m (Either SomeError r)+getProp c w p t = runExceptT $ do+ ap <- unsafeLookupATOM p+ at <- toPropertyType t+ eitherToExcept+ =<< fmap fromReply . eitherToExcept+ =<< getPropertyReply (request ap at)+ where+ fromReply r = case fromBytes (X.value_GetPropertyReply r) of+ Right a -> Right a+ Left e -> Left . X.toError . UnknownError . pack $ e+ getPropertyReply req = liftIO $ X.getProperty c req >>= X.getReply+ request ap at = MkGetProperty+ { delete_GetProperty = False+ , window_GetProperty = w+ , property_GetProperty = ap+ , type_GetProperty = at+ , long_offset_GetProperty = 0+ , long_length_GetProperty = maxBound+ }++setProp :: Prop p t r m => Connection -> WINDOW -> p -> t -> r -> m ()+setProp c w p t r = do+ ap <- unsafeLookupATOM p+ at <- toPropertyType t+ liftIO . X.changeProperty c $ request ap at+ where+ values = toBytes r+ request ap at = MkChangeProperty+ { mode_ChangeProperty = PropModeReplace+ , window_ChangeProperty = w+ , property_ChangeProperty = ap+ , type_ChangeProperty = at+ , format_ChangeProperty = 8+ , data_len_ChangeProperty = fromIntegral $ length values+ , data_ChangeProperty = values+ }++getRootProp :: Prop p t r m => Connection -> p -> t -> m (Either SomeError r)+getRootProp c = getProp c (X.getRoot c)++setRootProp :: Prop p t r m => Connection -> p -> t -> r -> m ()+setRootProp c = setProp c (X.getRoot c)++hoistMaybe :: Monad m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . return++-- | Send an Ewmh request for `WINDOW` to the root window+sendRequest :: Request p d m => Connection -> WINDOW -> p -> d -> m ()+sendRequest c w a d = void . runMaybeT $ lookupATOM a >>= hoistMaybe >>= send+ where+ send = liftIO . X.sendEvent c . request (X.getRoot c) . serializeEvent++ serializeEvent = map (CChar . fromIntegral) . toBytes . event++ event typ = MkClientMessageEvent+ { format_ClientMessageEvent = 32+ , window_ClientMessageEvent = w+ , type_ClientMessageEvent = typ+ , data_ClientMessageEvent = ClientData8 $ toBytes d+ }++ request win raw = MkSendEvent+ { propagate_SendEvent = False+ , destination_SendEvent = win+ , event_mask_SendEvent = [ EventMaskSubstructureNotify+ , EventMaskSubstructureRedirect+ ]+ , event_SendEvent = raw+ }++----------------------------+-- Root Window Properties --+----------------------------++getNetSupported :: EwmhCtx m => Connection -> m (Either SomeError NetSupported)+getNetSupported c = runExceptT $ do+ atomids <- mapM lookupAtomId+ =<< eitherToExcept+ =<< getRootProp c NET_SUPPORTED AtomATOM+ return $ NetSupported (atoms atomids) (states atomids) (actions atomids) (types atomids)+ where+ -- yeah..+ atoms = catMaybes . map fromAtom . catMaybes+ states = catMaybes . map fromAtom . catMaybes+ actions = catMaybes . map fromAtom . catMaybes+ types = catMaybes . map fromAtom . catMaybes++setNetSupported :: EwmhCtx m => Connection -> NetSupported -> m ()+setNetSupported c ns = do+ state <- unsafeLookupATOM NET_WM_STATE+ types <- unsafeLookupATOM NET_WM_WINDOW_TYPE+ actions <- unsafeLookupATOM NET_WM_ALLOWED_ACTIONS++ atoms <- mapM unsafeLookupATOM (ewmhAtoms ns)+ atoms' <- insertAt state atoms <$> mapM unsafeLookupATOM (netWmStates ns)+ atoms'' <- insertAt types atoms' <$> mapM unsafeLookupATOM (netWmWindowTypes ns)+ atoms''' <- insertAt actions atoms'' <$> mapM unsafeLookupATOM (netWmAllowedActions ns)++ setRootProp c NET_SUPPORTED AtomATOM atoms'''++ where+ insertAt :: Eq t => t -> [t] -> [t] -> [t]+ insertAt _ [] _ = []+ insertAt a (x:xs) as | a == x = x : as ++ xs+ | otherwise = x : insertAt a xs as++getNetClientList :: EwmhCtx m => Connection -> m (Either SomeError [WINDOW])+getNetClientList c = getRootProp c NET_CLIENT_LIST AtomWINDOW++setNetClientList :: EwmhCtx m => Connection -> [WINDOW] -> m ()+setNetClientList c = setRootProp c NET_CLIENT_LIST AtomWINDOW++getNetClientListStacking :: EwmhCtx m => Connection -> m (Either SomeError [WINDOW])+getNetClientListStacking c = getRootProp c NET_CLIENT_LIST_STACKING AtomWINDOW++setNetClientListStacking :: EwmhCtx m => Connection -> [WINDOW] -> m ()+setNetClientListStacking c = setRootProp c NET_CLIENT_LIST_STACKING AtomWINDOW++getNetNumberOfDesktops :: EwmhCtx m => Connection -> m (Either SomeError Word32)+getNetNumberOfDesktops c = getRootProp c NET_NUMBER_OF_DESKTOPS AtomCARDINAL++setNetNumberOfDesktops :: EwmhCtx m => Connection -> Word32 -> m ()+setNetNumberOfDesktops c = setRootProp c NET_NUMBER_OF_DESKTOPS AtomCARDINAL++requestNetNumberOfDesktops :: EwmhCtx m => Connection -> Word32 -> m ()+requestNetNumberOfDesktops c n = do+ sendRequest c none NET_NUMBER_OF_DESKTOPS [n]+ where none= X.fromXid $ X.toXid (X.toValue WindowNone :: Word32)++getNetDesktopGeometry :: EwmhCtx m => Connection -> m (Either SomeError NetDesktopGeometry)+getNetDesktopGeometry c = getRootProp c NET_DESKTOP_GEOMETRY AtomCARDINAL++setNetDesktopGeometry :: EwmhCtx m => Connection -> NetDesktopGeometry -> m ()+setNetDesktopGeometry c = setRootProp c NET_DESKTOP_GEOMETRY AtomCARDINAL++requestNetDesktopGeometry :: EwmhCtx m => Connection -> NetDesktopGeometry -> m ()+requestNetDesktopGeometry c (NetDesktopGeometry w h) = do+ sendRequest c none NET_DESKTOP_GEOMETRY [w, h]+ where none = X.fromXid $ X.toXid (X.toValue WindowNone :: Word32)++getNetDesktopViewport :: EwmhCtx m => Connection -> m (Either SomeError NetDesktopViewport)+getNetDesktopViewport c = getRootProp c NET_DESKTOP_VIEWPORT AtomCARDINAL++setNetDesktopViewport :: EwmhCtx m => Connection -> NetDesktopViewport -> m ()+setNetDesktopViewport c = setRootProp c NET_DESKTOP_VIEWPORT AtomCARDINAL++requestNetDesktopViewport :: EwmhCtx m => Connection -> Viewport -> m ()+requestNetDesktopViewport c (Viewport x y) = do+ sendRequest c none NET_DESKTOP_VIEWPORT [x, y]+ where none = X.fromXid $ X.toXid (X.toValue WindowNone :: Word32)++getNetCurrentDesktop :: EwmhCtx m => Connection -> m (Either SomeError Word32)+getNetCurrentDesktop c = getRootProp c NET_CURRENT_DESKTOP AtomCARDINAL++setNetCurrentDesktop :: EwmhCtx m => Connection -> Word32 -> m ()+setNetCurrentDesktop c = setRootProp c NET_CURRENT_DESKTOP AtomCARDINAL++requestNetCurrentDesktop :: EwmhCtx m => Connection -> Word32 -> m ()+requestNetCurrentDesktop c v = do+ sendRequest c none NET_CURRENT_DESKTOP [v, X.toValue TimeCurrentTime]+ where none = X.fromXid $ X.toXid (X.toValue WindowNone :: Word32)++getNetDesktopNames :: EwmhCtx m => Connection -> m (Either SomeError [String])+getNetDesktopNames c = getProp c (X.getRoot c) NET_DESKTOP_NAMES UTF8_STRING++setNetDesktopNames :: EwmhCtx m => Connection -> [String] -> m ()+setNetDesktopNames c = setRootProp c NET_DESKTOP_NAMES UTF8_STRING++getActiveWindow :: EwmhCtx m => Connection -> m (Either SomeError WINDOW)+getActiveWindow c = getRootProp c NET_ACTIVE_WINDOW AtomWINDOW++setActiveWindow :: EwmhCtx m => Connection -> WINDOW -> m ()+setActiveWindow c = setRootProp c NET_ACTIVE_WINDOW AtomWINDOW++requestNetActiveWindow :: EwmhCtx m => Connection -> NetActiveWindow -> m ()+requestNetActiveWindow c (NetActiveWindow src mw) = do+ sendRequest c none NET_ACTIVE_WINDOW values+ where none = X.fromXid $ X.toXid (X.toValue WindowNone :: Word32)+ values = [ X.toValue src+ , X.toValue TimeCurrentTime+ , maybe 0 (X.fromXid . X.toXid) mw+ ] :: [Word32]++getNetWorkarea :: EwmhCtx m => Connection -> m (Either SomeError NetWorkarea)+getNetWorkarea c = getRootProp c NET_WORKAREA AtomCARDINAL++setNetWorkarea :: EwmhCtx m => Connection -> NetWorkarea -> m ()+setNetWorkarea c = setRootProp c NET_WORKAREA AtomCARDINAL++getNetSupportingWmCheck :: EwmhCtx m => Connection -> m (Either SomeError WINDOW)+getNetSupportingWmCheck c = getRootProp c NET_SUPPORTING_WM_CHECK AtomWINDOW++setNetSupportingWmCheck :: EwmhCtx m => Connection -> WINDOW -> m ()+setNetSupportingWmCheck c = setRootProp c NET_SUPPORTING_WM_CHECK AtomWINDOW++getNetVirtualRoots :: EwmhCtx m => Connection -> m (Either SomeError [WINDOW])+getNetVirtualRoots c = getRootProp c NET_VIRTUAL_ROOTS AtomWINDOW++setNetVirtualRoots :: EwmhCtx m => Connection -> [WINDOW] -> m ()+setNetVirtualRoots c = setRootProp c NET_VIRTUAL_ROOTS AtomWINDOW++getNetDesktopLayout :: EwmhCtx m => Connection -> m (Either SomeError NetDesktopLayout)+getNetDesktopLayout conn = getRootProp conn NET_DESKTOP_LAYOUT AtomCARDINAL++setNetDesktopLayout :: EwmhCtx m => Connection -> NetDesktopLayout -> m ()+setNetDesktopLayout c = setRootProp c NET_DESKTOP_LAYOUT AtomCARDINAL++getNetShowingDesktop :: EwmhCtx m => Connection -> m (Either SomeError Word32)+getNetShowingDesktop c = getRootProp c NET_SHOWING_DESKTOP AtomCARDINAL++setNetShowingDesktop :: EwmhCtx m => Connection -> Word32 -> m ()+setNetShowingDesktop c = setRootProp c NET_SHOWING_DESKTOP AtomCARDINAL++requestNetShowingDesktop :: EwmhCtx m => Connection -> Bool -> m ()+requestNetShowingDesktop c b = sendRequest c none NET_SHOWING_DESKTOP [fromEnum b]+ where none = X.fromXid $ X.toXid (X.toValue WindowNone :: Word32)++--------------------------------+-- Other Root Window Messages --+--------------------------------++requestNetCloseWindow :: EwmhCtx m => Connection -> WINDOW -> SourceIndication -> m ()+requestNetCloseWindow c w si = do+ sendRequest c w NET_CLOSE_WINDOW ([X.toValue TimeCurrentTime, X.toValue si] :: [Word32])++requestNetMoveresizeWindow :: EwmhCtx m+ => Connection -> WINDOW -> NetMoveresizeWindow -> m ()+requestNetMoveresizeWindow c w mr = sendRequest c w NET_MOVERESIZE_WINDOW values+ where+ x = netMoveresizeWindow_x mr+ y = netMoveresizeWindow_y mr+ width = fromIntegral <$> netMoveresizeWindow_width mr+ height = fromIntegral <$> netMoveresizeWindow_height mr++ sourceIndicationBit = case netMoveresizeWindow_source_indication mr of+ SourceApplication -> 12+ SourcePager -> 13+ _ -> 0++ gravityBit = X.toValue $ netMoveresizeWindow_gravity mr+ xBit = if isJust x then shiftL 1 8 else 0+ yBit = if isJust y then shiftL 1 9 else 0+ widthBit = if isJust width then shiftL 1 10 else 0+ heightBit = if isJust height then shiftL 1 11 else 0++ flags = foldr (.|.) 0 [gravityBit, xBit, yBit, widthBit, heightBit, sourceIndicationBit]++ values = [flags, fromMaybe 0 x, fromMaybe 0 y, fromMaybe 0 width, fromMaybe 0 height]++requestNetWmMoveresize :: EwmhCtx m => Connection -> WINDOW -> NetWmMoveresize -> m ()+requestNetWmMoveresize c w mr = do+ sendRequest c w NET_WM_MOVERESIZE [x_root, y_root, direction, button, sourceIndication]+ where+ x_root = fromMaybe 0 $ netWmMoveresize_x_root mr+ y_root = fromMaybe 0 $ netWmMoveresize_y_root mr+ direction = X.toValue $ netWmMoveresize_direction mr+ button = X.toValue $ netWmMoveresize_button mr+ sourceIndication = X.toValue $ netWmMoveresize_source_indication mr++requestNetRestackWindow :: EwmhCtx m => Connection -> WINDOW -> NetRestackWindow -> m ()+requestNetRestackWindow c w rw = do+ sendRequest c w NET_RESTACK_WINDOW ([sourceIndication, sibling_window, detail] :: [Word32])+ where+ sourceIndication = X.toValue $ netRestackWindow_source_indication rw+ sibling_window = X.fromXid . X.toXid $ netRestackWindow_sibling_window rw+ detail = X.toValue $ netRestackWindow_detail rw++requestNetRequestFrameExtents :: EwmhCtx m => Connection -> WINDOW -> m ()+requestNetRequestFrameExtents c w = sendRequest c w NET_REQUEST_FRAME_EXTENTS ([] :: [Word32])++-----------------------------------+-- Application Window Properties --+-----------------------------------++getNetWmName :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [String])+getNetWmName c w = getProp c w NET_WM_NAME UTF8_STRING++setNetWmName :: EwmhCtx m => Connection -> WINDOW -> [String] -> m ()+setNetWmName c w = setProp c w NET_WM_NAME UTF8_STRING++getNetWmVisibleName :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [String])+getNetWmVisibleName c w = getProp c w NET_WM_VISIBLE_NAME UTF8_STRING++setNetWmVisibleName :: EwmhCtx m => Connection -> WINDOW -> [String] -> m ()+setNetWmVisibleName c w = setProp c w NET_WM_VISIBLE_NAME UTF8_STRING++getNetWmIconName :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [String])+getNetWmIconName c w = getProp c w NET_WM_ICON_NAME UTF8_STRING++setNetWmIconName :: EwmhCtx m => Connection -> WINDOW -> [String] -> m ()+setNetWmIconName c w = setProp c w NET_WM_ICON_NAME UTF8_STRING++getNetWmVisibleIconName :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [String])+getNetWmVisibleIconName c w = getProp c w NET_WM_VISIBLE_ICON_NAME UTF8_STRING++setNetWmVisibleIconName :: EwmhCtx m => Connection -> WINDOW -> [String] -> m ()+setNetWmVisibleIconName c w = setProp c w NET_WM_VISIBLE_ICON_NAME UTF8_STRING++getNetWmDesktop :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError Word32)+getNetWmDesktop c w = getProp c w NET_WM_DESKTOP AtomCARDINAL++setNetWmDesktop :: EwmhCtx m => Connection -> WINDOW -> Word32 -> m ()+setNetWmDesktop c w = setProp c w NET_WM_DESKTOP AtomCARDINAL++requestNetWmDesktop ::EwmhCtx m => Connection -> WINDOW -> NetWmDesktop -> m ()+requestNetWmDesktop c w d = sendRequest c w NET_WM_DESKTOP [desktop, source]+ where+ desktop = netWmDesktop_new_desktop d+ source = X.toValue $ netWmDesktop_source_indication d++getNetWmWindowType :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [NET_WM_WINDOW_TYPE])+getNetWmWindowType c w = runExceptT $ do+ getProp c w NET_WM_WINDOW_TYPE AtomATOM+ >>= eitherToExcept+ >>= fmap (catMaybes . map fromAtom . catMaybes) . mapM lookupAtomId++setNetWmWindowType :: EwmhCtx m => Connection -> WINDOW -> [NET_WM_WINDOW_TYPE] -> m ()+setNetWmWindowType c w vs = do+ mapM unsafeLookupATOM vs >>= setProp c w NET_WM_WINDOW_TYPE AtomATOM++getNetWmState :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [NET_WM_STATE])+getNetWmState c w = runExceptT $ do+ getProp c w NET_WM_STATE AtomATOM+ >>= eitherToExcept+ >>= fmap (catMaybes . map fromAtom . catMaybes) . mapM lookupAtomId++setNetWmState :: EwmhCtx m => Connection -> WINDOW -> [NET_WM_STATE] -> m ()+setNetWmState c w vs = mapM unsafeLookupATOM vs >>= setProp c w NET_WM_STATE AtomATOM++requestNetWmState :: EwmhCtx m => Connection -> WINDOW -> NetWmState -> m ()+requestNetWmState c w v = do+ a1 <- p1+ a2 <- p2+ sendRequest c w NET_WM_STATE ([action, a1, a2, source] :: [Word32])+ where+ action = X.toValue . netWmState_action $ v+ source = X.toValue . netWmState_source_indication $ v+ p1 = fmap (X.fromXid . X.toXid) $ unsafeLookupATOM $ netWmState_first_property v+ p2 = case netWmState_second_property v of+ Nothing -> return 0+ Just n -> fmap (X.fromXid . X.toXid) $ unsafeLookupATOM n++getNetWmAllowedActions :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError [NET_WM_ALLOWED_ACTIONS])+getNetWmAllowedActions c w = runExceptT $ do+ getProp c w NET_WM_ALLOWED_ACTIONS AtomATOM+ >>= eitherToExcept+ >>= fmap (catMaybes . map fromAtom . catMaybes) . mapM lookupAtomId++setNetWmAllowedActions :: EwmhCtx m => Connection -> WINDOW -> [NET_WM_ALLOWED_ACTIONS] -> m ()+setNetWmAllowedActions c w vs = mapM unsafeLookupATOM vs >>= setProp c w NET_WM_ALLOWED_ACTIONS AtomATOM++getNetWmStrut :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError NetWmStrut)+getNetWmStrut c w = getProp c w NET_WM_STRUT AtomCARDINAL++setNetWmStrut :: EwmhCtx m => Connection -> WINDOW -> NetWmStrut -> m ()+setNetWmStrut c w = setProp c w NET_WM_STRUT AtomCARDINAL++getNetWmStrutPartial :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError NetWmStrutPartial)+getNetWmStrutPartial c w = getProp c w NET_WM_STRUT_PARTIAL AtomCARDINAL++setNetWmStrutPartial :: EwmhCtx m => Connection -> WINDOW -> NetWmStrutPartial -> m ()+setNetWmStrutPartial c w = setProp c w NET_WM_STRUT_PARTIAL AtomCARDINAL++getNetWmIconGeometry :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError NetWmIconGeometry)+getNetWmIconGeometry c w = getProp c w NET_WM_ICON_GEOMETRY AtomCARDINAL++setNetWmIconGeometry :: EwmhCtx m => Connection -> WINDOW -> NetWmIconGeometry -> m ()+setNetWmIconGeometry c w = setProp c w NET_WM_ICON_GEOMETRY AtomCARDINAL++getNetWmIcon :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError NetWmIcon)+getNetWmIcon c w = getProp c w NET_WM_ICON AtomCARDINAL++setNetWmIcon :: EwmhCtx m => Connection -> WINDOW -> NetWmIcon -> m ()+setNetWmIcon c w = setProp c w NET_WM_ICON AtomCARDINAL++getNetWmPID :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError Word32)+getNetWmPID c w = getProp c w NET_WM_PID AtomCARDINAL++setNetWmPID :: EwmhCtx m => Connection -> WINDOW -> Word32 -> m ()+setNetWmPID c w = setProp c w NET_WM_PID AtomCARDINAL++getNetWmHandledIcons :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError Word32)+getNetWmHandledIcons c w = getProp c w NET_WM_HANDLED_ICONS AtomCARDINAL++setNetWmHandledIcons :: EwmhCtx m => Connection -> WINDOW -> Word32 -> m ()+setNetWmHandledIcons c w = setProp c w NET_WM_HANDLED_ICONS AtomCARDINAL++getNetWmUserTime :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError Word32)+getNetWmUserTime c w = getProp c w NET_WM_USER_TIME AtomCARDINAL++setNetWmUserTime :: EwmhCtx m => Connection -> WINDOW -> Word32 -> m ()+setNetWmUserTime c w = setProp c w NET_WM_USER_TIME AtomCARDINAL++getNetWmUserTimeWindow :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError WINDOW)+getNetWmUserTimeWindow c w = getProp c w NET_WM_USER_TIME_WINDOW AtomWINDOW++setNetWmUserTimeWindow :: EwmhCtx m => Connection -> WINDOW -> WINDOW -> m ()+setNetWmUserTimeWindow c w = setProp c w NET_WM_USER_TIME_WINDOW AtomWINDOW++getNetFrameExtents :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError NetFrameExtents)+getNetFrameExtents c w = getProp c w NET_FRAME_EXTENTS AtomCARDINAL++setNetFrameExtents :: EwmhCtx m => Connection -> WINDOW -> NetFrameExtents -> m ()+setNetFrameExtents c w = setProp c w NET_FRAME_EXTENTS AtomCARDINAL++getNetWmOpaqueRegion :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError NetWmOpaqueRegion)+getNetWmOpaqueRegion c w = getProp c w NET_WM_OPAQUE_REGION AtomCARDINAL++setNetWmOpaqueRegion :: EwmhCtx m => Connection -> WINDOW -> NetWmOpaqueRegion -> m ()+setNetWmOpaqueRegion c w = setProp c w NET_WM_OPAQUE_REGION AtomCARDINAL++getNetWmBypassCompositor :: EwmhCtx m => Connection -> WINDOW -> m (Either SomeError Word32)+getNetWmBypassCompositor c w = getProp c w NET_WM_BYPASS_COMPOSITOR AtomCARDINAL++setNetWmBypassCompositor :: EwmhCtx m => Connection -> WINDOW -> Word32 -> m ()+setNetWmBypassCompositor c w = setProp c w NET_WM_BYPASS_COMPOSITOR AtomCARDINAL++requestNetWmPing :: EwmhCtx m => Connection -> WINDOW -> m ()+requestNetWmPing c w = do+ unsafeLookupATOM NET_WM_PING >>= sendRequest c w WM_PROTOCOLS . values+ where values a = [ X.fromXid (X.toXid a)+ , X.toValue TimeCurrentTime+ , X.fromXid (X.toXid w)+ ] :: [Word32]++requestNetWmSyncRequest :: EwmhCtx m => Connection -> WINDOW -> NetWmSyncRequest -> m ()+requestNetWmSyncRequest c w sr = do+ unsafeLookupATOM NET_WM_SYNC_REQUEST >>= sendRequest c w WM_PROTOCOLS . values+ where values a = [ X.fromXid (X.toXid a)+ , X.toValue TimeCurrentTime+ , netWmSyncRequest_low sr+ , netWmSyncRequest_high sr+ ]++requestNetWmFullscreenMonitors :: EwmhCtx m+ => Connection -> WINDOW -> NetWmFullscreenMonitors -> m ()+requestNetWmFullscreenMonitors c w v = do+ sendRequest c w NET_WM_FULLSCREEN_MONITORS [top, bottom, left, right, source]+ where+ top = netWmFullscreenMonitors_top v+ bottom = netWmFullscreenMonitors_bottom v+ left = netWmFullscreenMonitors_left v+ right = netWmFullscreenMonitors_right v+ source = X.toValue . netWmFullscreenMonitors_source_indication $ v
+ src/Graphics/XHB/Ewmh/Atoms.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Graphics.XHB.Ewmh.Atoms where++import Data.Typeable (Typeable)+import Data.Hashable (Hashable(..))+import Graphics.XHB.AtomCache++data UTF8_STRING = UTF8_STRING+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Hashable UTF8_STRING where+ hashWithSalt s = hashWithSalt s . show++instance AtomLike UTF8_STRING where+ toAtomName = show++data EWMH_ATOM =+ -- Root Window Properties+ NET_SUPPORTED+ | NET_CLIENT_LIST+ | NET_CLIENT_LIST_STACKING+ | NET_NUMBER_OF_DESKTOPS+ | NET_DESKTOP_GEOMETRY+ | NET_DESKTOP_VIEWPORT+ | NET_CURRENT_DESKTOP+ | NET_DESKTOP_NAMES+ | NET_ACTIVE_WINDOW+ | NET_WORKAREA+ | NET_SUPPORTING_WM_CHECK+ | NET_VIRTUAL_ROOTS+ | NET_DESKTOP_LAYOUT+ | NET_SHOWING_DESKTOP++ -- Other Root Window Messages+ | NET_CLOSE_WINDOW+ | NET_MOVERESIZE_WINDOW+ | NET_WM_MOVERESIZE+ | NET_RESTACK_WINDOW+ | NET_REQUEST_FRAME_EXTENTS++ -- Application Window Property+ | NET_WM_NAME+ | NET_WM_VISIBLE_NAME+ | NET_WM_ICON_NAME+ | NET_WM_VISIBLE_ICON_NAME+ | NET_WM_DESKTOP+ | NET_WM_WINDOW_TYPE+ | NET_WM_STATE+ | NET_WM_ALLOWED_ACTIONS+ | NET_WM_STRUT+ | NET_WM_STRUT_PARTIAL+ | NET_WM_ICON_GEOMETRY+ | NET_WM_ICON+ | NET_WM_PID+ | NET_WM_HANDLED_ICONS+ | NET_WM_USER_TIME+ | NET_WM_USER_TIME_WINDOW+ | NET_FRAME_EXTENTS+ | NET_WM_OPAQUE_REGION+ | NET_WM_BYPASS_COMPOSITOR++ -- Window Manager Protocols+ | WM_PROTOCOLS+ | NET_WM_PING+ | NET_WM_SYNC_REQUEST+ | NET_WM_SYNC_REQUEST_COUNTER+ | NET_WM_FULLSCREEN_MONITORS++ -- Other Properties+ | NET_WM_FULL_PLACEMENT++ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Hashable EWMH_ATOM where+ hashWithSalt s = hashWithSalt s . show++instance AtomLike EWMH_ATOM where+ toAtomName a = '_' : show a++data NET_WM_WINDOW_TYPE =+ NET_WM_WINDOW_TYPE_DESKTOP+ | NET_WM_WINDOW_TYPE_DOCK+ | NET_WM_WINDOW_TYPE_TOOLBAR+ | NET_WM_WINDOW_TYPE_MENU+ | NET_WM_WINDOW_TYPE_UTILITY+ | NET_WM_WINDOW_TYPE_SPLASH+ | NET_WM_WINDOW_TYPE_DIALOG+ | NET_WM_WINDOW_TYPE_DROPDOWN_MENU+ | NET_WM_WINDOW_TYPE_POPUP_MENU+ | NET_WM_WINDOW_TYPE_TOOLTIP+ | NET_WM_WINDOW_TYPE_NOTIFICATION+ | NET_WM_WINDOW_TYPE_COMBO+ | NET_WM_WINDOW_TYPE_DND+ | NET_WM_WINDOW_TYPE_NORMAL+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Hashable NET_WM_WINDOW_TYPE where+ hashWithSalt s = hashWithSalt s . show++instance AtomLike NET_WM_WINDOW_TYPE where+ toAtomName a = '_' : show a++data NET_WM_STATE =+ NET_WM_STATE_MODAL+ | NET_WM_STATE_STICKY+ | NET_WM_STATE_MAXIMIZED_VERT+ | NET_WM_STATE_MAXIMIZED_HORZ+ | NET_WM_STATE_SHADED+ | NET_WM_STATE_SKIP_TASKBAR+ | NET_WM_STATE_SKIP_PAGER+ | NET_WM_STATE_HIDDEN+ | NET_WM_STATE_FULLSCREEN+ | NET_WM_STATE_ABOVE+ | NET_WM_STATE_BELOW+ | NET_WM_STATE_DEMANDS_ATTENTION+ | NET_WM_STATE_FOCUSED+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Hashable NET_WM_STATE where+ hashWithSalt s = hashWithSalt s . show++instance AtomLike NET_WM_STATE where+ toAtomName a = '_' : show a++data NET_WM_ALLOWED_ACTIONS =+ NET_WM_ACTION_MOVE+ | NET_WM_ACTION_RESIZE+ | NET_WM_ACTION_MINIMIZE+ | NET_WM_ACTION_SHADE+ | NET_WM_ACTION_STICK+ | NET_WM_ACTION_MAXIMIZE_HORZ+ | NET_WM_ACTION_MAXIMIZE_VERT+ | NET_WM_ACTION_FULLSCREEN+ | NET_WM_ACTION_CHANGE_DESKTOP+ | NET_WM_ACTION_CLOSE+ | NET_WM_ACTION_ABOVE+ | NET_WM_ACTION_BELOW+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Hashable NET_WM_ALLOWED_ACTIONS where+ hashWithSalt s = hashWithSalt s . show++instance AtomLike NET_WM_ALLOWED_ACTIONS where+ toAtomName a = '_' : show a
+ src/Graphics/XHB/Ewmh/Types.hs view
@@ -0,0 +1,359 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}++module Graphics.XHB.Ewmh.Types where++import Control.Applicative (Applicative, (<$>), (<*>))+import Control.Monad (replicateM)+import Control.Monad.IO.Class (MonadIO)+import Data.Typeable (Typeable)+import Data.Word (Word8, Word32)+import Graphics.XHB (ButtonIndex(..), StackMode(..), WINDOW)+import Graphics.XHB.AtomCache+import Graphics.XHB.Ewmh.Atoms+import Graphics.XHB.Ewmh.Serialize+import Graphics.XHB.Ewmh.Values++type EwmhT = AtomCacheT++type EwmhCtx m = (Applicative m, MonadIO m, AtomCacheCtx m)++data NetSupported = NetSupported+ { ewmhAtoms :: [EWMH_ATOM]+ , netWmStates :: [NET_WM_STATE]+ , netWmAllowedActions :: [NET_WM_ALLOWED_ACTIONS]+ , netWmWindowTypes :: [NET_WM_WINDOW_TYPE]+ }+ deriving (Eq, Ord, Read, Show, Typeable)++data NetDesktopGeometry = NetDesktopGeometry+ { netDesktopGeometry_width :: Word32+ , netDesktopGeometry_height :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetDesktopGeometry where+ serialize v = mapM_ ($ v) [ serialize . netDesktopGeometry_width+ , serialize . netDesktopGeometry_height+ ]+ deserialize = NetDesktopGeometry <$> deserialize <*> deserialize++data Viewport = Viewport+ { viewport_x :: Word32+ , viewport_y :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize Viewport where+ serialize v = mapM_ ($ v) [ serialize . viewport_x+ , serialize . viewport_y+ ]+ deserialize = Viewport <$> deserialize <*> deserialize++data NetDesktopViewport = NetDesktopViewport+ { netDesktopViewport_viewports :: [Viewport]+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetDesktopViewport where+ serialize = serialize . netDesktopViewport_viewports+ deserialize = NetDesktopViewport <$> deserialize++data NetActiveWindow = NetActiveWindow+ { netActiveWindow_source_indication :: SourceIndication+ , netActiveWindow_currently_active_window :: Maybe WINDOW+ }+ deriving (Eq, Ord, Show, Typeable)++data Workarea = Workarea+ { workarea_x :: Word32+ , workarea_y :: Word32+ , workarea_width :: Word32+ , workarea_height :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize Workarea where+ serialize v = mapM_ ($ v) [ serialize . workarea_x+ , serialize . workarea_y+ , serialize . workarea_width+ , serialize . workarea_height+ ]+ deserialize = Workarea <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWorkarea = NetWorkarea+ { netWorkarea_workareas :: [Workarea]+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWorkarea where+ serialize = serialize . netWorkarea_workareas+ deserialize = NetWorkarea <$> deserialize++data NetDesktopLayout = NetDesktopLayout+ { orientation :: NET_DESKTOP_LAYOUT_ORIENTATION+ , starting_corner :: NET_DESKTOP_LAYOUT_STARTING_CORNER+ , columns :: Word32+ , rows :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetDesktopLayout where+ serialize (NetDesktopLayout o s c r) = do+ serialize o+ serialize c+ serialize r+ serialize s++ deserialize = do+ o <- deserialize+ c <- deserialize+ r <- deserialize+ s <- deserialize+ return $ NetDesktopLayout o s c r++data NetMoveresizeWindow = NetMoveresizeWindow+ { netMoveresizeWindow_source_indication :: SourceIndication+ , netMoveresizeWindow_gravity :: Gravity+ , netMoveresizeWindow_x :: Maybe Int+ , netMoveresizeWindow_y :: Maybe Int+ , netMoveresizeWindow_width :: Maybe Word32+ , netMoveresizeWindow_height :: Maybe Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++-- TODO: push to xhb package+deriving instance Eq ButtonIndex+deriving instance Ord ButtonIndex+deriving instance Read ButtonIndex++data NetWmMoveresize = NetWmMoveresize+ { netWmMoveresize_x_root :: Maybe Int+ , netWmMoveresize_y_root :: Maybe Int+ , netWmMoveresize_direction :: NET_WM_MOVERESIZE_DIRECTION+ , netWmMoveresize_button :: ButtonIndex+ , netWmMoveresize_source_indication :: SourceIndication+ }+ deriving (Eq, Ord, Read, Show, Typeable)++-- TODO: push to xhb package+deriving instance Eq StackMode+deriving instance Ord StackMode+deriving instance Read StackMode++-- no Read because there's no Read instance for WINDOW+data NetRestackWindow = NetRestackWindow+ { netRestackWindow_source_indication :: SourceIndication+ , netRestackWindow_sibling_window :: WINDOW+ , netRestackWindow_detail :: StackMode+ }+ deriving (Eq, Ord, Show, Typeable)++data NetWmDesktop = NetWmDesktop+ { netWmDesktop_new_desktop :: Word32+ , netWmDesktop_source_indication :: SourceIndication+ }+ deriving (Eq, Ord, Read, Show, Typeable)++data NetWmState = NetWmState+ { netWmState_action :: NET_WM_STATE_ACTION+ , netWmState_first_property :: NET_WM_STATE+ , netWmState_second_property :: Maybe NET_WM_STATE+ , netWmState_source_indication :: SourceIndication+ }+ deriving (Eq, Ord, Read, Show, Typeable)++data NetWmStrut = NetWmStrut+ { netWmStrut_left :: Word32+ , netWmStrut_right :: Word32+ , netWmStrut_top :: Word32+ , netWmStrut_bottom :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWmStrut where+ serialize v = mapM_ ($ v) [ serialize . netWmStrut_left+ , serialize . netWmStrut_right+ , serialize . netWmStrut_top+ , serialize . netWmStrut_bottom+ ]++ deserialize = NetWmStrut <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWmStrutPartial = NetWmStrutPartial+ { netWmStrutPartial_left :: Word32+ , netWmStrutPartial_right :: Word32+ , netWmStrutPartial_top :: Word32+ , netWmStrutPartial_bottom :: Word32+ , netWmStrutPartial_left_start_y :: Word32+ , netWmStrutPartial_left_end_y :: Word32+ , netWmStrutPartial_right_start_y :: Word32+ , netWmStrutPartial_right_end_y :: Word32+ , netWmStrutPartial_top_start_x :: Word32+ , netWmStrutPartial_top_end_x :: Word32+ , netWmStrutPartial_bottom_start_x :: Word32+ , netWmStrutPartial_bottom_end_x :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWmStrutPartial where+ serialize v = mapM_ ($ v) [ serialize . netWmStrutPartial_left+ , serialize . netWmStrutPartial_right+ , serialize . netWmStrutPartial_top+ , serialize . netWmStrutPartial_bottom+ , serialize . netWmStrutPartial_left_start_y+ , serialize . netWmStrutPartial_left_end_y+ , serialize . netWmStrutPartial_right_start_y+ , serialize . netWmStrutPartial_right_end_y+ , serialize . netWmStrutPartial_top_start_x+ , serialize . netWmStrutPartial_top_end_x+ , serialize . netWmStrutPartial_bottom_start_x+ , serialize . netWmStrutPartial_bottom_end_x+ ]++ deserialize = NetWmStrutPartial <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWmIconGeometry = NetWmIconGeometry+ { netWmIconGeometry_x :: Word32+ , netWmIconGeometry_y :: Word32+ , netWmIconGeometry_width :: Word32+ , netWmIconGeometry_height :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWmIconGeometry where+ serialize v = mapM_ ($ v) [ serialize . netWmIconGeometry_x+ , serialize . netWmIconGeometry_y+ , serialize . netWmIconGeometry_width+ , serialize . netWmIconGeometry_height+ ]++ deserialize = NetWmIconGeometry <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWmIconData = NetWmIconData+ { netWmIconData_a :: Word8+ , netWmIconData_r :: Word8+ , netWmIconData_g :: Word8+ , netWmIconData_b :: Word8+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWmIconData where+ serialize v = mapM_ ($ v) [ serialize . netWmIconData_a+ , serialize . netWmIconData_r+ , serialize . netWmIconData_g+ , serialize . netWmIconData_b+ ]++ deserialize = NetWmIconData <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWmIcon = NetWmIcon+ { netWmIcon_width :: Word32+ , netWmIcon_height :: Word32+ , netWmIcon_data :: [[NetWmIconData]]+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWmIcon where+ serialize v = mapM_ ($ v) [ serialize . netWmIcon_width+ , serialize . netWmIcon_height+ , serialize . netWmIcon_data+ ]++ deserialize = do+ width <- deserialize+ height <- deserialize+ NetWmIcon width height <$>+ replicateM (fromIntegral height)+ (replicateM (fromIntegral width) deserialize)++netWmIconToPPM :: NetWmIcon -> String+netWmIconToPPM (NetWmIcon w h d) =+ "P3\n"+ ++ show w ++ " " ++ show h ++ "\n"+ ++ "255\n"+ ++ unlines (map (unwords . map conv) d)+ where+ conv (NetWmIconData _ r g b) = show r ++ " " ++ show g ++ " " ++ show b++data NetFrameExtents = NetFrameExtents+ { netFrameExtents_left :: Word32+ , netFrameExtents_right :: Word32+ , netFrameExtents_top :: Word32+ , netFrameExtents_bottom :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetFrameExtents where+ serialize v = mapM_ ($ v) [ serialize . netFrameExtents_left+ , serialize . netFrameExtents_right+ , serialize . netFrameExtents_top+ , serialize . netFrameExtents_bottom+ ]++ deserialize = NetFrameExtents <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWmOpaqueRegion = NetWmOpaqueRegion+ { netWmOpaqueRegion_x :: Word32+ , netWmOpaqueRegion_y :: Word32+ , netWmOpaqueRegion_width :: Word32+ , netWmOpaqueRegion_height :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++instance Serialize NetWmOpaqueRegion where+ serialize v = mapM_ ($ v) [ serialize . netWmOpaqueRegion_x+ , serialize . netWmOpaqueRegion_y+ , serialize . netWmOpaqueRegion_width+ , serialize . netWmOpaqueRegion_height+ ]++ deserialize = NetWmOpaqueRegion <$> deserialize+ <*> deserialize+ <*> deserialize+ <*> deserialize++data NetWmSyncRequest = NetWmSyncRequest+ { netWmSyncRequest_low :: Word32+ , netWmSyncRequest_high :: Word32+ }+ deriving (Eq, Ord, Read, Show, Typeable)++data NetWmFullscreenMonitors = NetWmFullscreenMonitors+ { netWmFullscreenMonitors_top :: Word32+ , netWmFullscreenMonitors_bottom :: Word32+ , netWmFullscreenMonitors_left :: Word32+ , netWmFullscreenMonitors_right :: Word32+ , netWmFullscreenMonitors_source_indication :: SourceIndication+ }+ deriving (Eq, Ord, Read, Show, Typeable)
+ src/Graphics/XHB/Ewmh/Values.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Graphics.XHB.Ewmh.Values where++import Data.Typeable (Typeable)+import Data.Binary.Get (getWord32host)+import Data.Binary.Put (putWord32host)+import Graphics.XHB (SimpleEnum(..))+import Graphics.XHB.Ewmh.Serialize++data Gravity = WinGravity+ | NorthWest+ | North+ | NorthEast+ | West+ | Center+ | East+ | SouthWest+ | South+ | SouthEast+ | Static+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance SimpleEnum Gravity where+ toValue v = case v of+ WinGravity -> 0+ NorthWest -> 1+ North -> 2+ NorthEast -> 3+ West -> 4+ Center -> 5+ East -> 6+ SouthWest -> 7+ South -> 8+ SouthEast -> 9+ Static -> 10++ fromValue v = case v of+ 0 -> WinGravity+ 1 -> NorthWest+ 2 -> North+ 3 -> NorthEast+ 4 -> West+ 5 -> Center+ 6 -> East+ 7 -> SouthWest+ 8 -> South+ 9 -> SouthEast+ 10 -> Static+ _ -> error "Gravity: no such value"++data SourceIndication = SourceNone+ | SourceApplication+ | SourcePager+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance SimpleEnum SourceIndication where+ toValue v = case v of+ SourceNone -> 0+ SourceApplication -> 1+ SourcePager -> 2++ fromValue v = case v of+ 0 -> SourceNone+ 1 -> SourceApplication+ 2 -> SourcePager+ _ -> error "SourceIndication: no such value"++data NET_DESKTOP_LAYOUT_ORIENTATION = NET_WM_ORIENTATION_HORZ+ | NET_WM_ORIENTATION_VERT+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Serialize NET_DESKTOP_LAYOUT_ORIENTATION where+ serialize = putWord32host . toValue+ deserialize = fmap fromValue getWord32host++instance SimpleEnum NET_DESKTOP_LAYOUT_ORIENTATION where+ toValue v = case v of+ NET_WM_ORIENTATION_HORZ -> 0+ NET_WM_ORIENTATION_VERT -> 1++ fromValue v = case v of+ 0 -> NET_WM_ORIENTATION_HORZ+ 1 -> NET_WM_ORIENTATION_VERT+ _ -> error "NET_DESKTOP_LAYOUT_ORIENTATION: no such value"++data NET_DESKTOP_LAYOUT_STARTING_CORNER = NET_WM_TOPLEFT+ | NET_WM_TOPRIGHT+ | NET_WM_BOTTOMRIGHT+ | NET_WM_BOTTOMLEFT+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance Serialize NET_DESKTOP_LAYOUT_STARTING_CORNER where+ serialize = putWord32host . toValue+ deserialize = fmap fromValue getWord32host++instance SimpleEnum NET_DESKTOP_LAYOUT_STARTING_CORNER where+ toValue v = case v of+ NET_WM_TOPLEFT -> 0+ NET_WM_TOPRIGHT -> 1+ NET_WM_BOTTOMRIGHT -> 2+ NET_WM_BOTTOMLEFT -> 3++ fromValue v = case v of+ 0 -> NET_WM_TOPLEFT+ 1 -> NET_WM_TOPRIGHT+ 2 -> NET_WM_BOTTOMRIGHT+ 3 -> NET_WM_BOTTOMLEFT+ _ -> error "NET_DESKTOP_LAYOUT_STARTING_CORNER: no such value"++data NET_WM_MOVERESIZE_DIRECTION = NET_WM_MOVERESIZE_SIZE_TOPLEFT+ | NET_WM_MOVERESIZE_SIZE_TOP+ | NET_WM_MOVERESIZE_SIZE_TOPRIGHT+ | NET_WM_MOVERESIZE_SIZE_RIGHT+ | NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT+ | NET_WM_MOVERESIZE_SIZE_BOTTOM+ | NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT+ | NET_WM_MOVERESIZE_SIZE_LEFT+ | NET_WM_MOVERESIZE_MOVE+ | NET_WM_MOVERESIZE_SIZE_KEYBOARD+ | NET_WM_MOVERESIZE_MOVE_KEYBOARD+ | NET_WM_MOVERESIZE_CANCEL+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance SimpleEnum NET_WM_MOVERESIZE_DIRECTION where+ toValue v = case v of+ NET_WM_MOVERESIZE_SIZE_TOPLEFT -> 0+ NET_WM_MOVERESIZE_SIZE_TOP -> 1+ NET_WM_MOVERESIZE_SIZE_TOPRIGHT -> 2+ NET_WM_MOVERESIZE_SIZE_RIGHT -> 3+ NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT -> 4+ NET_WM_MOVERESIZE_SIZE_BOTTOM -> 5+ NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT -> 6+ NET_WM_MOVERESIZE_SIZE_LEFT -> 7+ NET_WM_MOVERESIZE_MOVE -> 8+ NET_WM_MOVERESIZE_SIZE_KEYBOARD -> 9+ NET_WM_MOVERESIZE_MOVE_KEYBOARD -> 10+ NET_WM_MOVERESIZE_CANCEL -> 11++ fromValue v = case v of+ 0 -> NET_WM_MOVERESIZE_SIZE_TOPLEFT+ 1 -> NET_WM_MOVERESIZE_SIZE_TOP+ 2 -> NET_WM_MOVERESIZE_SIZE_TOPRIGHT+ 3 -> NET_WM_MOVERESIZE_SIZE_RIGHT+ 4 -> NET_WM_MOVERESIZE_SIZE_BOTTOMRIGHT+ 5 -> NET_WM_MOVERESIZE_SIZE_BOTTOM+ 6 -> NET_WM_MOVERESIZE_SIZE_BOTTOMLEFT+ 7 -> NET_WM_MOVERESIZE_SIZE_LEFT+ 8 -> NET_WM_MOVERESIZE_MOVE+ 9 -> NET_WM_MOVERESIZE_SIZE_KEYBOARD+ 10 -> NET_WM_MOVERESIZE_MOVE_KEYBOARD+ 11 -> NET_WM_MOVERESIZE_CANCEL+ _ -> error "NET_WM_MOVERESIZE_DIRECTION: no such value"++data NET_WM_STATE_ACTION = NET_WM_STATE_REMOVE+ | NET_WM_STATE_ADD+ | NET_WM_STATE_TOGGLE+ deriving (Enum, Eq, Ord, Read, Show, Typeable)++instance SimpleEnum NET_WM_STATE_ACTION where+ toValue v = case v of+ NET_WM_STATE_REMOVE -> 0+ NET_WM_STATE_ADD -> 1+ NET_WM_STATE_TOGGLE -> 2++ fromValue v = case v of+ 0 -> NET_WM_STATE_REMOVE+ 1 -> NET_WM_STATE_ADD+ 2 -> NET_WM_STATE_TOGGLE+ _ -> error "NET_WM_STATE_ACTION: no such value"
+ xhb-ewmh.cabal view
@@ -0,0 +1,44 @@+name: xhb-ewmh+version: 0.1.0.0+synopsis: EWMH utilities for XHB+description: EWMH utilities for XHB+license: BSD2+license-file: LICENSE+author: Jochen Keil+maintainer: Jochen Keil <jochen.keil+xhb-ewmh@gmail.com>+homepage: http://github.com/jotrk/xhb-ewmh/+bug-reports: http://github.com/jotrk/xhb-ewmh/issues++category: Graphics+build-type: Simple++cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/jotrk/xhb-ewmh.git++library+ build-depends: base >= 4.7 && < 4.8,+ binary >= 0.7 && < 0.8,+ bytestring >= 0.10 && < 0.11,+ dlist >= 0.7 && < 0.8,+ hashable >= 1.2 && < 1.3,+ mtl >= 2.2 && < 3.0,+ transformers >= 0.4 && < 0.5,+ xhb >= 0.5 && < 0.6,+ xhb-atom-cache++ exposed-modules: Graphics.XHB.Ewmh,+ Graphics.XHB.Ewmh.Atoms,+ Graphics.XHB.Ewmh.Types,+ Graphics.XHB.Ewmh.Values++ other-extensions: DeriveDataTypeable,+ FlexibleContexts,+ FlexibleInstances,+ OverlappingInstances++ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src