-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.EWMHDesktopInfo
-- Copyright   : (c) José A. Romero L.
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : José A. Romero L. <escherdragon@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Functions to access data provided by the X11 desktop via EWHM hints. This
-- module requires that the EwmhDesktops hook from the XMonadContrib project
-- be installed in your @~\/.xmonad\/xmonad.hs@ configuration:
--
-- > import XMonad
-- > import XMonad.Hooks.EwmhDesktops (ewmh)
-- >
-- > main = xmonad $ ewmh $ ...
--
-----------------------------------------------------------------------------

module System.Taffybar.Information.EWMHDesktopInfo
  ( EWMHIcon(..)
  , EWMHIconData
  , WorkspaceId(..)
  , X11Window
  , allEWMHProperties
  , ewmhActiveWindow
  , ewmhClientList
  , ewmhClientListStacking
  , ewmhCurrentDesktop
  , ewmhDesktopNames
  , ewmhNumberOfDesktops
  , ewmhStateHidden
  , ewmhWMClass
  , ewmhWMDesktop
  , ewmhWMIcon
  , ewmhWMName
  , ewmhWMName2
  , ewmhWMState
  , ewmhWMStateHidden
  , focusWindow
  , getActiveWindow
  , getCurrentWorkspace
  , getVisibleWorkspaces
  , getWindowClass
  , getWindowIconsData
  , getWindowMinimized
  , getWindowState
  , getWindowStateProperty
  , getWindowTitle
  , getWindows
  , getWindowsStacking
  , getWorkspace
  , getWorkspaceNames
  , isWindowUrgent
  , parseWindowClasses
  , switchOneWorkspace
  , switchToWorkspace
  , withX11Context
  , withEWMHIcons
  ) where

import Control.Monad ((>=>))
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Tuple
import Data.Word
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import System.Log.Logger
import System.Taffybar.Information.SafeX11
import System.Taffybar.Information.X11DesktopInfo

logHere :: MonadIO m => Priority -> String -> m ()
logHere :: forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logHere Priority
p = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Information.EWMHDesktopInfo" Priority
p

newtype WorkspaceId = WorkspaceId Int deriving (Int -> WorkspaceId -> ShowS
[WorkspaceId] -> ShowS
WorkspaceId -> String
(Int -> WorkspaceId -> ShowS)
-> (WorkspaceId -> String)
-> ([WorkspaceId] -> ShowS)
-> Show WorkspaceId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorkspaceId -> ShowS
showsPrec :: Int -> WorkspaceId -> ShowS
$cshow :: WorkspaceId -> String
show :: WorkspaceId -> String
$cshowList :: [WorkspaceId] -> ShowS
showList :: [WorkspaceId] -> ShowS
Show, ReadPrec [WorkspaceId]
ReadPrec WorkspaceId
Int -> ReadS WorkspaceId
ReadS [WorkspaceId]
(Int -> ReadS WorkspaceId)
-> ReadS [WorkspaceId]
-> ReadPrec WorkspaceId
-> ReadPrec [WorkspaceId]
-> Read WorkspaceId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS WorkspaceId
readsPrec :: Int -> ReadS WorkspaceId
$creadList :: ReadS [WorkspaceId]
readList :: ReadS [WorkspaceId]
$creadPrec :: ReadPrec WorkspaceId
readPrec :: ReadPrec WorkspaceId
$creadListPrec :: ReadPrec [WorkspaceId]
readListPrec :: ReadPrec [WorkspaceId]
Read, Eq WorkspaceId
Eq WorkspaceId =>
(WorkspaceId -> WorkspaceId -> Ordering)
-> (WorkspaceId -> WorkspaceId -> Bool)
-> (WorkspaceId -> WorkspaceId -> Bool)
-> (WorkspaceId -> WorkspaceId -> Bool)
-> (WorkspaceId -> WorkspaceId -> Bool)
-> (WorkspaceId -> WorkspaceId -> WorkspaceId)
-> (WorkspaceId -> WorkspaceId -> WorkspaceId)
-> Ord WorkspaceId
WorkspaceId -> WorkspaceId -> Bool
WorkspaceId -> WorkspaceId -> Ordering
WorkspaceId -> WorkspaceId -> WorkspaceId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WorkspaceId -> WorkspaceId -> Ordering
compare :: WorkspaceId -> WorkspaceId -> Ordering
$c< :: WorkspaceId -> WorkspaceId -> Bool
< :: WorkspaceId -> WorkspaceId -> Bool
$c<= :: WorkspaceId -> WorkspaceId -> Bool
<= :: WorkspaceId -> WorkspaceId -> Bool
$c> :: WorkspaceId -> WorkspaceId -> Bool
> :: WorkspaceId -> WorkspaceId -> Bool
$c>= :: WorkspaceId -> WorkspaceId -> Bool
>= :: WorkspaceId -> WorkspaceId -> Bool
$cmax :: WorkspaceId -> WorkspaceId -> WorkspaceId
max :: WorkspaceId -> WorkspaceId -> WorkspaceId
$cmin :: WorkspaceId -> WorkspaceId -> WorkspaceId
min :: WorkspaceId -> WorkspaceId -> WorkspaceId
Ord, WorkspaceId -> WorkspaceId -> Bool
(WorkspaceId -> WorkspaceId -> Bool)
-> (WorkspaceId -> WorkspaceId -> Bool) -> Eq WorkspaceId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorkspaceId -> WorkspaceId -> Bool
== :: WorkspaceId -> WorkspaceId -> Bool
$c/= :: WorkspaceId -> WorkspaceId -> Bool
/= :: WorkspaceId -> WorkspaceId -> Bool
Eq)

-- A super annoying detail of the XGetWindowProperty interface is that: "If the
-- returned format is 32, the returned data is represented as a long array and
-- should be cast to that type to obtain the elements." This means that even
-- though only the 4 least significant bits will ever contain any data, the
-- array that is returned from X11 can have a larger word size. This means that
-- we need to manipulate the underlying data in annoying ways to pass it to gtk
-- appropriately.
type PixelsWordType = Word64

type EWMHProperty = String

ewmhActiveWindow, ewmhClientList, ewmhClientListStacking, ewmhCurrentDesktop, ewmhDesktopNames, ewmhNumberOfDesktops, ewmhStateHidden, ewmhWMDesktop, ewmhWMStateHidden, ewmhWMClass, ewmhWMState, ewmhWMIcon, ewmhWMName, ewmhWMName2 :: EWMHProperty
ewmhActiveWindow :: String
ewmhActiveWindow = String
"_NET_ACTIVE_WINDOW"
ewmhClientList :: String
ewmhClientList = String
"_NET_CLIENT_LIST"
ewmhClientListStacking :: String
ewmhClientListStacking = String
"_NET_CLIENT_LIST_STACKING"
ewmhCurrentDesktop :: String
ewmhCurrentDesktop = String
"_NET_CURRENT_DESKTOP"
ewmhDesktopNames :: String
ewmhDesktopNames = String
"_NET_DESKTOP_NAMES"
ewmhNumberOfDesktops :: String
ewmhNumberOfDesktops = String
"_NET_NUMBER_OF_DESKTOPS"
ewmhStateHidden :: String
ewmhStateHidden = String
"_NET_WM_STATE_HIDDEN"
ewmhWMClass :: String
ewmhWMClass = String
"WM_CLASS"
ewmhWMDesktop :: String
ewmhWMDesktop = String
"_NET_WM_DESKTOP"
ewmhWMIcon :: String
ewmhWMIcon = String
"_NET_WM_ICON"
ewmhWMName :: String
ewmhWMName = String
"_NET_WM_NAME"
ewmhWMName2 :: String
ewmhWMName2 = String
"WM_NAME"
ewmhWMState :: String
ewmhWMState = String
"_NET_WM_STATE"
ewmhWMStateHidden :: String
ewmhWMStateHidden = String
"_NET_WM_STATE_HIDDEN"

allEWMHProperties :: [EWMHProperty]
allEWMHProperties :: [String]
allEWMHProperties =
  [ String
ewmhActiveWindow
  , String
ewmhClientList
  , String
ewmhClientListStacking
  , String
ewmhCurrentDesktop
  , String
ewmhDesktopNames
  , String
ewmhNumberOfDesktops
  , String
ewmhStateHidden
  , String
ewmhWMClass
  , String
ewmhWMDesktop
  , String
ewmhWMIcon
  , String
ewmhWMName
  , String
ewmhWMName2
  , String
ewmhWMState
  , String
ewmhWMStateHidden
  ]

type EWMHIconData = (ForeignPtr PixelsWordType, Int)

data EWMHIcon = EWMHIcon
  { EWMHIcon -> Int
ewmhWidth :: Int
  , EWMHIcon -> Int
ewmhHeight :: Int
  , EWMHIcon -> Ptr PixelsWordType
ewmhPixelsARGB :: Ptr PixelsWordType
  } deriving (Int -> EWMHIcon -> ShowS
[EWMHIcon] -> ShowS
EWMHIcon -> String
(Int -> EWMHIcon -> ShowS)
-> (EWMHIcon -> String) -> ([EWMHIcon] -> ShowS) -> Show EWMHIcon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EWMHIcon -> ShowS
showsPrec :: Int -> EWMHIcon -> ShowS
$cshow :: EWMHIcon -> String
show :: EWMHIcon -> String
$cshowList :: [EWMHIcon] -> ShowS
showList :: [EWMHIcon] -> ShowS
Show, EWMHIcon -> EWMHIcon -> Bool
(EWMHIcon -> EWMHIcon -> Bool)
-> (EWMHIcon -> EWMHIcon -> Bool) -> Eq EWMHIcon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EWMHIcon -> EWMHIcon -> Bool
== :: EWMHIcon -> EWMHIcon -> Bool
$c/= :: EWMHIcon -> EWMHIcon -> Bool
/= :: EWMHIcon -> EWMHIcon -> Bool
Eq)

getWindowStateProperty :: String -> X11Window -> X11Property Bool
getWindowStateProperty :: String -> PixelsWordType -> X11Property Bool
getWindowStateProperty String
property PixelsWordType
window =
  Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool)
-> ReaderT X11Context IO [String] -> X11Property Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PixelsWordType -> [String] -> ReaderT X11Context IO [String]
getWindowState PixelsWordType
window [String
property]

getWindowState :: X11Window -> [String] -> X11Property [String]
getWindowState :: PixelsWordType -> [String] -> ReaderT X11Context IO [String]
getWindowState PixelsWordType
window [String]
request = do
  let getAsLong :: String -> ReaderT X11Context IO b
getAsLong String
s = PixelsWordType -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PixelsWordType -> b)
-> ReaderT X11Context IO PixelsWordType -> ReaderT X11Context IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ReaderT X11Context IO PixelsWordType
getAtom String
s
  [CLong]
integers <- (String -> ReaderT X11Context IO CLong)
-> [String] -> ReaderT X11Context IO [CLong]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> ReaderT X11Context IO CLong
forall {b}. Num b => String -> ReaderT X11Context IO b
getAsLong [String]
request
  Maybe [CLong]
properties <- PropertyFetcher CLong
-> Maybe PixelsWordType -> String -> X11Property (Maybe [CLong])
forall a.
Integral a =>
PropertyFetcher a
-> Maybe PixelsWordType -> String -> X11Property (Maybe [a])
fetch PropertyFetcher CLong
getWindowProperty32 (PixelsWordType -> Maybe PixelsWordType
forall a. a -> Maybe a
Just PixelsWordType
window) String
ewmhWMState
  let integerToString :: [(CLong, String)]
integerToString = [CLong] -> [String] -> [(CLong, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CLong]
integers [String]
request
      present :: [CLong]
present = [CLong] -> [CLong] -> [CLong]
forall a. Eq a => [a] -> [a] -> [a]
intersect [CLong]
integers ([CLong] -> [CLong]) -> [CLong] -> [CLong]
forall a b. (a -> b) -> a -> b
$ [CLong] -> Maybe [CLong] -> [CLong]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [CLong]
properties
      presentStrings :: [Maybe String]
presentStrings = (CLong -> Maybe String) -> [CLong] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (CLong -> [(CLong, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(CLong, String)]
integerToString) [CLong]
present
  [String] -> ReaderT X11Context IO [String]
forall a. a -> ReaderT X11Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> ReaderT X11Context IO [String])
-> [String] -> ReaderT X11Context IO [String]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
presentStrings

-- | Get a bool reflecting whether window with provided X11Window is minimized
-- or not.
getWindowMinimized :: X11Window -> X11Property Bool
getWindowMinimized :: PixelsWordType -> X11Property Bool
getWindowMinimized = String -> PixelsWordType -> X11Property Bool
getWindowStateProperty String
ewmhStateHidden

-- | Retrieve the index of the current workspace in the desktop, starting from
-- 0.
getCurrentWorkspace :: X11Property WorkspaceId
getCurrentWorkspace :: X11Property WorkspaceId
getCurrentWorkspace = Int -> WorkspaceId
WorkspaceId (Int -> WorkspaceId)
-> ReaderT X11Context IO Int -> X11Property WorkspaceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PixelsWordType -> String -> ReaderT X11Context IO Int
readAsInt Maybe PixelsWordType
forall a. Maybe a
Nothing String
ewmhCurrentDesktop

-- | Retrieve the indexes of all currently visible workspaces
-- with the active workspace at the head of the list.
getVisibleWorkspaces :: X11Property [WorkspaceId]
getVisibleWorkspaces :: X11Property [WorkspaceId]
getVisibleWorkspaces = do
  [String]
vis <- ReaderT X11Context IO [String]
getVisibleTags
  [(String, WorkspaceId)]
allNames <- ((WorkspaceId, String) -> (String, WorkspaceId))
-> [(WorkspaceId, String)] -> [(String, WorkspaceId)]
forall a b. (a -> b) -> [a] -> [b]
map (WorkspaceId, String) -> (String, WorkspaceId)
forall a b. (a, b) -> (b, a)
swap ([(WorkspaceId, String)] -> [(String, WorkspaceId)])
-> ReaderT X11Context IO [(WorkspaceId, String)]
-> ReaderT X11Context IO [(String, WorkspaceId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT X11Context IO [(WorkspaceId, String)]
getWorkspaceNames
  WorkspaceId
cur <- X11Property WorkspaceId
getCurrentWorkspace
  [WorkspaceId] -> X11Property [WorkspaceId]
forall a. a -> ReaderT X11Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([WorkspaceId] -> X11Property [WorkspaceId])
-> [WorkspaceId] -> X11Property [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ WorkspaceId
cur WorkspaceId -> [WorkspaceId] -> [WorkspaceId]
forall a. a -> [a] -> [a]
: (String -> Maybe WorkspaceId) -> [String] -> [WorkspaceId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> [(String, WorkspaceId)] -> Maybe WorkspaceId
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, WorkspaceId)]
allNames) [String]
vis

-- | Return a list with the names of all the workspaces currently
-- available.
getWorkspaceNames :: X11Property [(WorkspaceId, String)]
getWorkspaceNames :: ReaderT X11Context IO [(WorkspaceId, String)]
getWorkspaceNames = [String] -> [(WorkspaceId, String)]
forall {b}. [b] -> [(WorkspaceId, b)]
go ([String] -> [(WorkspaceId, String)])
-> ReaderT X11Context IO [String]
-> ReaderT X11Context IO [(WorkspaceId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PixelsWordType -> String -> ReaderT X11Context IO [String]
readAsListOfString Maybe PixelsWordType
forall a. Maybe a
Nothing String
ewmhDesktopNames
  where go :: [b] -> [(WorkspaceId, b)]
go = [WorkspaceId] -> [b] -> [(WorkspaceId, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int -> WorkspaceId
WorkspaceId Int
i | Int
i <- [Int
0..]]

-- | Ask the window manager to switch to the workspace with the given
-- index, starting from 0.
switchToWorkspace :: WorkspaceId -> X11Property ()
switchToWorkspace :: WorkspaceId -> X11Property ()
switchToWorkspace (WorkspaceId Int
idx) = do
  PixelsWordType
cmd <- String -> ReaderT X11Context IO PixelsWordType
getAtom String
ewmhCurrentDesktop
  PixelsWordType -> PixelsWordType -> X11Property ()
sendCommandEvent PixelsWordType
cmd (Int -> PixelsWordType
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx)

-- | Move one workspace up or down from the current workspace
switchOneWorkspace :: Bool -> Int -> X11Property ()
switchOneWorkspace :: Bool -> Int -> X11Property ()
switchOneWorkspace Bool
dir Int
end = do
  WorkspaceId
cur <- X11Property WorkspaceId
getCurrentWorkspace
  WorkspaceId -> X11Property ()
switchToWorkspace (WorkspaceId -> X11Property ()) -> WorkspaceId -> X11Property ()
forall a b. (a -> b) -> a -> b
$ if Bool
dir then WorkspaceId -> Int -> WorkspaceId
getPrev WorkspaceId
cur Int
end else WorkspaceId -> Int -> WorkspaceId
getNext WorkspaceId
cur Int
end

-- | Check for corner case and switch one workspace up
getPrev :: WorkspaceId -> Int -> WorkspaceId
getPrev :: WorkspaceId -> Int -> WorkspaceId
getPrev (WorkspaceId Int
idx) Int
end
  | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> WorkspaceId
WorkspaceId (Int -> WorkspaceId) -> Int -> WorkspaceId
forall a b. (a -> b) -> a -> b
$ Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
  | Bool
otherwise = Int -> WorkspaceId
WorkspaceId Int
end

-- | Check for corner case and switch one workspace down
getNext :: WorkspaceId -> Int -> WorkspaceId
getNext :: WorkspaceId -> Int -> WorkspaceId
getNext (WorkspaceId Int
idx) Int
end
  | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
end = Int -> WorkspaceId
WorkspaceId (Int -> WorkspaceId) -> Int -> WorkspaceId
forall a b. (a -> b) -> a -> b
$ Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
  | Bool
otherwise = Int -> WorkspaceId
WorkspaceId Int
0

-- | Get the title of the given X11 window.
getWindowTitle :: X11Window -> X11Property String
getWindowTitle :: PixelsWordType -> X11Property String
getWindowTitle PixelsWordType
window = do
  let w :: Maybe PixelsWordType
w = PixelsWordType -> Maybe PixelsWordType
forall a. a -> Maybe a
Just PixelsWordType
window
  String
prop <- Maybe PixelsWordType -> String -> X11Property String
readAsString Maybe PixelsWordType
w String
ewmhWMName
  case String
prop of
    String
"" -> Maybe PixelsWordType -> String -> X11Property String
readAsString Maybe PixelsWordType
w String
ewmhWMName2
    String
_  -> String -> X11Property String
forall a. a -> ReaderT X11Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
prop

-- | Get the class of the given X11 window.
getWindowClass :: X11Window -> X11Property String
getWindowClass :: PixelsWordType -> X11Property String
getWindowClass PixelsWordType
window = Maybe PixelsWordType -> String -> X11Property String
readAsString (PixelsWordType -> Maybe PixelsWordType
forall a. a -> Maybe a
Just PixelsWordType
window) String
ewmhWMClass

parseWindowClasses :: String -> [String]
parseWindowClasses :: String -> [String]
parseWindowClasses = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"\NUL"

-- | Get EWMHIconData for the given X11Window
getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData)
getWindowIconsData :: PixelsWordType -> X11Property (Maybe EWMHIconData)
getWindowIconsData PixelsWordType
window = do
  Display
dpy <- X11Property Display
getDisplay
  PixelsWordType
atom <- String -> ReaderT X11Context IO PixelsWordType
getAtom String
ewmhWMIcon
  IO (Maybe EWMHIconData) -> X11Property (Maybe EWMHIconData)
forall (m :: * -> *) a. Monad m => m a -> ReaderT X11Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe EWMHIconData) -> X11Property (Maybe EWMHIconData))
-> IO (Maybe EWMHIconData) -> X11Property (Maybe EWMHIconData)
forall a b. (a -> b) -> a -> b
$ Int
-> Display
-> PixelsWordType
-> PixelsWordType
-> IO (Maybe EWMHIconData)
forall a.
Storable a =>
Int
-> Display
-> PixelsWordType
-> PixelsWordType
-> IO (Maybe (ForeignPtr a, Int))
rawGetWindowPropertyBytes Int
32 Display
dpy PixelsWordType
atom PixelsWordType
window

-- | Operate on the data contained in 'EWMHIconData' in the easier to interact
-- with format offered by 'EWMHIcon'. This function is much like
-- 'withForeignPtr' in that the 'EWMHIcon' values that are provided to the
-- callable argument should not be kept around in any way, because it can not be
-- guaranteed that the finalizer for the memory to which those icon objects
-- point will not be executed, after the call to 'withEWMHIcons' completes.
withEWMHIcons :: EWMHIconData -> ([EWMHIcon] -> IO a) -> IO a
withEWMHIcons :: forall a. EWMHIconData -> ([EWMHIcon] -> IO a) -> IO a
withEWMHIcons (ForeignPtr PixelsWordType
fptr, Int
size) [EWMHIcon] -> IO a
action =
  ForeignPtr PixelsWordType -> (Ptr PixelsWordType -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PixelsWordType
fptr (Int -> Ptr PixelsWordType -> IO [EWMHIcon]
parseIcons Int
size (Ptr PixelsWordType -> IO [EWMHIcon])
-> ([EWMHIcon] -> IO a) -> Ptr PixelsWordType -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [EWMHIcon] -> IO a
action)

-- | Split icon raw integer data into EWMHIcons. Each icon raw data is an
-- integer for width, followed by height, followed by exactly (width*height)
-- ARGB pixels, optionally followed by the next icon.
--
-- XXX: This function should not be made public, because its return value contains
-- (sub)pointers whose allocation we do not control.
parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon]
parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon]
parseIcons Int
0 Ptr PixelsWordType
_ = [EWMHIcon] -> IO [EWMHIcon]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
parseIcons Int
totalSize Ptr PixelsWordType
arr = do
  Int
iwidth <- PixelsWordType -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PixelsWordType -> Int) -> IO PixelsWordType -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PixelsWordType -> IO PixelsWordType
forall a. Storable a => Ptr a -> IO a
peek Ptr PixelsWordType
arr
  Int
iheight <- PixelsWordType -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PixelsWordType -> Int) -> IO PixelsWordType -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PixelsWordType -> Int -> IO PixelsWordType
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr PixelsWordType
arr Int
1
  let pixelsPtr :: Ptr PixelsWordType
pixelsPtr = Ptr PixelsWordType -> Int -> Ptr PixelsWordType
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr PixelsWordType
arr Int
2
      thisSize :: Int
thisSize = Int
iwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
iheight
      newArr :: Ptr PixelsWordType
newArr = Ptr PixelsWordType -> Int -> Ptr PixelsWordType
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr PixelsWordType
pixelsPtr Int
thisSize
      thisIcon :: EWMHIcon
thisIcon =
        EWMHIcon
        { ewmhWidth :: Int
ewmhWidth = Int
iwidth
        , ewmhHeight :: Int
ewmhHeight = Int
iheight
        , ewmhPixelsARGB :: Ptr PixelsWordType
ewmhPixelsARGB = Ptr PixelsWordType
pixelsPtr
        }
      getRes :: Int -> IO [EWMHIcon]
getRes Int
newSize
        | Int
newSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
          Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logHere Priority
ERROR String
"Attempt to recurse on negative value in parseIcons"
                    IO () -> IO [EWMHIcon] -> IO [EWMHIcon]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [EWMHIcon] -> IO [EWMHIcon]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        | Bool
otherwise = (EWMHIcon
thisIcon EWMHIcon -> [EWMHIcon] -> [EWMHIcon]
forall a. a -> [a] -> [a]
:) ([EWMHIcon] -> [EWMHIcon]) -> IO [EWMHIcon] -> IO [EWMHIcon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Ptr PixelsWordType -> IO [EWMHIcon]
parseIcons Int
newSize Ptr PixelsWordType
newArr
  Int -> IO [EWMHIcon]
getRes (Int -> IO [EWMHIcon]) -> Int -> IO [EWMHIcon]
forall a b. (a -> b) -> a -> b
$ Int
totalSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
thisSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

-- | Get the window that currently has focus if such a window exists.
getActiveWindow :: X11Property (Maybe X11Window)
getActiveWindow :: X11Property (Maybe PixelsWordType)
getActiveWindow = (PixelsWordType -> Bool)
-> [PixelsWordType] -> Maybe PixelsWordType
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (PixelsWordType -> PixelsWordType -> Bool
forall a. Ord a => a -> a -> Bool
> PixelsWordType
0) ([PixelsWordType] -> Maybe PixelsWordType)
-> ReaderT X11Context IO [PixelsWordType]
-> X11Property (Maybe PixelsWordType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PixelsWordType
-> String -> ReaderT X11Context IO [PixelsWordType]
readAsListOfWindow Maybe PixelsWordType
forall a. Maybe a
Nothing String
ewmhActiveWindow

-- | Return a list of all @X11Window@s, sorted by initial mapping order, oldest to newest.
getWindows :: X11Property [X11Window]
getWindows :: ReaderT X11Context IO [PixelsWordType]
getWindows = Maybe PixelsWordType
-> String -> ReaderT X11Context IO [PixelsWordType]
readAsListOfWindow Maybe PixelsWordType
forall a. Maybe a
Nothing String
ewmhClientList

-- | Return a list of all @X11Window@s, sorted in stacking order, bottom-to-top.
getWindowsStacking :: X11Property [X11Window]
getWindowsStacking :: ReaderT X11Context IO [PixelsWordType]
getWindowsStacking = Maybe PixelsWordType
-> String -> ReaderT X11Context IO [PixelsWordType]
readAsListOfWindow Maybe PixelsWordType
forall a. Maybe a
Nothing String
ewmhClientListStacking

-- | Return the index (starting from 0) of the workspace on which the given
-- window is being displayed.
getWorkspace :: X11Window -> X11Property WorkspaceId
getWorkspace :: PixelsWordType -> X11Property WorkspaceId
getWorkspace PixelsWordType
window = Int -> WorkspaceId
WorkspaceId (Int -> WorkspaceId)
-> ReaderT X11Context IO Int -> X11Property WorkspaceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PixelsWordType -> String -> ReaderT X11Context IO Int
readAsInt (PixelsWordType -> Maybe PixelsWordType
forall a. a -> Maybe a
Just PixelsWordType
window) String
ewmhWMDesktop

-- | Ask the window manager to give focus to the given window.
focusWindow :: X11Window -> X11Property ()
focusWindow :: PixelsWordType -> X11Property ()
focusWindow PixelsWordType
wh = do
  PixelsWordType
cmd <- String -> ReaderT X11Context IO PixelsWordType
getAtom String
ewmhActiveWindow
  PixelsWordType -> PixelsWordType -> X11Property ()
sendWindowEvent PixelsWordType
cmd (PixelsWordType -> PixelsWordType
forall a b. (Integral a, Num b) => a -> b
fromIntegral PixelsWordType
wh)