diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Graphics/XHB/Ewmh.hs b/src/Graphics/XHB/Ewmh.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/XHB/Ewmh.hs @@ -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 diff --git a/src/Graphics/XHB/Ewmh/Atoms.hs b/src/Graphics/XHB/Ewmh/Atoms.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/XHB/Ewmh/Atoms.hs @@ -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 diff --git a/src/Graphics/XHB/Ewmh/Types.hs b/src/Graphics/XHB/Ewmh/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/XHB/Ewmh/Types.hs @@ -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) diff --git a/src/Graphics/XHB/Ewmh/Values.hs b/src/Graphics/XHB/Ewmh/Values.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/XHB/Ewmh/Values.hs @@ -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" diff --git a/xhb-ewmh.cabal b/xhb-ewmh.cabal new file mode 100644 --- /dev/null +++ b/xhb-ewmh.cabal @@ -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 +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