{-# OPTIONS_GHC -w #-}
{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections, FlexibleContexts #-}
module Xmobar.Plugins.EWMH (EWMH(..)) where
import Control.Applicative (Applicative(..))
import Control.Monad.State
import Control.Monad
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
$creadsPrec :: Int -> ReadS EWMH
readsPrec :: Int -> ReadS EWMH
$creadList :: ReadS [EWMH]
readList :: ReadS [EWMH]
$creadPrec :: ReadPrec EWMH
readPrec :: ReadPrec EWMH
$creadListPrec :: ReadPrec [EWMH]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> EWMH -> ShowS
showsPrec :: Int -> EWMH -> ShowS
$cshow :: EWMH -> String
show :: EWMH -> String
$cshowList :: [EWMH] -> ShowS
showList :: [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
d <- (EwmhConf -> Display) -> M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Display
display
r <- asks root
liftIO xSetErrorHandler
liftIO $ selectInput d r propertyChangeMask
handlers' <- 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 a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Updater
h)) handlers
mapM_ ((=<< asks root) . snd) handlers'
forever $ do
liftIO . cb . fmtOf ew =<< get
liftIO $ nextEvent' d ep
e <- liftIO $ getEvent ep
case 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 a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Event
_ -> () -> M ()
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 :: forall a. [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 a. [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 a b. (a -> b -> b) -> b -> [a] -> b
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 a. Eq a => a -> [a] -> 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)
]
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 a. [a] -> 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
$creadsPrec :: Int -> ReadS Component
readsPrec :: Int -> ReadS Component
$creadList :: ReadS [Component]
readList :: ReadS [Component]
$creadPrec :: ReadPrec Component
readPrec :: ReadPrec Component
$creadListPrec :: ReadPrec [Component]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> Component -> ShowS
showsPrec :: Int -> Component -> ShowS
$cshow :: Component -> String
show :: Component -> String
$cshowList :: [Component] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS Modifier
readsPrec :: Int -> ReadS Modifier
$creadList :: ReadS [Modifier]
readList :: ReadS [Modifier]
$creadPrec :: ReadPrec Modifier
readPrec :: ReadPrec Modifier
$creadListPrec :: ReadPrec [Modifier]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> Modifier -> ShowS
showsPrec :: Int -> Modifier -> ShowS
$cshow :: Modifier -> String
show :: Modifier -> String
$cshowList :: [Modifier] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS WsOpt
readsPrec :: Int -> ReadS WsOpt
$creadList :: ReadS [WsOpt]
readList :: ReadS [WsOpt]
$creadPrec :: ReadPrec WsOpt
readPrec :: ReadPrec WsOpt
$creadListPrec :: ReadPrec [WsOpt]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> WsOpt -> ShowS
showsPrec :: Int -> WsOpt -> ShowS
$cshow :: WsOpt -> String
show :: WsOpt -> String
$cshowList :: [WsOpt] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS WsType
readsPrec :: Int -> ReadS WsType
$creadList :: ReadS [WsType]
readList :: ReadS [WsType]
$creadPrec :: ReadPrec WsType
readPrec :: ReadPrec WsType
$creadListPrec :: ReadPrec [WsType]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> WsType -> ShowS
showsPrec :: Int -> WsType -> ShowS
$cshow :: WsType -> String
show :: WsType -> String
$cshowList :: [WsType] -> ShowS
showList :: [WsType] -> ShowS
Show, WsType -> WsType -> Bool
(WsType -> WsType -> Bool)
-> (WsType -> WsType -> Bool) -> Eq WsType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WsType -> WsType -> Bool
== :: WsType -> WsType -> Bool
$c/= :: WsType -> WsType -> Bool
/= :: 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
$cshowsPrec :: Int -> EwmhState -> ShowS
showsPrec :: Int -> EwmhState -> ShowS
$cshow :: EwmhState -> String
show :: EwmhState -> String
$cshowList :: [EwmhState] -> ShowS
showList :: [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
$cshowsPrec :: Int -> Client -> ShowS
showsPrec :: Int -> Client -> ShowS
$cshow :: Client -> String
show :: Client -> String
$cshowList :: [Client] -> ShowS
showList :: [Client] -> ShowS
Show
getAtom :: String -> M Atom
getAtom :: String -> M Window
getAtom String
s = do
d <- (EwmhConf -> Display) -> M Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks EwmhConf -> Display
display
liftIO $ internAtom d s False
windowProperty32 :: String -> Window -> M (Maybe [CLong])
windowProperty32 :: String -> Window -> M (Maybe [CLong])
windowProperty32 String
s Window
w = do
C {display} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
a <- getAtom s
liftIO $ getWindowProperty32 display a w
windowProperty8 :: String -> Window -> M (Maybe [CChar])
windowProperty8 :: String -> Window -> M (Maybe [CChar])
windowProperty8 String
s Window
w = do
C {display} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
a <- getAtom s
liftIO $ getWindowProperty8 display a 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
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
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
$c>>= :: forall a b. M a -> (a -> M b) -> M b
>>= :: forall a b. M a -> (a -> M b) -> M b
$c>> :: forall a b. M a -> M b -> M b
>> :: forall a b. M a -> M b -> M b
$creturn :: forall a. a -> M a
return :: forall a. a -> M a
Monad, (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
$cfmap :: forall a b. (a -> b) -> M a -> M b
fmap :: forall a b. (a -> b) -> M a -> M b
$c<$ :: forall a b. a -> M b -> M a
<$ :: forall a b. a -> M b -> M a
Functor, Functor M
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
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
$cpure :: forall a. a -> M a
pure :: forall a. a -> M a
$c<*> :: forall a b. M (a -> b) -> M a -> M b
<*> :: forall a b. M (a -> b) -> M a -> M b
$cliftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
liftA2 :: forall a b c. (a -> b -> c) -> M a -> M b -> M c
$c*> :: forall a b. M a -> M b -> M b
*> :: forall a b. M a -> M b -> M b
$c<* :: forall a b. M a -> M b -> M a
<* :: forall a b. M a -> M b -> M a
Applicative, Monad M
Monad M => (forall a. IO a -> M a) -> MonadIO M
forall a. IO a -> M a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> M a
liftIO :: forall a. IO a -> M a
MonadIO, MonadReader EwmhConf, MonadState EwmhState)
execM :: M a -> IO a
execM :: forall a. M a -> IO a
execM (M ReaderT EwmhConf (StateT EwmhState IO) a
m) = do
d <- String -> IO Display
openDisplay String
""
r <- rootWindow d (defaultScreen d)
let conf = Window -> Display -> EwmhConf
C Window
r Display
d
evalStateT (runReaderT m (C r d)) initialState
type Updater = Window -> M ()
updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater
updateCurrentDesktop :: Updater
updateCurrentDesktop Window
_ = do
C {root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root
case mwp of
Just [CLong
x] -> (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { currentDesktop = x })
Maybe [CLong]
_ -> () -> M ()
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateActiveWindow :: Updater
updateActiveWindow Window
_ = do
C {root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root
case mwp of
Just [CLong
x] -> (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { activeWindow = fromIntegral x })
Maybe [CLong]
_ -> () -> M ()
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateDesktopNames :: Updater
updateDesktopNames Window
_ = do
C {root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root
case mwp of
Just [CChar]
xs -> (EwmhState -> EwmhState) -> M ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\EwmhState
s -> EwmhState
s { desktopNames = parse xs })
Maybe [CChar]
_ -> () -> M ()
forall a. a -> M a
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 {root} <- M EwmhConf
forall r (m :: * -> *). MonadReader r m => m r
ask
mwp <- windowProperty32 "_NET_CLIENT_LIST" root
case mwp of
Just [CLong]
xs -> do
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' = [(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 -> 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 -> 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
modify (\EwmhState
s -> EwmhState
s { clients = Map.union (Map.intersection cl cl') cl'})
mapM_ (unmanage . fst) (Map.toList dels)
mapM_ (listen . fst) (Map.toList cl')
mapM_ (update . fst) (Map.toList new)
Maybe [CLong]
_ -> () -> M ()
forall a. a -> M a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> IO () -> m ()
forall a. IO a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> IO () -> m ()
forall a. IO a -> m a
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.alter f' w $ clients 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
mwp <- String -> Window -> M (Maybe [CChar])
windowProperty8 String
"_NET_WM_NAME" Window
w
case mwp of
Just [CChar]
xs -> Window -> (Client -> Client) -> M ()
modifyClient Window
w (\Client
c -> Client
c { windowName = decodeCChar xs })
Maybe [CChar]
_ -> () -> M ()
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateDesktop :: Updater
updateDesktop Window
w = do
mwp <- String -> Window -> M (Maybe [CLong])
windowProperty32 String
"_NET_WM_DESKTOP" Window
w
case mwp of
Just [CLong]
x -> Window -> (Client -> Client) -> M ()
modifyClient Window
w (\Client
c -> Client
c { desktops = Set.fromList x })
Maybe [CLong]
_ -> () -> M ()
forall a. a -> M a
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