From 50134d5b5c4baabdfb35c0aeb8bf53d29f009c4d Mon Sep 17 00:00:00 2001 From: jao Date: Wed, 21 Nov 2018 23:51:41 +0000 Subject: All sources moved inside src --- src/Xmobar/Plugins/EWMH.hs | 265 --------------------------------------------- 1 file changed, 265 deletions(-) delete mode 100644 src/Xmobar/Plugins/EWMH.hs (limited to 'src/Xmobar/Plugins/EWMH.hs') diff --git a/src/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs deleted file mode 100644 index 363ec90..0000000 --- a/src/Xmobar/Plugins/EWMH.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# 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 --- 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.Plugins -#ifdef UTF8 -#undef UTF8 -import Codec.Binary.UTF8.String as UTF8 -#define UTF8 -#endif -import Foreign.C (CChar, CLong) -import Xmobar.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 } -> - 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, Applicative, 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 ((, 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 . fst) (Map.toList dels) - mapM_ (listen . fst) (Map.toList cl') - mapM_ (update . 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