From fbdc9d635d9e2ddcf11e8f4adcbfafd16ea90e3b Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Wed, 9 Dec 2009 03:16:20 +0100 Subject: Add very experimental EWMH plugin Ignore-this: 9837736ecbe1f4595f7f892bbfa3f620 darcs-hash:20091209021620-a5988-d6413cf4cde6bae98037e277f47347392e7c710a.gz --- Plugins/EWMH.hs | 263 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 263 insertions(+) create mode 100644 Plugins/EWMH.hs (limited to 'Plugins') diff --git a/Plugins/EWMH.hs b/Plugins/EWMH.hs new file mode 100644 index 0000000..0718aa4 --- /dev/null +++ b/Plugins/EWMH.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.EWMH +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- 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 ["", x, ""] +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 -- cgit v1.2.3