{-# 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
#ifdef UTF8
#undef UTF8
import Codec.Binary.UTF8.String as UTF8
#define UTF8
#endif
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
#ifdef UTF8
#undef UTF8
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
#define UTF8
#else
decodeCChar = map (toEnum . fromIntegral)
#endif