summaryrefslogtreecommitdiffhomepage
path: root/src/Plugins/EWMH.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Plugins/EWMH.hs')
-rw-r--r--src/Plugins/EWMH.hs264
1 files changed, 264 insertions, 0 deletions
diff --git a/src/Plugins/EWMH.hs b/src/Plugins/EWMH.hs
new file mode 100644
index 0000000..d5b70cb
--- /dev/null
+++ b/src/Plugins/EWMH.hs
@@ -0,0 +1,264 @@
+{-# OPTIONS_GHC -w #-}
+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- 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 Plugins.EWMH (EWMH(..)) where
+
+import Control.Monad.State
+import Control.Monad.Reader
+import Graphics.X11 hiding (Modifier, Color)
+import Graphics.X11.Xlib.Extras
+import Plugins
+#ifdef UTF8
+#undef UTF8
+import Codec.Binary.UTF8.String as UTF8
+#define UTF8
+#endif
+import Foreign.C (CChar, CLong)
+import XUtil (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 (Read, Show)
+
+instance Exec EWMH where
+ alias EWMH = "EWMH"
+
+ start ew cb = allocaXEvent $ \ep -> execM $ do
+ d <- asks display
+ r <- asks root
+
+ liftIO xSetErrorHandler
+
+ liftIO $ selectInput d r propertyChangeMask
+ handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return 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 = a, ev_window = w } -> do
+ case lookup a handlers' of
+ Just f -> f w
+ _ -> return ()
+ _ -> return ()
+
+ return ()
+
+defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty]
+ , Layout
+ , Color "#00ee00" "" :$ Short 120 :$ WindowName]
+
+fmtOf EWMH = flip fmt defaultPP
+fmtOf (EWMHFMT f) = flip fmt f
+
+sep :: [a] -> [[a]] -> [a]
+sep x xs = intercalate x $ filter (not . null) xs
+
+fmt :: EwmhState -> Component -> String
+fmt e (Text s) = s
+fmt e (l :+ r) = fmt e l ++ fmt e r
+fmt e (m :$ r) = modifier m $ fmt e r
+fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs
+fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e)
+fmt e Layout = layout e
+fmt e (Workspaces opts) = sep " "
+ [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as]
+ | (n, as) <- attrs]
+ where
+ stats i = [ (Current, i == currentDesktop e)
+ , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e)
+ -- TODO for visible , (Visibl
+ ]
+ attrs :: [(String, [WsType])]
+ attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)]
+ nonEmptys = Set.unions . map desktops . Map.elems $ clients e
+
+modifier :: Modifier -> (String -> String)
+modifier Hide = const ""
+modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg
+ , ">", x, "</fc>"]
+modifier (Short n) = take n
+modifier (Wrap l r) = \x -> l ++ x ++ r
+
+data Component = Text String
+ | Component :+ Component
+ | Modifier :$ Component
+ | Sep Component [Component]
+ | WindowName
+ | Layout
+ | Workspaces [WsOpt]
+ deriving (Read, Show)
+
+infixr 0 :$
+infixr 5 :+
+
+data Modifier = Hide
+ | Color String String
+ | Short Int
+ | Wrap String String
+ deriving (Read, Show)
+
+data WsOpt = Modifier :% WsType
+ | WSep Component
+ deriving (Read, Show)
+infixr 0 :%
+
+data WsType = Current | Empty | Visible
+ deriving (Read, Show, Eq)
+
+data EwmhConf = C { root :: Window
+ , display :: Display }
+
+data EwmhState = S { currentDesktop :: CLong
+ , activeWindow :: Window
+ , desktopNames :: [String]
+ , layout :: String
+ , clients :: Map Window Client }
+ deriving Show
+
+data Client = Cl { windowName :: String
+ , desktops :: Set CLong }
+ deriving Show
+
+getAtom :: String -> M Atom
+getAtom s = do
+ d <- asks display
+ liftIO $ internAtom d s False
+
+windowProperty32 :: String -> Window -> M (Maybe [CLong])
+windowProperty32 s w = do
+ (C {display}) <- ask
+ a <- getAtom s
+ liftIO $ getWindowProperty32 display a w
+
+windowProperty8 :: String -> Window -> M (Maybe [CChar])
+windowProperty8 s w = do
+ (C {display}) <- ask
+ a <- getAtom s
+ liftIO $ getWindowProperty8 display a w
+
+initialState :: EwmhState
+initialState = S 0 0 [] [] Map.empty
+
+initialClient :: Client
+initialClient = Cl "" Set.empty
+
+handlers, clientHandlers :: [(String, Updater)]
+handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop)
+ , ("_NET_DESKTOP_NAMES", updateDesktopNames )
+ , ("_NET_ACTIVE_WINDOW", updateActiveWindow)
+ , ("_NET_CLIENT_LIST", updateClientList)
+ ] ++ clientHandlers
+
+clientHandlers = [ ("_NET_WM_NAME", updateName)
+ , ("_NET_WM_DESKTOP", updateDesktop) ]
+
+newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a)
+ deriving (Monad, Functor, MonadIO, MonadReader EwmhConf, MonadState EwmhState)
+
+execM :: M a -> IO a
+execM (M m) = do
+ d <- openDisplay ""
+ r <- rootWindow d (defaultScreen d)
+ let conf = C r d
+ evalStateT (runReaderT m (C r d)) initialState
+
+type Updater = Window -> M ()
+
+updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater
+updateCurrentDesktop _ = do
+ (C {root}) <- ask
+ mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root
+ case mwp of
+ Just [x] -> modify (\s -> s { currentDesktop = x })
+ _ -> return ()
+
+updateActiveWindow _ = do
+ (C {root}) <- ask
+ mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root
+ case mwp of
+ Just [x] -> modify (\s -> s { activeWindow = fromIntegral x })
+ _ -> return ()
+
+updateDesktopNames _ = do
+ (C {root}) <- ask
+ mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root
+ case mwp of
+ Just xs -> modify (\s -> s { desktopNames = parse xs })
+ _ -> return ()
+ where
+ dropNull ('\0':xs) = xs
+ dropNull xs = xs
+
+ split [] = []
+ split xs = case span (/= '\0') xs of
+ (x, ys) -> x : split (dropNull ys)
+ parse = split . decodeCChar
+
+updateClientList _ = do
+ (C {root}) <- ask
+ mwp <- windowProperty32 "_NET_CLIENT_LIST" root
+ case mwp of
+ Just xs -> do
+ cl <- gets clients
+ let cl' = Map.fromList $ map (flip (,) initialClient . fromIntegral) xs
+ dels = Map.difference cl cl'
+ new = Map.difference cl' cl
+ modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'})
+ mapM_ unmanage (map fst $ Map.toList dels)
+ mapM_ listen (map fst $ Map.toList cl')
+ mapM_ update (map fst $ Map.toList new)
+ _ -> return ()
+ where
+ unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0
+ listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask
+ update w = mapM_ (($ w) . snd) clientHandlers
+
+modifyClient :: Window -> (Client -> Client) -> M ()
+modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s })
+ where
+ f' Nothing = Just $ f initialClient
+ f' (Just x) = Just $ f x
+
+updateName w = do
+ mwp <- windowProperty8 "_NET_WM_NAME" w
+ case mwp of
+ Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs })
+ _ -> return ()
+
+updateDesktop w = do
+ mwp <- windowProperty32 "_NET_WM_DESKTOP" w
+ case mwp of
+ Just x -> modifyClient w (\c -> c { desktops = Set.fromList x })
+ _ -> return ()
+
+decodeCChar :: [CChar] -> String
+#ifdef UTF8
+#undef UTF8
+decodeCChar = UTF8.decode . map fromIntegral
+#define UTF8
+#else
+decodeCChar = map (toEnum . fromIntegral)
+#endif
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 09:19:26 +0000