summaryrefslogtreecommitdiffhomepage
path: root/Plugins/EWMH.hs
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2010-12-21 02:36:35 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2010-12-21 02:36:35 +0100
commite3853a9cb2a9a2cffa174d1334e2ca8ba610f151 (patch)
tree13aa04faea320afe85636e23686280386c1c2910 /Plugins/EWMH.hs
parent598bfe5deeff079280e8513c55dc7bda3e8cf9a0 (diff)
downloadxmobar-e3853a9cb2a9a2cffa174d1334e2ca8ba610f151.tar.gz
xmobar-e3853a9cb2a9a2cffa174d1334e2ca8ba610f151.tar.bz2
Haskell sources moved to src/ to unclutter toplevel
Diffstat (limited to 'Plugins/EWMH.hs')
-rw-r--r--Plugins/EWMH.hs264
1 files changed, 0 insertions, 264 deletions
diff --git a/Plugins/EWMH.hs b/Plugins/EWMH.hs
deleted file mode 100644
index d5b70cb..0000000
--- a/Plugins/EWMH.hs
+++ /dev/null
@@ -1,264 +0,0 @@
-{-# 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