{-# OPTIONS_GHC -w #-}
{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.EWMH
-- Copyright   :  (c) Spencer Janssen
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Spencer Janssen <spencerjanssen@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- An experimental plugin to display EWMH pager information
--
-----------------------------------------------------------------------------

module Xmobar.Plugins.EWMH (EWMH(..)) where

import Control.Applicative (Applicative(..))
import Control.Monad.State
import Control.Monad.Reader
import Graphics.X11 hiding (Modifier, Color)
import Graphics.X11.Xlib.Extras
import Xmobar.Run.Exec
import Codec.Binary.UTF8.String as UTF8
import Foreign.C (CChar, CLong)
import Xmobar.X11.Events (nextEvent')

import Data.List (intersperse, intercalate)

import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set


data EWMH = EWMH | EWMHFMT Component deriving (ReadPrec [EWMH]
ReadPrec EWMH
Int -> ReadS EWMH
ReadS [EWMH]
(Int -> ReadS EWMH)
-> ReadS [EWMH] -> ReadPrec EWMH -> ReadPrec [EWMH] -> Read EWMH
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [EWMH]
$creadListPrec :: ReadPrec [EWMH]
readPrec :: ReadPrec EWMH
$creadPrec :: ReadPrec EWMH
readList :: ReadS [EWMH]
$creadList :: ReadS [EWMH]
readsPrec :: Int -> ReadS EWMH
$creadsPrec :: Int -> ReadS EWMH
Read, Int -> EWMH -> ShowS
[EWMH] -> ShowS
EWMH -> String
(Int -> EWMH -> ShowS)
-> (EWMH -> String) -> ([EWMH] -> ShowS) -> Show EWMH
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EWMH] -> ShowS
$cshowList :: [EWMH] -> ShowS
show :: EWMH -> String
$cshow :: EWMH -> String
showsPrec :: Int -> EWMH -> ShowS
$cshowsPrec :: Int -> EWMH -> ShowS
Show)

instance Exec EWMH where
    alias :: EWMH -> String
alias EWMH
EWMH = String
"EWMH"

    start :: EWMH -> (String -> IO ()) -> IO ()
start EWMH
ew String -> IO ()
cb = (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
ep -> M () -> IO ()
forall a. M a -> IO a
execM (M () -> IO ()) -> M () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Display
d <- (EwmhConf -> Display) -> M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Display
display
        Window
r <- (EwmhConf -> Window) -> M Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Window
root

        IO () -> M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
xSetErrorHandler

        IO () -> M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
selectInput Display
d Window
r Window
propertyChangeMask
        [(Window, Updater)]
handlers' <- ((String, Updater) -> M (Window, Updater))
-> [(String, Updater)] -> M [(Window, Updater)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(String
a, Updater
h) -> (Window -> Updater -> (Window, Updater))
-> M Window -> M Updater -> M (Window, Updater)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (String -> M Window
getAtom String
a) (Updater -> M Updater
forall (m :: * -> *) a. Monad m => a -> m a
return Updater
h)) [(String, Updater)]
handlers
        ((Window, Updater) -> M ()) -> [(Window, Updater)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Updater -> M Window -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (EwmhConf -> Window) -> M Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Window
root) (Updater -> M ())
-> ((Window, Updater) -> Updater) -> (Window, Updater) -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Updater) -> Updater
forall a b. (a, b) -> b
snd) [(Window, Updater)]
handlers'

        M () -> M Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M () -> M Any) -> M () -> M Any
forall a b. (a -> b) -> a -> b
$ do
            IO () -> M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> (EwmhState -> IO ()) -> EwmhState -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
cb (String -> IO ()) -> (EwmhState -> String) -> EwmhState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EWMH -> EwmhState -> String
fmtOf EWMH
ew (EwmhState -> M ()) -> M EwmhState -> M ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< M EwmhState
forall s (m :: * -> *). MonadState s m => m s
get
            IO () -> M ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M ()) -> IO () -> M ()
forall a b. (a -> b) -> a -> b
$ Display -> XEventPtr -> IO ()
nextEvent' Display
d XEventPtr
ep
            Event
e <- IO Event -> M Event
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Event -> M Event) -> IO Event -> M Event
forall a b. (a -> b) -> a -> b
$ XEventPtr -> IO Event
getEvent XEventPtr
ep
            case Event
e of
                PropertyEvent { ev_atom :: Event -> Window
ev_atom = Window
a, ev_window :: Event -> Window
ev_window = Window
w } ->
                    case Window -> [(Window, Updater)] -> Maybe Updater
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Window
a [(Window, Updater)]
handlers' of
                        Just Updater
f -> Updater
f Window
w
                        Maybe Updater
_      -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Event
_ -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

defaultPP :: Component
defaultPP = Component -> [Component] -> Component
Sep (String -> Component
Text String
" : ") [ [WsOpt] -> Component
Workspaces [String -> String -> Modifier
Color String
"white" String
"black" Modifier -> WsType -> WsOpt
:% WsType
Current, Modifier
Hide Modifier -> WsType -> WsOpt
:% WsType
Empty]
                             , Component
Layout
                             , String -> String -> Modifier
Color String
"#00ee00" String
"" Modifier -> Component -> Component
:$ Int -> Modifier
Short Int
120 Modifier -> Component -> Component
:$ Component
WindowName]

fmtOf :: EWMH -> EwmhState -> String
fmtOf EWMH
EWMH = (EwmhState -> Component -> String)
-> Component -> EwmhState -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip EwmhState -> Component -> String
fmt Component
defaultPP
fmtOf (EWMHFMT Component
f) = (EwmhState -> Component -> String)
-> Component -> EwmhState -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip EwmhState -> Component -> String
fmt Component
f

sep :: [a] -> [[a]] -> [a]
sep :: [a] -> [[a]] -> [a]
sep [a]
x [[a]]
xs = [a] -> [[a]] -> [a]
forall a. [a] -> [[a]] -> [a]
intercalate [a]
x ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
xs

fmt :: EwmhState -> Component -> String
fmt :: EwmhState -> Component -> String
fmt EwmhState
e (Text String
s) = String
s
fmt EwmhState
e (Component
l :+ Component
r) = EwmhState -> Component -> String
fmt EwmhState
e Component
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ EwmhState -> Component -> String
fmt EwmhState
e Component
r
fmt EwmhState
e (Modifier
m :$ Component
r) = Modifier -> ShowS
modifier Modifier
m ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ EwmhState -> Component -> String
fmt EwmhState
e Component
r
fmt EwmhState
e (Sep Component
c [Component]
xs) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
sep (EwmhState -> Component -> String
fmt EwmhState
e Component
c) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Component -> String) -> [Component] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (EwmhState -> Component -> String
fmt EwmhState
e) [Component]
xs
fmt EwmhState
e Component
WindowName = Client -> String
windowName (Client -> String) -> Client -> String
forall a b. (a -> b) -> a -> b
$ Client -> Window -> Map Window Client -> Client
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Client
initialClient (EwmhState -> Window
activeWindow EwmhState
e) (EwmhState -> Map Window Client
clients EwmhState
e)
fmt EwmhState
e Component
Layout = EwmhState -> String
layout EwmhState
e
fmt EwmhState
e (Workspaces [WsOpt]
opts) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
sep String
" "
                            [(ShowS -> ShowS) -> String -> [ShowS] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS
forall a b. (a -> b) -> a -> b
($) String
n [Modifier -> ShowS
modifier Modifier
m | (Modifier
m :% WsType
a) <- [WsOpt]
opts, WsType
a WsType -> [WsType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WsType]
as]
                                | (String
n, [WsType]
as) <- [(String, [WsType])]
attrs]
 where
    stats :: CLong -> [(WsType, Bool)]
stats CLong
i = [ (WsType
Current, CLong
i CLong -> CLong -> Bool
forall a. Eq a => a -> a -> Bool
== EwmhState -> CLong
currentDesktop EwmhState
e)
              , (WsType
Empty, CLong -> Set CLong -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember CLong
i Set CLong
nonEmptys Bool -> Bool -> Bool
&& CLong
i CLong -> CLong -> Bool
forall a. Eq a => a -> a -> Bool
/= EwmhState -> CLong
currentDesktop EwmhState
e)
              -- TODO for visible , (Visibl
              ]
    attrs :: [(String, [WsType])]
    attrs :: [(String, [WsType])]
attrs = [(String
n, [WsType
s | (WsType
s, Bool
b) <- CLong -> [(WsType, Bool)]
stats CLong
i, Bool
b]) | (CLong
i, String
n) <- [CLong] -> [String] -> [(CLong, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CLong
0 ..] (EwmhState -> [String]
desktopNames EwmhState
e)]
    nonEmptys :: Set CLong
nonEmptys = [Set CLong] -> Set CLong
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set CLong] -> Set CLong)
-> (Map Window Client -> [Set CLong])
-> Map Window Client
-> Set CLong
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Client -> Set CLong) -> [Client] -> [Set CLong]
forall a b. (a -> b) -> [a] -> [b]
map Client -> Set CLong
desktops ([Client] -> [Set CLong])
-> (Map Window Client -> [Client])
-> Map Window Client
-> [Set CLong]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Window Client -> [Client]
forall k a. Map k a -> [a]
Map.elems (Map Window Client -> Set CLong) -> Map Window Client -> Set CLong
forall a b. (a -> b) -> a -> b
$ EwmhState -> Map Window Client
clients EwmhState
e

modifier :: Modifier -> String -> String
modifier :: Modifier -> ShowS
modifier Modifier
Hide = String -> ShowS
forall a b. a -> b -> a
const String
""
modifier (Color String
fg String
bg) = \String
x -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"<fc=", String
fg, if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
bg then String
"" else String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
bg
                                      , String
">", String
x, String
"</fc>"]
modifier (Short Int
n) = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n
modifier (Wrap String
l String
r) = \String
x -> String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
r

data Component = Text String
               | Component :+ Component
               | Modifier :$ Component
               | Sep Component [Component]
               | WindowName
               | Layout
               | Workspaces [WsOpt]
    deriving (ReadPrec [Component]
ReadPrec Component
Int -> ReadS Component
ReadS [Component]
(Int -> ReadS Component)
-> ReadS [Component]
-> ReadPrec Component
-> ReadPrec [Component]
-> Read Component
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Component]
$creadListPrec :: ReadPrec [Component]
readPrec :: ReadPrec Component
$creadPrec :: ReadPrec Component
readList :: ReadS [Component]
$creadList :: ReadS [Component]
readsPrec :: Int -> ReadS Component
$creadsPrec :: Int -> ReadS Component
Read, Int -> Component -> ShowS
[Component] -> ShowS
Component -> String
(Int -> Component -> ShowS)
-> (Component -> String)
-> ([Component] -> ShowS)
-> Show Component
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Component] -> ShowS
$cshowList :: [Component] -> ShowS
show :: Component -> String
$cshow :: Component -> String
showsPrec :: Int -> Component -> ShowS
$cshowsPrec :: Int -> Component -> ShowS
Show)

infixr 0 :$
infixr 5 :+

data Modifier = Hide
              | Color String String
              | Short Int
              | Wrap String String
    deriving (ReadPrec [Modifier]
ReadPrec Modifier
Int -> ReadS Modifier
ReadS [Modifier]
(Int -> ReadS Modifier)
-> ReadS [Modifier]
-> ReadPrec Modifier
-> ReadPrec [Modifier]
-> Read Modifier
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Modifier]
$creadListPrec :: ReadPrec [Modifier]
readPrec :: ReadPrec Modifier
$creadPrec :: ReadPrec Modifier
readList :: ReadS [Modifier]
$creadList :: ReadS [Modifier]
readsPrec :: Int -> ReadS Modifier
$creadsPrec :: Int -> ReadS Modifier
Read, Int -> Modifier -> ShowS
[Modifier] -> ShowS
Modifier -> String
(Int -> Modifier -> ShowS)
-> (Modifier -> String) -> ([Modifier] -> ShowS) -> Show Modifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Modifier] -> ShowS
$cshowList :: [Modifier] -> ShowS
show :: Modifier -> String
$cshow :: Modifier -> String
showsPrec :: Int -> Modifier -> ShowS
$cshowsPrec :: Int -> Modifier -> ShowS
Show)

data WsOpt = Modifier :% WsType
           | WSep Component
    deriving (ReadPrec [WsOpt]
ReadPrec WsOpt
Int -> ReadS WsOpt
ReadS [WsOpt]
(Int -> ReadS WsOpt)
-> ReadS [WsOpt]
-> ReadPrec WsOpt
-> ReadPrec [WsOpt]
-> Read WsOpt
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WsOpt]
$creadListPrec :: ReadPrec [WsOpt]
readPrec :: ReadPrec WsOpt
$creadPrec :: ReadPrec WsOpt
readList :: ReadS [WsOpt]
$creadList :: ReadS [WsOpt]
readsPrec :: Int -> ReadS WsOpt
$creadsPrec :: Int -> ReadS WsOpt
Read, Int -> WsOpt -> ShowS
[WsOpt] -> ShowS
WsOpt -> String
(Int -> WsOpt -> ShowS)
-> (WsOpt -> String) -> ([WsOpt] -> ShowS) -> Show WsOpt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WsOpt] -> ShowS
$cshowList :: [WsOpt] -> ShowS
show :: WsOpt -> String
$cshow :: WsOpt -> String
showsPrec :: Int -> WsOpt -> ShowS
$cshowsPrec :: Int -> WsOpt -> ShowS
Show)
infixr 0 :%

data WsType = Current | Empty | Visible
    deriving (ReadPrec [WsType]
ReadPrec WsType
Int -> ReadS WsType
ReadS [WsType]
(Int -> ReadS WsType)
-> ReadS [WsType]
-> ReadPrec WsType
-> ReadPrec [WsType]
-> Read WsType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WsType]
$creadListPrec :: ReadPrec [WsType]
readPrec :: ReadPrec WsType
$creadPrec :: ReadPrec WsType
readList :: ReadS [WsType]
$creadList :: ReadS [WsType]
readsPrec :: Int -> ReadS WsType
$creadsPrec :: Int -> ReadS WsType
Read, Int -> WsType -> ShowS
[WsType] -> ShowS
WsType -> String
(Int -> WsType -> ShowS)
-> (WsType -> String) -> ([WsType] -> ShowS) -> Show WsType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WsType] -> ShowS
$cshowList :: [WsType] -> ShowS
show :: WsType -> String
$cshow :: WsType -> String
showsPrec :: Int -> WsType -> ShowS
$cshowsPrec :: Int -> WsType -> ShowS
Show, WsType -> WsType -> Bool
(WsType -> WsType -> Bool)
-> (WsType -> WsType -> Bool) -> Eq WsType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WsType -> WsType -> Bool
$c/= :: WsType -> WsType -> Bool
== :: WsType -> WsType -> Bool
$c== :: WsType -> WsType -> Bool
Eq)

data EwmhConf  = C { EwmhConf -> Window
root :: Window
                   , EwmhConf -> Display
display :: Display }

data EwmhState = S { EwmhState -> CLong
currentDesktop :: CLong
                   , EwmhState -> Window
activeWindow :: Window
                   , EwmhState -> [String]
desktopNames :: [String]
                   , EwmhState -> String
layout :: String
                   , EwmhState -> Map Window Client
clients :: Map Window Client }
    deriving Int -> EwmhState -> ShowS
[EwmhState] -> ShowS
EwmhState -> String
(Int -> EwmhState -> ShowS)
-> (EwmhState -> String)
-> ([EwmhState] -> ShowS)
-> Show EwmhState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EwmhState] -> ShowS
$cshowList :: [EwmhState] -> ShowS
show :: EwmhState -> String
$cshow :: EwmhState -> String
showsPrec :: Int -> EwmhState -> ShowS
$cshowsPrec :: Int -> EwmhState -> ShowS
Show

data Client = Cl { Client -> String
windowName :: String
                 , Client -> Set CLong
desktops :: Set CLong }
    deriving Int -> Client -> ShowS
[Client] -> ShowS
Client -> String
(Int -> Client -> ShowS)
-> (Client -> String) -> ([Client] -> ShowS) -> Show Client
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Client] -> ShowS
$cshowList :: [Client] -> ShowS
show :: Client -> String
$cshow :: Client -> String
showsPrec :: Int -> Client -> ShowS
$cshowsPrec :: Int -> Client -> ShowS
Show

getAtom :: String -> M Atom
getAtom :: String -> M Window
getAtom String
s = do
    Display
d <- (EwmhConf -> Display) -> M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Display
display
    IO Window -> M Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Window -> M Window) -> IO Window -> M Window
forall a b. (a -> b) -> a -> b
$ Display -> String -> Bool -> IO Window
internAtom Display
d String
s Bool
False

windowProperty32 :: String -> Window -> M (Maybe [CLong])
windowProperty32 :: String -> Window -> M (Maybe [CLong])
windowProperty32 String
s Window
w = do
    C {Display
display :: Display
display :: EwmhConf -> Display
display} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Window
a <- String -> M Window
getAtom String
s
    IO (Maybe [CLong]) -> M (Maybe [CLong])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [CLong]) -> M (Maybe [CLong]))
-> IO (Maybe [CLong]) -> M (Maybe [CLong])
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO (Maybe [CLong])
getWindowProperty32 Display
display Window
a Window
w

windowProperty8 :: String -> Window -> M (Maybe [CChar])
windowProperty8 :: String -> Window -> M (Maybe [CChar])
windowProperty8 String
s Window
w = do
    C {Display
display :: Display
display :: EwmhConf -> Display
display} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Window
a <- String -> M Window
getAtom String
s
    IO (Maybe [CChar]) -> M (Maybe [CChar])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [CChar]) -> M (Maybe [CChar]))
-> IO (Maybe [CChar]) -> M (Maybe [CChar])
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO (Maybe [CChar])
getWindowProperty8 Display
display Window
a Window
w

initialState :: EwmhState
initialState :: EwmhState
initialState = CLong
-> Window -> [String] -> String -> Map Window Client -> EwmhState
S CLong
0 Window
0 [] [] Map Window Client
forall k a. Map k a
Map.empty

initialClient :: Client
initialClient :: Client
initialClient = String -> Set CLong -> Client
Cl String
"" Set CLong
forall a. Set a
Set.empty

handlers, clientHandlers :: [(String, Updater)]
handlers :: [(String, Updater)]
handlers = [ (String
"_NET_CURRENT_DESKTOP", Updater
updateCurrentDesktop)
           , (String
"_NET_DESKTOP_NAMES", Updater
updateDesktopNames )
           , (String
"_NET_ACTIVE_WINDOW", Updater
updateActiveWindow)
           , (String
"_NET_CLIENT_LIST", Updater
forall p. p -> M ()
updateClientList)
           ] [(String, Updater)] -> [(String, Updater)] -> [(String, Updater)]
forall a. [a] -> [a] -> [a]
++ [(String, Updater)]
clientHandlers

clientHandlers :: [(String, Updater)]
clientHandlers = [ (String
"_NET_WM_NAME", Updater
updateName)
                 , (String
"_NET_WM_DESKTOP", Updater
updateDesktop) ]

newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a)
    deriving (Applicative M
a -> M a
Applicative M
-> (forall a b. M a -> (a -> M b) -> M b)
-> (forall a b. M a -> M b -> M b)
-> (forall a. a -> M a)
-> Monad M
M a -> (a -> M b) -> M b
M a -> M b -> M b
forall a. a -> M a
forall a b. M a -> M b -> M b
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> M a
$creturn :: forall a. a -> M a
>> :: M a -> M b -> M b
$c>> :: forall a b. M a -> M b -> M b
>>= :: M a -> (a -> M b) -> M b
$c>>= :: forall a b. M a -> (a -> M b) -> M b
$cp1Monad :: Applicative M
Monad, a -> M b -> M a
(a -> b) -> M a -> M b
(forall a b. (a -> b) -> M a -> M b)
-> (forall a b. a -> M b -> M a) -> Functor M
forall a b. a -> M b -> M a
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> M b -> M a
$c<$ :: forall a b. a -> M b -> M a
fmap :: (a -> b) -> M a -> M b
$cfmap :: forall a b. (a -> b) -> M a -> M b
Functor, Functor M
a -> M a
Functor M
-> (forall a. a -> M a)
-> (forall a b. M (a -> b) -> M a -> M b)
-> (forall a b c. (a -> b -> c) -> M a -> M b -> M c)
-> (forall a b. M a -> M b -> M b)
-> (forall a b. M a -> M b -> M a)
-> Applicative M
M a -> M b -> M b
M a -> M b -> M a
M (a -> b) -> M a -> M b
(a -> b -> c) -> M a -> M b -> M c
forall a. a -> M a
forall a b. M a -> M b -> M a
forall a b. M a -> M b -> M b
forall a b. M (a -> b) -> M a -> M b
forall a b c. (a -> b -> c) -> M a -> M b -> M c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: M a -> M b -> M a
$c<* :: forall a b. M a -> M b -> M a
*> :: M a -> M b -> M b
$c*> :: forall a b. M a -> M b -> M b
liftA2 :: (a -> b -> c) -> M a -> M b -> M c
$cliftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
<*> :: M (a -> b) -> M a -> M b
$c<*> :: forall a b. M (a -> b) -> M a -> M b
pure :: a -> M a
$cpure :: forall a. a -> M a
$cp1Applicative :: Functor M
Applicative, Monad M
Monad M -> (forall a. IO a -> M a) -> MonadIO M
IO a -> M a
forall a. IO a -> M a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> M a
$cliftIO :: forall a. IO a -> M a
$cp1MonadIO :: Monad M
MonadIO, MonadReader EwmhConf, MonadState EwmhState)

execM :: M a -> IO a
execM :: M a -> IO a
execM (M ReaderT EwmhConf (StateT EwmhState IO) a
m) = do
    Display
d <- String -> IO Display
openDisplay String
""
    Window
r <- Display -> ScreenNumber -> IO Window
rootWindow Display
d (Display -> ScreenNumber
defaultScreen Display
d)
    let conf :: EwmhConf
conf = Window -> Display -> EwmhConf
C Window
r Display
d
    StateT EwmhState IO a -> EwmhState -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT EwmhConf (StateT EwmhState IO) a
-> EwmhConf -> StateT EwmhState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT EwmhConf (StateT EwmhState IO) a
m (Window -> Display -> EwmhConf
C Window
r Display
d)) EwmhState
initialState

type Updater = Window -> M ()

updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater
updateCurrentDesktop :: Updater
updateCurrentDesktop Window
_ = do
    C {Window
root :: Window
root :: EwmhConf -> Window
root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe [CLong]
mwp <- String -> Window -> M (Maybe [CLong])
windowProperty32 String
"_NET_CURRENT_DESKTOP" Window
root
    case Maybe [CLong]
mwp of
        Just [CLong
x] -> (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { currentDesktop :: CLong
currentDesktop = CLong
x })
        Maybe [CLong]
_        -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updateActiveWindow :: Updater
updateActiveWindow Window
_ = do
    C {Window
root :: Window
root :: EwmhConf -> Window
root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe [CLong]
mwp <- String -> Window -> M (Maybe [CLong])
windowProperty32 String
"_NET_ACTIVE_WINDOW" Window
root
    case Maybe [CLong]
mwp of
        Just [CLong
x] -> (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { activeWindow :: Window
activeWindow = CLong -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
x })
        Maybe [CLong]
_        -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updateDesktopNames :: Updater
updateDesktopNames Window
_ = do
    C {Window
root :: Window
root :: EwmhConf -> Window
root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe [CChar]
mwp <- String -> Window -> M (Maybe [CChar])
windowProperty8 String
"_NET_DESKTOP_NAMES" Window
root
    case Maybe [CChar]
mwp of
        Just [CChar]
xs -> (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { desktopNames :: [String]
desktopNames = [CChar] -> [String]
parse [CChar]
xs })
        Maybe [CChar]
_       -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
    dropNull :: ShowS
dropNull (Char
'\0':String
xs) = String
xs
    dropNull String
xs        = String
xs

    split :: String -> [String]
split []        = []
    split String
xs        = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0') String
xs of
                        (String
x, String
ys) -> String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
split (ShowS
dropNull String
ys)
    parse :: [CChar] -> [String]
parse = String -> [String]
split (String -> [String]) -> ([CChar] -> String) -> [CChar] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CChar] -> String
decodeCChar

updateClientList :: p -> M ()
updateClientList p
_ = do
    C {Window
root :: Window
root :: EwmhConf -> Window
root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe [CLong]
mwp <- String -> Window -> M (Maybe [CLong])
windowProperty32 String
"_NET_CLIENT_LIST" Window
root
    case Maybe [CLong]
mwp of
        Just [CLong]
xs -> do
                    Map Window Client
cl <- (EwmhState -> Map Window Client) -> M (Map Window Client)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EwmhState -> Map Window Client
clients
                    let cl' :: Map Window Client
cl' = [(Window, Client)] -> Map Window Client
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Window, Client)] -> Map Window Client)
-> [(Window, Client)] -> Map Window Client
forall a b. (a -> b) -> a -> b
$ (CLong -> (Window, Client)) -> [CLong] -> [(Window, Client)]
forall a b. (a -> b) -> [a] -> [b]
map ((, Client
initialClient) (Window -> (Window, Client))
-> (CLong -> Window) -> CLong -> (Window, Client)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [CLong]
xs
                        dels :: Map Window Client
dels = Map Window Client -> Map Window Client -> Map Window Client
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map Window Client
cl Map Window Client
cl'
                        new :: Map Window Client
new = Map Window Client -> Map Window Client -> Map Window Client
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map Window Client
cl' Map Window Client
cl
                    (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { clients :: Map Window Client
clients = Map Window Client -> Map Window Client -> Map Window Client
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Map Window Client -> Map Window Client -> Map Window Client
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map Window Client
cl Map Window Client
cl') Map Window Client
cl'})
                    ((Window, Client) -> M ()) -> [(Window, Client)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Updater
forall (m :: * -> *).
(MonadReader EwmhConf m, MonadIO m) =>
Window -> m ()
unmanage Updater -> ((Window, Client) -> Window) -> (Window, Client) -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Client) -> Window
forall a b. (a, b) -> a
fst) (Map Window Client -> [(Window, Client)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Window Client
dels)
                    ((Window, Client) -> M ()) -> [(Window, Client)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Updater
forall (m :: * -> *).
(MonadReader EwmhConf m, MonadIO m) =>
Window -> m ()
listen Updater -> ((Window, Client) -> Window) -> (Window, Client) -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Client) -> Window
forall a b. (a, b) -> a
fst)   (Map Window Client -> [(Window, Client)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Window Client
cl')
                    ((Window, Client) -> M ()) -> [(Window, Client)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Updater
update Updater -> ((Window, Client) -> Window) -> (Window, Client) -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Client) -> Window
forall a b. (a, b) -> a
fst)   (Map Window Client -> [(Window, Client)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Window Client
new)
        Maybe [CLong]
_       -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
    unmanage :: Window -> m ()
unmanage Window
w = (EwmhConf -> Display) -> m Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Display
display m Display -> (Display -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
selectInput Display
d Window
w Window
0
    listen :: Window -> m ()
listen Window
w = (EwmhConf -> Display) -> m Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Display
display m Display -> (Display -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
selectInput Display
d Window
w Window
propertyChangeMask
    update :: Updater
update Window
w = ((String, Updater) -> M ()) -> [(String, Updater)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Updater -> Updater
forall a b. (a -> b) -> a -> b
$ Window
w) (Updater -> M ())
-> ((String, Updater) -> Updater) -> (String, Updater) -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Updater) -> Updater
forall a b. (a, b) -> b
snd) [(String, Updater)]
clientHandlers

modifyClient :: Window -> (Client -> Client) -> M ()
modifyClient :: Window -> (Client -> Client) -> M ()
modifyClient Window
w Client -> Client
f = (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { clients :: Map Window Client
clients = (Maybe Client -> Maybe Client)
-> Window -> Map Window Client -> Map Window Client
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Client -> Maybe Client
f' Window
w (Map Window Client -> Map Window Client)
-> Map Window Client -> Map Window Client
forall a b. (a -> b) -> a -> b
$ EwmhState -> Map Window Client
clients EwmhState
s })
 where
    f' :: Maybe Client -> Maybe Client
f' Maybe Client
Nothing  = Client -> Maybe Client
forall a. a -> Maybe a
Just (Client -> Maybe Client) -> Client -> Maybe Client
forall a b. (a -> b) -> a -> b
$ Client -> Client
f Client
initialClient
    f' (Just Client
x) = Client -> Maybe Client
forall a. a -> Maybe a
Just (Client -> Maybe Client) -> Client -> Maybe Client
forall a b. (a -> b) -> a -> b
$ Client -> Client
f Client
x

updateName :: Updater
updateName Window
w = do
    Maybe [CChar]
mwp <- String -> Window -> M (Maybe [CChar])
windowProperty8 String
"_NET_WM_NAME" Window
w
    case Maybe [CChar]
mwp of
        Just [CChar]
xs -> Window -> (Client -> Client) -> M ()
modifyClient Window
w (\Client
c -> Client
c { windowName :: String
windowName = [CChar] -> String
decodeCChar [CChar]
xs })
        Maybe [CChar]
_       -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updateDesktop :: Updater
updateDesktop Window
w = do
    Maybe [CLong]
mwp <- String -> Window -> M (Maybe [CLong])
windowProperty32 String
"_NET_WM_DESKTOP" Window
w
    case Maybe [CLong]
mwp of
        Just [CLong]
x -> Window -> (Client -> Client) -> M ()
modifyClient Window
w (\Client
c -> Client
c { desktops :: Set CLong
desktops = [CLong] -> Set CLong
forall a. Ord a => [a] -> Set a
Set.fromList [CLong]
x })
        Maybe [CLong]
_      -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

decodeCChar :: [CChar] -> String
decodeCChar :: [CChar] -> String
decodeCChar = [Word8] -> String
UTF8.decode ([Word8] -> String) -> ([CChar] -> [Word8]) -> [CChar] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CChar -> Word8) -> [CChar] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map CChar -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral