From aa507d0bda3919e1885edb327b855908f2aafcb8 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 12:12:17 +0200 Subject: BufferedPipeReader: A plugin for temporary data display This plugin allows to display data from multiple pipes. New data will always overwrite the currently displayed data. However, if a timeout is specified, the previous content is restored. Configuration works like this: BufferedPipeReader [ ( Timeout, "/path/to/fifo/pipe" ), (..), .. ] If Timeout is set to 0 then the content is persistent, i.e. it will be reset to any previous value, it will itself become the previous value. If Timeout is set to a negative value the earth will stop spinning, so don't do it. --- src/Config.hs | 3 +- src/Plugins/BufferedPipeReader.hs | 78 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+), 1 deletion(-) create mode 100644 src/Plugins/BufferedPipeReader.hs (limited to 'src') diff --git a/src/Config.hs b/src/Config.hs index 4405314..712687d 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -28,6 +28,7 @@ import {-# SOURCE #-} Runnable import Plugins.Monitors import Plugins.Date import Plugins.PipeReader +import Plugins.BufferedPipeReader import Plugins.CommandReader import Plugins.StdinReader import Plugins.XMonadLog @@ -113,7 +114,7 @@ infixr :*: -- the 'Runnable.Runnable' Read instance. To install a plugin just add -- the plugin's type to the list of types (separated by ':*:') appearing in -- this function's type signature. -runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: +runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: BufferedPipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: #ifdef INOTIFY Mail :*: MBox :*: #endif diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs new file mode 100644 index 0000000..1fb9dcb --- /dev/null +++ b/src/Plugins/BufferedPipeReader.hs @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.BufferedPipeReader +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading (temporarily) from named pipes with reset +-- +----------------------------------------------------------------------------- + +module Plugins.BufferedPipeReader where + +import Control.Monad(forM_, when) +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +-- import System.IO.Unsafe(unsafePerformIO) + +import Plugins + +data BufferedPipeReader = BufferedPipeReader String [(Int, String)] + deriving (Read, Show) + +-- pipeState :: MVar String +-- pipeState = unsafePerformIO $ newMVar "" + +-- pipe :: (String -> IO ()) -> Handle -> IO () +-- pipe cb h = hGetLineSafe h >>= cb + +instance Exec BufferedPipeReader where + alias ( BufferedPipeReader a _ ) = a + start ( BufferedPipeReader _ ps ) cb = do + + (chan, str, rst) <- initV + forM_ ps $ \p -> forkIO $ reader p chan + writer chan str rst + + where + initV :: IO ( TChan (Int, String), TVar String, TVar Bool ) + initV = atomically $ do + tc <- newTChan + ts <- newTVar "" + tb <- newTVar False + return (tc, ts, tb) + + reader :: (Int, FilePath) -> TChan (Int, String) -> IO () + reader p@(to, fp) tc = do + openFile fp ReadWriteMode >>= hGetLineSafe >>= \dt -> + atomically $ writeTChan tc (to, dt) + reader p tc + + writer :: TChan (Int, String) -> TVar String -> TVar Bool -> IO () + writer tc ts otb = do + (to, dt, ntb) <- update + cb dt + when (to /= 0) $ sfork $ reset to ts ntb + writer tc ts ntb + + where + sfork :: IO () -> IO () + sfork f = forkIO f >> return () + + update :: IO (Int, String, TVar Bool) + update = atomically $ do + (to, dt) <- readTChan tc + when (to == 0) $ writeTVar ts dt + writeTVar otb False + tb <- newTVar True + return (to, dt, tb) + + reset :: Int -> TVar String -> TVar Bool -> IO () + reset to ts tb = do + threadDelay ( to * 100 * 1000 ) + readTVarIO tb >>= flip when ( readTVarIO ts >>= cb ) -- cgit v1.2.3 From a52c4a076807ae04db67894aebd741924ff9f926 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 20:24:53 +0200 Subject: Modularize Window handling functions These functions are about creation, positioning and property setting of the xmobar window. An own module does them justice and eases the task of adding functions for revealing/hiding and toggling the window. --- src/Window.hs | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Xmobar.hs | 130 +------------------------------------------------------ 2 files changed, 139 insertions(+), 128 deletions(-) create mode 100644 src/Window.hs (limited to 'src') diff --git a/src/Window.hs b/src/Window.hs new file mode 100644 index 0000000..34ecbf4 --- /dev/null +++ b/src/Window.hs @@ -0,0 +1,137 @@ +module Window where + +import Prelude hiding (catch) +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama + +import Control.Monad.Reader +import Data.Maybe(fromMaybe) +import System.Posix.Process (getProcessID) + +import Config +import XUtil + +-- $window + +-- | The function to create the initial window +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin d fs c = do + let dflt = defaultScreen d + srs <- getScreenInfo d + rootw <- rootWindow d dflt + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + (r,o) = setPosition (position c) srs (fi ht) + win <- newWindow d (defaultScreenOfDisplay d) rootw r o + setProperties r c d win srs + when (lowerOnStart c) (lowerWindow d win) + mapWindow d win + return (r,win) + +-- | Updates the size and position of the window +repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle +repositionWin d win fs c = do + srs <- getScreenInfo d + (as,ds) <- textExtents fs "0" + let ht = as + ds + 4 + (r,_) = setPosition (position c) srs (fi ht) + moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) + setProperties r c d win srs + return r + +setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) +setPosition p rs ht = + case p' of + Top -> (Rectangle rx ry rw h, True) + TopW a i -> (Rectangle (ax a i) ry (nw i) h, True) + TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True) + Bottom -> (Rectangle rx ny rw h, True) + BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True) + BottomSize a i ch -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True) + Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True) + OnScreen _ p'' -> setPosition p'' [scr] ht + where + (scr@(Rectangle rx ry rw rh), p') = + case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) + _ -> (head rs, p) + ny = ry + fi (rh - ht) + center i = rx + fi (div (remwid i) 2) + right i = rx + fi (remwid i) + remwid i = rw - pw (fi i) + ax L = const rx + ax R = right + ax C = center + pw i = rw * min 100 i `div` 100 + nw = fi . pw . fi + h = fi ht + mh h' = max (fi h') h + ny' h' = ry + fi (rh - mh h') + safeIndex i = lookup i . zip [0..] + +setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setProperties r c d w srs = do + a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False + c1 <- internAtom d "CARDINAL" False + a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False + c2 <- internAtom d "ATOM" False + v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False + p <- internAtom d "_NET_WM_PID" False + + setTextProperty d w "xmobar" wM_CLASS + setTextProperty d w "xmobar" wM_NAME + + changeProperty32 d w a1 c1 propModeReplace $ map fi $ + getStrutValues r (position c) (getRootWindowHeight srs) + changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] + + getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral + +getRootWindowHeight :: [Rectangle] -> Int +getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) + where + getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) + +getStrutValues :: Rectangle -> XPosition -> Int -> [Int] +getStrutValues r@(Rectangle x y w h) p rwh = + case p of + OnScreen _ p' -> getStrutValues r p' rwh + Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + Static {} -> getStaticStrutValues p rwh + where st = fi y + fi h + sb = rwh - fi y + nx = fi x + nw = fi (x + fi w - 1) + +-- get some reaonable strut values for static placement. +getStaticStrutValues :: XPosition -> Int -> [Int] +getStaticStrutValues (Static cx cy cw ch) rwh + -- if the yPos is in the top half of the screen, then assume a Top + -- placement, otherwise, it's a Bottom placement + | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] + | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] + where st = cy + ch + sb = rwh - cy + xs = cx -- a simple calculation for horizontal (x) placement + xe = xs + cw +getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + +drawBorder :: Border -> Display -> Drawable -> GC -> Pixel + -> Dimension -> Dimension -> IO () +drawBorder b d p gc c wi ht = case b of + NoBorder -> return () + TopB -> drawBorder (TopBM 0) d p gc c w h + BottomB -> drawBorder (BottomBM 0) d p gc c w h + FullB -> drawBorder (FullBM 0) d p gc c w h + TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 + BottomBM m -> let rw = fi h - fi m in + sf >> drawLine d p gc 0 rw (fi w) rw + FullBM m -> let pad = 2 * fi m; mp = fi m in + sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) + where sf = setForeground d gc c + (w, h) = (wi - 1, ht - 1) diff --git a/src/Xmobar.hs b/src/Xmobar.hs index c348f99..0b744de 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -41,15 +41,13 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception hiding (handle) import Data.Bits -import Data.Maybe(fromMaybe) -import Data.Typeable (Typeable) -import System.Posix.Process (getProcessID) -import System.Posix.Signals import Config import Parsers import Commands import Runnable +import Signal +import Window import XUtil -- $main @@ -197,115 +195,6 @@ startCommand (com,s,ss) return (Just h,var) where is = s ++ "Updating..." ++ ss --- $window - --- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) -createWin d fs c = do - let dflt = defaultScreen d - srs <- getScreenInfo d - rootw <- rootWindow d dflt - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,o) = setPosition (position c) srs (fi ht) - win <- newWindow d (defaultScreenOfDisplay d) rootw r o - setProperties r c d win srs - when (lowerOnStart c) (lowerWindow d win) - mapWindow d win - return (r,win) - --- | Updates the size and position of the window -repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle -repositionWin d win fs c = do - srs <- getScreenInfo d - (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,_) = setPosition (position c) srs (fi ht) - moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) - setProperties r c d win srs - return r - -setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) -setPosition p rs ht = - case p' of - Top -> (Rectangle rx ry rw h, True) - TopW a i -> (Rectangle (ax a i) ry (nw i) h, True) - TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True) - Bottom -> (Rectangle rx ny rw h, True) - BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True) - BottomSize a i ch -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True) - Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True) - OnScreen _ p'' -> setPosition p'' [scr] ht - where - (scr@(Rectangle rx ry rw rh), p') = - case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) - _ -> (head rs, p) - ny = ry + fi (rh - ht) - center i = rx + fi (div (remwid i) 2) - right i = rx + fi (remwid i) - remwid i = rw - pw (fi i) - ax L = const rx - ax R = right - ax C = center - pw i = rw * min 100 i `div` 100 - nw = fi . pw . fi - h = fi ht - mh h' = max (fi h') h - ny' h' = ry + fi (rh - mh h') - safeIndex i = lookup i . zip [0..] - -setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () -setProperties r c d w srs = do - a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False - c1 <- internAtom d "CARDINAL" False - a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False - c2 <- internAtom d "ATOM" False - v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False - p <- internAtom d "_NET_WM_PID" False - - setTextProperty d w "xmobar" wM_CLASS - setTextProperty d w "xmobar" wM_NAME - - changeProperty32 d w a1 c1 propModeReplace $ map fi $ - getStrutValues r (position c) (getRootWindowHeight srs) - changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] - - getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral - -getRootWindowHeight :: [Rectangle] -> Int -getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) - where - getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) - -getStrutValues :: Rectangle -> XPosition -> Int -> [Int] -getStrutValues r@(Rectangle x y w h) p rwh = - case p of - OnScreen _ p' -> getStrutValues r p' rwh - Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - Static {} -> getStaticStrutValues p rwh - where st = fi y + fi h - sb = rwh - fi y - nx = fi x - nw = fi (x + fi w - 1) - --- get some reaonable strut values for static placement. -getStaticStrutValues :: XPosition -> Int -> [Int] -getStaticStrutValues (Static cx cy cw ch) rwh - -- if the yPos is in the top half of the screen, then assume a Top - -- placement, otherwise, it's a Bottom placement - | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] - | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] - where st = cy + ch - sb = rwh - cy - xs = cx -- a simple calculation for horizontal (x) placement - xe = xs + cw -getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - updateWin :: TVar [String] -> X () updateWin v = do xc <- ask @@ -346,21 +235,6 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do -- resync io $ sync d True -drawBorder :: Border -> Display -> Drawable -> GC -> Pixel - -> Dimension -> Dimension -> IO () -drawBorder b d p gc c wi ht = case b of - NoBorder -> return () - TopB -> drawBorder (TopBM 0) d p gc c w h - BottomB -> drawBorder (BottomBM 0) d p gc c w h - FullB -> drawBorder (FullBM 0) d p gc c w h - TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 - BottomBM m -> let rw = fi h - fi m in - sf >> drawLine d p gc 0 rw (fi w) rw - FullBM m -> let pad = 2 * fi m; mp = fi m in - sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) - where sf = setForeground d gc c - (w, h) = (wi - 1, ht - 1) - -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> XFont -> Position -> Align -> [(String, String, Position)] -> X () -- cgit v1.2.3 From 77ce9cbe7f8371aadf24713a6d700a436d983eaf Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 19:54:22 +0200 Subject: Move signal handler and data types to own module This is necessary to make SignalType available for other modules without import loops. This also decoupels the modules and their functionality a bit more so this is generally a cleaner solution. --- src/Signal.hs | 33 +++++++++++++++++++++++++++++++++ src/Xmobar.hs | 25 +------------------------ 2 files changed, 34 insertions(+), 24 deletions(-) create mode 100644 src/Signal.hs (limited to 'src') diff --git a/src/Signal.hs b/src/Signal.hs new file mode 100644 index 0000000..3919d86 --- /dev/null +++ b/src/Signal.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Signal where + +import Data.Typeable (Typeable) +import Control.Concurrent +import Control.Exception hiding (handle) +import System.Posix.Signals + +data WakeUp = WakeUp deriving (Show,Typeable) +instance Exception WakeUp + +data SignalType = Wakeup + | Reposition + | ChangeScreen + +-- | Signal handling +setupSignalHandler :: IO (MVar SignalType) +setupSignalHandler = do + tid <- newEmptyMVar + installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing + installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing + return tid + +updatePosHandler :: MVar SignalType -> IO () +updatePosHandler sig = do + putMVar sig Reposition + return () + +changeScreenHandler :: MVar SignalType -> IO () +changeScreenHandler sig = do + putMVar sig ChangeScreen + return () diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 0b744de..6c2965c 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -39,7 +39,7 @@ import Control.Arrow ((&&&)) import Control.Monad.Reader import Control.Concurrent import Control.Concurrent.STM -import Control.Exception hiding (handle) +import Control.Exception (catch, SomeException(..)) import Data.Bits import Config @@ -70,11 +70,6 @@ data XConf = runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc -data WakeUp = WakeUp deriving (Show,Typeable) -instance Exception WakeUp - -data SignalType = Wakeup | Reposition | ChangeScreen - -- | Starts the main event loop and threads startLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO () startLoop xcfg@(XConf _ _ w _ _) vs = do @@ -162,24 +157,6 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do return (ocfg {position = OnScreen 1 o}) --- | Signal handling -setupSignalHandler :: IO (MVar SignalType) -setupSignalHandler = do - tid <- newEmptyMVar - installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing - installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing - return tid - -updatePosHandler :: MVar SignalType -> IO () -updatePosHandler sig = do - putMVar sig Reposition - return () - -changeScreenHandler :: MVar SignalType -> IO () -changeScreenHandler sig = do - putMVar sig ChangeScreen - return () - -- $command -- | Runs a command as an independent thread and returns its thread id -- cgit v1.2.3 From db34ddc05fd308986a1be4140f8f8ddf14598122 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 20:01:38 +0200 Subject: Add signals for {show,hid,toggl}ing Also make them {Read,Show}able which can be useful for printf debugging and does not hurt otherwise. --- src/Signal.hs | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/Signal.hs b/src/Signal.hs index 3919d86..0acdea1 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -13,6 +13,10 @@ instance Exception WakeUp data SignalType = Wakeup | Reposition | ChangeScreen + | Hide + | Reveal + | Toggle + deriving (Read, Show) -- | Signal handling setupSignalHandler :: IO (MVar SignalType) -- cgit v1.2.3 From 536273a9d980cf3e71d8d05813e18b3ebcaf9233 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 20:02:43 +0200 Subject: Extend the interface so that plugins can send signals Also: realign methods to look pretty again. --- src/Commands.hs | 4 ++++ src/Runnable.hs | 5 +++-- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Commands.hs b/src/Commands.hs index 1bfbb94..f31c53c 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -30,6 +30,8 @@ import Data.Char import System.Process import System.Exit import System.IO (hClose) + +import Signal import XUtil class Show e => Exec e where @@ -42,6 +44,8 @@ class Show e => Exec e where start :: e -> (String -> IO ()) -> IO () start e cb = go where go = run e >>= cb >> tenthSeconds (rate e) >> go + trigger :: e -> (Maybe SignalType -> IO ()) -> IO () + trigger _ sh = sh Nothing data Command = Com Program Args Alias Rate deriving (Show,Read,Eq) diff --git a/src/Runnable.hs b/src/Runnable.hs index 56fedb3..84d9b77 100644 --- a/src/Runnable.hs +++ b/src/Runnable.hs @@ -29,8 +29,9 @@ import Commands data Runnable = forall r . (Exec r, Read r, Show r) => Run r instance Exec Runnable where - start (Run a) = start a - alias (Run a) = alias a + start (Run a) = start a + alias (Run a) = alias a + trigger (Run a) = trigger a instance Show Runnable where show (Run x) = show x -- cgit v1.2.3 From fa4b999c73067cb55e316b94fe62aebb147cea98 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 10:12:39 +0200 Subject: Create signal handler in main and pass it down to the start* functions This is necessary for setting up the signal callback (trigger) from the Plugin interface. As another benefit it is now possible to implement the lowerOnStart config option properly by simply sending a Hide signal in startLoop. --- src/Main.hs | 7 +++++-- src/Window.hs | 1 - src/Xmobar.hs | 14 ++++++++------ 3 files changed, 13 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 4c3f351..c7045b5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -36,6 +36,8 @@ import System.Environment import System.Posix.Files import Control.Monad (unless) +import Signal (setupSignalHandler, SignalType(..)) + -- $main -- | The main entry point @@ -55,9 +57,10 @@ main = do conf <- doOpts c o fs <- initFont d (font conf) cls <- mapM (parseTemplate conf) (splitTemplate conf) - vars <- mapM (mapM startCommand) cls + sig <- setupSignalHandler + vars <- mapM (mapM $ startCommand sig) cls (r,w) <- createWin d fs conf - startLoop (XConf d r w fs conf) vars + startLoop (XConf d r w fs conf) sig vars -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/Window.hs b/src/Window.hs index 34ecbf4..4917f57 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -25,7 +25,6 @@ createWin d fs c = do (r,o) = setPosition (position c) srs (fi ht) win <- newWindow d (defaultScreenOfDisplay d) rootw r o setProperties r c d win srs - when (lowerOnStart c) (lowerWindow d win) mapWindow d win return (r,win) diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 6c2965c..1b58352 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -71,10 +71,10 @@ runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc -- | Starts the main event loop and threads -startLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO () -startLoop xcfg@(XConf _ _ w _ _) vs = do +startLoop :: XConf -> MVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () +startLoop xcfg@(XConf _ _ w _ conf) sig vs = do tv <- atomically $ newTVar [] - sig <- setupSignalHandler + when (lowerOnStart conf) $ putMVar sig Hide _ <- forkIO (checker tv [] vs sig `catch` \(SomeException _) -> void (putStrLn "Thread checker failed")) #ifdef THREADED_RUNTIME @@ -156,19 +156,21 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do o -> return (ocfg {position = OnScreen 1 o}) - -- $command -- | Runs a command as an independent thread and returns its thread id -- and the TVar the command will be writing to. -startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String) -startCommand (com,s,ss) +startCommand :: MVar SignalType + -> (Runnable,String,String) + -> IO (Maybe ThreadId, TVar String) +startCommand sig (com,s,ss) | alias com == "" = do var <- atomically $ newTVar is atomically $ writeTVar var (s ++ ss) return (Nothing,var) | otherwise = do var <- atomically $ newTVar is let cb str = atomically $ writeTVar var (s ++ str ++ ss) h <- forkIO $ start com cb + _ <- forkIO $ trigger com ( maybe (return ()) (putMVar sig) ) return (Just h,var) where is = s ++ "Updating..." ++ ss -- cgit v1.2.3 From cc77b5a7bc8309f694fd0aed4110b92f16316c0b Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Wed, 8 Aug 2012 20:30:40 +0200 Subject: Add functions for {reveal,hid,toggl}ing the window Toggling is based is based on the current window status. If unmapped then reveal else hide. Sync is necessary or delays might occur. The functions are called from the event loop when the according signal is received When mapping (revealing) the window again we need to set the struts property again. The easiest way to do this is to call repositionWin. However, repositionWin needs access to the Config structure which is available in eventLoop. Because decomposition wouldn't be easy and I don't want to pass Config down to showWindow (which would need to return the new Rectangle then) this is done here. --- src/Window.hs | 15 +++++++++++++++ src/Xmobar.hs | 11 +++++++++++ 2 files changed, 26 insertions(+) (limited to 'src') diff --git a/src/Window.hs b/src/Window.hs index 4917f57..e59c5ff 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -134,3 +134,18 @@ drawBorder b d p gc c wi ht = case b of sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) where sf = setForeground d gc c (w, h) = (wi - 1, ht - 1) + +hideWindow :: Display -> Window -> IO () +hideWindow d w = do + a <- internAtom d "_NET_WM_STRUT_PARTIAL" False + c <- internAtom d "CARDINAL" False + changeProperty32 d w a c propModeReplace $ replicate 12 0 + unmapWindow d w + sync d False + +showWindow :: Display -> Window -> IO () +showWindow d w = mapWindow d w >> sync d False + +isMapped :: Display -> Window -> IO Bool +isMapped d w = fmap ism $ getWindowAttributes d w + where ism (WindowAttributes { wa_map_state = wms }) = wms /= waIsUnmapped diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 1b58352..a65a236 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -140,7 +140,18 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do ncfg <- updateConfigPosition cfg reposWindow ncfg + Hide -> hide + Reveal -> reveal + Toggle -> toggle + where + hide = hideWindow d w >> eventLoop tv xc signal + reveal = do + r' <- repositionWin d w fs cfg + showWindow d w + eventLoop tv (XConf d r' w fs cfg) signal + toggle = isMapped d w >>= \b -> if b then hide else reveal + reposWindow rcfg = do r' <- repositionWin d w fs rcfg eventLoop tv (XConf d r' w fs rcfg) signal -- cgit v1.2.3 From 58427c76c892334522dfb28ea2d2a858469fc65a Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 09:43:49 +0200 Subject: Cosmetic surgery Realign methods, remove unnecessary imports and remove clutter --- src/Commands.hs | 16 ++++++++-------- src/Main.hs | 2 +- src/Plugins/BufferedPipeReader.hs | 6 ------ src/Window.hs | 1 - 4 files changed, 9 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/Commands.hs b/src/Commands.hs index f31c53c..b501022 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -35,14 +35,14 @@ import Signal import XUtil class Show e => Exec e where - alias :: e -> String - alias e = takeWhile (not . isSpace) $ show e - rate :: e -> Int - rate _ = 10 - run :: e -> IO String - run _ = return "" - start :: e -> (String -> IO ()) -> IO () - start e cb = go + alias :: e -> String + alias e = takeWhile (not . isSpace) $ show e + rate :: e -> Int + rate _ = 10 + run :: e -> IO String + run _ = return "" + start :: e -> (String -> IO ()) -> IO () + start e cb = go where go = run e >>= cb >> tenthSeconds (rate e) >> go trigger :: e -> (Maybe SignalType -> IO ()) -> IO () trigger _ sh = sh Nothing diff --git a/src/Main.hs b/src/Main.hs index c7045b5..5ef5db6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -36,7 +36,7 @@ import System.Environment import System.Posix.Files import Control.Monad (unless) -import Signal (setupSignalHandler, SignalType(..)) +import Signal (setupSignalHandler) -- $main diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index 1fb9dcb..e232916 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -18,18 +18,12 @@ import Control.Monad(forM_, when) import Control.Concurrent import Control.Concurrent.STM import System.IO --- import System.IO.Unsafe(unsafePerformIO) import Plugins data BufferedPipeReader = BufferedPipeReader String [(Int, String)] deriving (Read, Show) --- pipeState :: MVar String --- pipeState = unsafePerformIO $ newMVar "" - --- pipe :: (String -> IO ()) -> Handle -> IO () --- pipe cb h = hGetLineSafe h >>= cb instance Exec BufferedPipeReader where alias ( BufferedPipeReader a _ ) = a diff --git a/src/Window.hs b/src/Window.hs index e59c5ff..9024fff 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -5,7 +5,6 @@ import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama -import Control.Monad.Reader import Data.Maybe(fromMaybe) import System.Posix.Process (getProcessID) -- cgit v1.2.3 From dd78c8bfa52ba0b10e6acf8bde8d467fb02a8d4e Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 10:25:52 +0200 Subject: Implement trigger method for BufferedPipeReader Plugin Using the trigger method activity on a pipe can now cause the window to appear (reveal) and disappear again after a given timeout. The timeout for hiding the window is the same as for restoring the pipes content. The timeout value is given in tenth of seconds. --- src/Plugins/BufferedPipeReader.hs | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index e232916..602862e 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -18,39 +18,48 @@ import Control.Monad(forM_, when) import Control.Concurrent import Control.Concurrent.STM import System.IO +import System.IO.Unsafe(unsafePerformIO) import Plugins +import Signal -data BufferedPipeReader = BufferedPipeReader String [(Int, String)] +data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] deriving (Read, Show) +signal :: MVar SignalType +signal = unsafePerformIO newEmptyMVar instance Exec BufferedPipeReader where - alias ( BufferedPipeReader a _ ) = a - start ( BufferedPipeReader _ ps ) cb = do + alias ( BufferedPipeReader a _ ) = a + + trigger br@( BufferedPipeReader _ _ ) sh = + takeMVar signal >>= sh . Just >> trigger br sh + + start ( BufferedPipeReader _ ps ) cb = do (chan, str, rst) <- initV forM_ ps $ \p -> forkIO $ reader p chan writer chan str rst where - initV :: IO ( TChan (Int, String), TVar String, TVar Bool ) + initV :: IO ( TChan (Int, Bool, String), TVar String, TVar Bool ) initV = atomically $ do tc <- newTChan ts <- newTVar "" tb <- newTVar False return (tc, ts, tb) - reader :: (Int, FilePath) -> TChan (Int, String) -> IO () - reader p@(to, fp) tc = do + reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () + reader p@(to, tg, fp) tc = do openFile fp ReadWriteMode >>= hGetLineSafe >>= \dt -> - atomically $ writeTChan tc (to, dt) + atomically $ writeTChan tc (to, tg, dt) reader p tc - writer :: TChan (Int, String) -> TVar String -> TVar Bool -> IO () + writer :: TChan (Int, Bool, String) -> TVar String -> TVar Bool -> IO () writer tc ts otb = do - (to, dt, ntb) <- update + (to, tg, dt, ntb) <- update cb dt + when tg $ putMVar signal Reveal when (to /= 0) $ sfork $ reset to ts ntb writer tc ts ntb @@ -58,15 +67,16 @@ instance Exec BufferedPipeReader where sfork :: IO () -> IO () sfork f = forkIO f >> return () - update :: IO (Int, String, TVar Bool) + update :: IO (Int, Bool, String, TVar Bool) update = atomically $ do - (to, dt) <- readTChan tc + (to, tg, dt) <- readTChan tc when (to == 0) $ writeTVar ts dt writeTVar otb False tb <- newTVar True - return (to, dt, tb) + return (to, tg, dt, tb) reset :: Int -> TVar String -> TVar Bool -> IO () reset to ts tb = do threadDelay ( to * 100 * 1000 ) - readTVarIO tb >>= flip when ( readTVarIO ts >>= cb ) + readTVarIO tb >>= + flip when ( putMVar signal Hide >> readTVarIO ts >>= cb ) -- cgit v1.2.3 From fc474471e12afd5ec958082a7246f2ee22fcc2cf Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 11:44:39 +0200 Subject: Bugfix: Replace TVar with TMVar for the old value This solves a problem when there is only one pipe in place. With a default value of "" and only one pipe with a timeout the value is overwritten with "" after the timeout. To prevent this from happening a TMVar is used which will never be filled if there is only one pipe. --- src/Plugins/BufferedPipeReader.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index 602862e..8a91967 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -42,10 +42,10 @@ instance Exec BufferedPipeReader where writer chan str rst where - initV :: IO ( TChan (Int, Bool, String), TVar String, TVar Bool ) + initV :: IO ( TChan (Int, Bool, String), TMVar String, TVar Bool ) initV = atomically $ do tc <- newTChan - ts <- newTVar "" + ts <- newEmptyTMVar tb <- newTVar False return (tc, ts, tb) @@ -55,7 +55,7 @@ instance Exec BufferedPipeReader where atomically $ writeTChan tc (to, tg, dt) reader p tc - writer :: TChan (Int, Bool, String) -> TVar String -> TVar Bool -> IO () + writer :: TChan (Int, Bool, String) -> TMVar String -> TVar Bool -> IO () writer tc ts otb = do (to, tg, dt, ntb) <- update cb dt @@ -70,13 +70,14 @@ instance Exec BufferedPipeReader where update :: IO (Int, Bool, String, TVar Bool) update = atomically $ do (to, tg, dt) <- readTChan tc - when (to == 0) $ writeTVar ts dt + when (to == 0) $ tryPutTMVar ts dt >> return () writeTVar otb False tb <- newTVar True return (to, tg, dt, tb) - reset :: Int -> TVar String -> TVar Bool -> IO () + reset :: Int -> TMVar String -> TVar Bool -> IO () reset to ts tb = do threadDelay ( to * 100 * 1000 ) - readTVarIO tb >>= - flip when ( putMVar signal Hide >> readTVarIO ts >>= cb ) + readTVarIO tb >>= \b -> when b $ do + putMVar signal Hide + atomically (tryTakeTMVar ts) >>= maybe (return ()) cb -- cgit v1.2.3 From 6c456e9e1f881fd70e9c1b357edfc5d63f7a3204 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Thu, 9 Aug 2012 12:07:33 +0200 Subject: Bugfix: Do not hide the window when toggling is off for this pipe The window became hidden although the toggling behaviour was set to False for a particular pipe. This fixes this behaviour and hides the window only if the configuration option is set to True. --- src/Plugins/BufferedPipeReader.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs index 8a91967..be6a652 100644 --- a/src/Plugins/BufferedPipeReader.hs +++ b/src/Plugins/BufferedPipeReader.hs @@ -60,7 +60,7 @@ instance Exec BufferedPipeReader where (to, tg, dt, ntb) <- update cb dt when tg $ putMVar signal Reveal - when (to /= 0) $ sfork $ reset to ts ntb + when (to /= 0) $ sfork $ reset to tg ts ntb writer tc ts ntb where @@ -75,9 +75,9 @@ instance Exec BufferedPipeReader where tb <- newTVar True return (to, tg, dt, tb) - reset :: Int -> TMVar String -> TVar Bool -> IO () - reset to ts tb = do + reset :: Int -> Bool -> TMVar String -> TVar Bool -> IO () + reset to tg ts tb = do threadDelay ( to * 100 * 1000 ) readTVarIO tb >>= \b -> when b $ do - putMVar signal Hide + when tg $ putMVar signal Hide atomically (tryTakeTMVar ts) >>= maybe (return ()) cb -- cgit v1.2.3 From 5074fdf2d6aa85ce17ad98112ec5019eb05a39c4 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 08:36:03 +0200 Subject: New configuration option "persistent" When persistent is set to True then xmobar will always be mapped (revealed) and never be hidden. The flag is checked in eventLoop and operation to map/unmap windows is not carried out if persistence is desired. --- src/Config.hs | 3 +++ src/Parsers.hs | 11 +++++++---- src/Xmobar.hs | 16 +++++++++++----- 3 files changed, 21 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Config.hs b/src/Config.hs index 712687d..47358b0 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -57,6 +57,8 @@ data Config = , borderColor :: String -- ^ Border color , lowerOnStart :: Bool -- ^ Lower to the bottom of the -- window stack on initialization + , persistent :: Bool -- ^ Whether automatic hiding should + -- be enabled or disabled , commands :: [Runnable] -- ^ For setting the command, the command arguments -- and refresh rate for the programs to run (optional) , sepChar :: String -- ^ The character to be used for indicating @@ -96,6 +98,7 @@ defaultConfig = , border = NoBorder , borderColor = "#BFBFBF" , lowerOnStart = True + , persistent = False , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 , Run StdinReader] , sepChar = "%" diff --git a/src/Parsers.hs b/src/Parsers.hs index f5f00a9..c92480e 100644 --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -131,13 +131,15 @@ parseConfig = runParser parseConf fields "Config" . stripComments <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition <|?> pBorder <|?> pBdColor - <|?> pLowerOnStart <|?> pCommands - <|?> pSepChar <|?> pAlignSep - <|?> pTemplate + <|?> pLowerOnStart <|?> pPersistent + <|?> pCommands <|?> pSepChar + <|?> pAlignSep <|?> pTemplate fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" , "border", "borderColor" ,"template", "position" - , "lowerOnStart", "commands"] + , "lowerOnStart", "persistent", "commands" + ] + pFont = strField font "font" pBgColor = strField bgColor "bgColor" pFgColor = strField fgColor "fgColor" @@ -148,6 +150,7 @@ parseConfig = runParser parseConf fields "Config" . stripComments pPosition = field position "position" $ tillFieldEnd >>= read' "position" pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart" + pPersistent = field persistent "persistent" $ tillFieldEnd >>= read' "persistent" pBorder = field border "border" $ tillFieldEnd >>= read' "border" pCommands = field commands "commands" $ readCommands diff --git a/src/Xmobar.hs b/src/Xmobar.hs index a65a236..1ae55bb 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -145,11 +145,17 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do Toggle -> toggle where - hide = hideWindow d w >> eventLoop tv xc signal - reveal = do - r' <- repositionWin d w fs cfg - showWindow d w - eventLoop tv (XConf d r' w fs cfg) signal + isPersistent = not $ persistent cfg + + hide = when isPersistent (hideWindow d w) >> eventLoop tv xc signal + + reveal = if isPersistent + then do + r' <- repositionWin d w fs cfg + showWindow d w + eventLoop tv (XConf d r' w fs cfg) signal + else eventLoop tv xc signal + toggle = isMapped d w >>= \b -> if b then hide else reveal reposWindow rcfg = do -- cgit v1.2.3 From 509eee4e98b5a9a1362a87f0d88e317d08b4dec2 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 08:42:32 +0200 Subject: New SignalType TogglePersistent By sending a TogglePersistent signal the configuration option "persistent" can be changed. Thus it is possible to hide or show xmobar constantly. --- src/Signal.hs | 1 + src/Xmobar.hs | 3 +++ 2 files changed, 4 insertions(+) (limited to 'src') diff --git a/src/Signal.hs b/src/Signal.hs index 0acdea1..ad19fdd 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -16,6 +16,7 @@ data SignalType = Wakeup | Hide | Reveal | Toggle + | TogglePersistent deriving (Read, Show) -- | Signal handling diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 1ae55bb..adbe956 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -144,6 +144,9 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do Reveal -> reveal Toggle -> toggle + TogglePersistent -> eventLoop + tv xc { config = cfg { persistent = not $ persistent cfg } } signal + where isPersistent = not $ persistent cfg -- cgit v1.2.3 From a7158c426ae008fb268f603f75d027683f726757 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:35:35 +0200 Subject: Add an initial (working) version of the DBus IPC module --- src/IPC/DBus.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 src/IPC/DBus.hs (limited to 'src') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs new file mode 100644 index 0000000..64e3cca --- /dev/null +++ b/src/IPC/DBus.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DBus +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil +-- Stability : unstable +-- Portability : unportable +-- +-- DBus IPC module for Xmobar +-- +----------------------------------------------------------------------------- + +module IPC.DBus ( runIPC ) where + +import DBus +import DBus.Client +import Control.Monad ((>=>), join, when) +import Control.Concurrent + +import Signal + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + +busName :: BusName +busName = busName_ "org.Xmobar.Control" + +objectPath :: ObjectPath +objectPath = objectPath_ "/org/Xmobar/Control" + +interfaceName :: InterfaceName +interfaceName = interfaceName_ "org.Xmobar.Control" + +runIPC :: MVar SignalType -> IO () +runIPC mvst = do + client <- connectSession + requestName client busName [ nameDoNotQueue ] + export client objectPath [ sendSignalMethod mvst ] + +sendSignalMethod :: MVar SignalType -> Method +sendSignalMethod mvst = method interfaceName sendSignalName + (signature_ [variantType $ toVariant $ (undefined :: SignalType)]) + (signature_ []) + sendSignalMethodCall + where + sendSignalName :: MemberName + sendSignalName = memberName_ "SendSignal" + + sendSignalMethodCall :: MethodCall -> IO Reply + sendSignalMethodCall mc = do + when ( methodCallMember mc == sendSignalName ) $ sendSignal $ + join $ safeHead $ map fromVariant $ methodCallBody mc + return ( replyReturn [] ) + + sendSignal :: Maybe SignalType -> IO () + sendSignal = maybe (return ()) (putMVar mvst) -- cgit v1.2.3 From 1f603c25eea15d302a4aa1ebb879bbd8198a3b82 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:37:22 +0200 Subject: Move safeHead to Plugins.Utils safeHead is a very general utility function with suits better into a common Util module. --- src/IPC/DBus.hs | 5 +---- src/Plugins/Utils.hs | 6 +++++- 2 files changed, 6 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 64e3cca..4357c48 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -20,10 +20,7 @@ import Control.Monad ((>=>), join, when) import Control.Concurrent import Signal - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x +import Plugins.Utils (safeHead) instance IsVariant SignalType where toVariant = toVariant . show diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs index 1dbcd40..bbfa84f 100644 --- a/src/Plugins/Utils.hs +++ b/src/Plugins/Utils.hs @@ -15,7 +15,7 @@ ------------------------------------------------------------------------------ -module Plugins.Utils (expandHome, changeLoop) where +module Plugins.Utils (expandHome, changeLoop, safeHead) where import Control.Monad import Control.Concurrent.STM @@ -37,3 +37,7 @@ changeLoop s f = atomically s >>= go new <- s guard (new /= old) return new) + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x -- cgit v1.2.3 From b318c3c18d3c2d4866c3f325f8ec6f00a42876fb Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:38:52 +0200 Subject: Move the IsVariant SignalType instance to Signal module This belongs here, otherwise ghc will complain about orphaned instances --- src/IPC/DBus.hs | 9 +-------- src/Signal.hs | 18 +++++++++++++++++- 2 files changed, 18 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index 4357c48..b0597a4 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -16,19 +16,12 @@ module IPC.DBus ( runIPC ) where import DBus import DBus.Client -import Control.Monad ((>=>), join, when) +import Control.Monad (join, when) import Control.Concurrent import Signal import Plugins.Utils (safeHead) -instance IsVariant SignalType where - toVariant = toVariant . show - fromVariant = fromVariant >=> parseSignalType - -parseSignalType :: String -> Maybe SignalType -parseSignalType = fmap fst . safeHead . reads - busName :: BusName busName = busName_ "org.Xmobar.Control" diff --git a/src/Signal.hs b/src/Signal.hs index ad19fdd..f634c16 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, CPP #-} module Signal where @@ -7,6 +7,13 @@ import Control.Concurrent import Control.Exception hiding (handle) import System.Posix.Signals +#ifdef DBUS +import DBus (IsVariant(..)) +import Control.Monad ((>=>)) + +import Plugins.Utils (safeHead) +#endif + data WakeUp = WakeUp deriving (Show,Typeable) instance Exception WakeUp @@ -19,6 +26,15 @@ data SignalType = Wakeup | TogglePersistent deriving (Read, Show) +#ifdef DBUS +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType +#endif + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + -- | Signal handling setupSignalHandler :: IO (MVar SignalType) setupSignalHandler = do -- cgit v1.2.3 From 2af5fab3c8df61ec189bcc880524fe73a6e1e361 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Fri, 10 Aug 2012 11:40:01 +0200 Subject: Run the DBus event handler in startCommand Actually run this stuff --- src/Xmobar.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Xmobar.hs b/src/Xmobar.hs index adbe956..fb0860d 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -50,6 +50,10 @@ import Signal import Window import XUtil +#ifdef DBUS +import IPC.DBus +#endif + -- $main -- -- The Xmobar data type and basic loops and functions. @@ -191,6 +195,9 @@ startCommand sig (com,s,ss) let cb str = atomically $ writeTVar var (s ++ str ++ ss) h <- forkIO $ start com cb _ <- forkIO $ trigger com ( maybe (return ()) (putMVar sig) ) +#ifdef DBUS + runIPC sig +#endif return (Just h,var) where is = s ++ "Updating..." ++ ss -- cgit v1.2.3 From 901bd4c9067b05616392de238d525dd8d4a99f45 Mon Sep 17 00:00:00 2001 From: Jochen Keil Date: Sat, 11 Aug 2012 21:22:45 +0200 Subject: Fix the MPRIS plugin to work with DBus >= 0.10 This commit updates the mpris plugin to use the DBus 0.10 interface. DBus-Core does no longer exist and is deprecated. DBus 0.10 does not use proxies anymore. The dependency on Data.Text also disappeared. Since I do not have/use mpris I cannot test if this works. It should however, since the functionality was just transformed to use the new interface. --- src/Plugins/Monitors/Mpris.hs | 61 ++++++++++++++++++++++++------------------- xmobar.cabal | 2 +- 2 files changed, 35 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/Plugins/Monitors/Mpris.hs b/src/Plugins/Monitors/Mpris.hs index 0fa181c..b899a16 100644 --- a/src/Plugins/Monitors/Mpris.hs +++ b/src/Plugins/Monitors/Mpris.hs @@ -21,43 +21,50 @@ module Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where import Plugins.Monitors.Common import Text.Printf (printf) -import qualified DBus.Client.Simple as C -import DBus.Types -import DBus.Connection ( ConnectionError ) + +import DBus +import qualified DBus.Client as DC + import Data.Maybe ( fromJust ) import Data.Int ( Int32, Int64 ) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Text as T import Control.Exception (try) class MprisVersion a where - getProxy :: a -> C.Client -> String -> IO C.Proxy - getMetadataReply :: a -> C.Client -> String -> IO [Variant] + getMethodCall :: a -> String -> MethodCall + getMetadataReply :: a -> DC.Client -> String -> IO [Variant] + getMetadataReply mv c p = fmap methodReturnBody (DC.call_ c $ getMethodCall mv p) fieldsList :: a -> [String] data MprisVersion1 = MprisVersion1 instance MprisVersion MprisVersion1 where - getProxy MprisVersion1 c p = do - let playerBusName = T.concat ["org.mpris.", T.pack p] - C.proxy c (C.busName_ playerBusName) "/Player" - getMetadataReply MprisVersion1 c p = do - player <- getProxy MprisVersion1 c p - C.call player "org.freedesktop.MediaPlayer" "GetMetadata" [] - fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title", "tracknumber" ] + getMethodCall MprisVersion1 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + } + where + busName = busName_ $ "org.mpris." ++ p + objectPath = objectPath_ $ "/Player" + interfaceName = interfaceName_ $ "org.freedesktop.MediaPlayer" + memberName = memberName_ $ "GetMetadata" + + fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title" + , "tracknumber" ] data MprisVersion2 = MprisVersion2 instance MprisVersion MprisVersion2 where - getProxy MprisVersion2 c p = do - let playerBusName = T.concat ["org.mpris.MediaPlayer2.", T.pack p] - C.proxy c (C.busName_ playerBusName) "/org/mpris/MediaPlayer2" - getMetadataReply MprisVersion2 c p = do - player <- getProxy MprisVersion2 c p - C.call player "org.freedesktop.DBus.Properties" - "Get" - (map (toVariant::String -> Variant) - ["org.mpris.MediaPlayer2.Player", "Metadata"] - ) + getMethodCall MprisVersion2 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + , methodCallBody = arguments + } + where + busName = busName_ $ "org.mpris.MediaPlayer2." ++ p + objectPath = objectPath_ $ "/org/mpris/MediaPlayer2" + interfaceName = interfaceName_ $ "org.freedesktop.DBus.Properties" + memberName = memberName_ $ "Get" + arguments = map (toVariant::String -> Variant) + ["org.mpris.MediaPlayer2.Player", "Metadata"] + fieldsList MprisVersion2 = [ "xesam:album", "xesam:artist", "mpris:artUrl" , "mpris:length", "xesam:title", "xesam:trackNumber" ] @@ -67,8 +74,8 @@ mprisConfig = mkMConfig " - " [ "album", "artist", "arturl", "length" , "title", "tracknumber" ] -dbusClient :: C.Client -dbusClient = unsafePerformIO C.connectSession +dbusClient :: DC.Client +dbusClient = unsafePerformIO DC.connectSession runMPRIS :: (MprisVersion a) => a -> String -> [String] -> Monitor String runMPRIS version playerName _ = do @@ -95,10 +102,10 @@ unpackMetadata xs = ((map (\(k, v) -> (fromVar k, fromVar v))) . unpack . head) TypeStructure _ -> unpack $ head $ structureItems $ fromVar v _ -> [] -getMetadata :: (MprisVersion a) => a -> C.Client -> String -> IO [(String, Variant)] +getMetadata :: (MprisVersion a) => a -> DC.Client -> String -> IO [(String, Variant)] getMetadata version client player = do reply <- try (getMetadataReply version client player) :: - IO (Either ConnectionError [Variant]) + IO (Either DC.ClientError [Variant]) return $ case reply of Right metadata -> unpackMetadata metadata; Left _ -> [] diff --git a/xmobar.cabal b/xmobar.cabal index 8e5b604..54f932e 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -166,7 +166,7 @@ executable xmobar cpp-options: -DDATEZONE if flag(with_mpris) || flag(all_extensions) - build-depends: dbus-core >= 0.9.2.1, text >= 0.11.1.5 && < 0.12 + build-depends: dbus >= 0.10 other-modules: Plugins.Monitors.Mpris cpp-options: -DMPRIS -- cgit v1.2.3 From 8a53271cd677bea3223f7d25eb1f697aa3d96540 Mon Sep 17 00:00:00 2001 From: Jochen Keil <jochen.keil@gmail.com> Date: Sun, 12 Aug 2012 10:33:41 +0200 Subject: Catch error when DBus connection fails connectSession throws a ClientError Exception when DBUS_SESSION_BUS_ADDRESS is unset. Without exception handler this will result in program termination. Since the DBus handler merely sends a signal to the event loop it does no harm when it won't run. Normal operation will continue just if compiled without dbus support. --- src/IPC/DBus.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs index b0597a4..469a7c6 100644 --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -14,10 +14,14 @@ module IPC.DBus ( runIPC ) where +import Prelude hiding (catch) + import DBus import DBus.Client import Control.Monad (join, when) import Control.Concurrent +import Control.Exception (catch) +import System.IO (stderr, hPutStrLn) import Signal import Plugins.Utils (safeHead) @@ -32,10 +36,14 @@ interfaceName :: InterfaceName interfaceName = interfaceName_ "org.Xmobar.Control" runIPC :: MVar SignalType -> IO () -runIPC mvst = do - client <- connectSession - requestName client busName [ nameDoNotQueue ] - export client objectPath [ sendSignalMethod mvst ] +runIPC mvst = catch exportConnection printException + where + printException :: ClientError -> IO () + printException = hPutStrLn stderr . clientErrorMessage + exportConnection = do + client <- connectSession + requestName client busName [ nameDoNotQueue ] + export client objectPath [ sendSignalMethod mvst ] sendSignalMethod :: MVar SignalType -> Method sendSignalMethod mvst = method interfaceName sendSignalName -- cgit v1.2.3 From 2570b0d756121fb6314de514412b52f648d0fc25 Mon Sep 17 00:00:00 2001 From: Jochen Keil <jochen.keil@gmail.com> Date: Sun, 12 Aug 2012 10:39:08 +0200 Subject: Run the DBus/IPC handler only once on program start The startCommand function is called for every configured plugin. This results in multiple calls to runIPC. This it not necessary however. startLoop is a much more appropriate place, since the other signal handler (checker and eventer) are run here to. --- src/Xmobar.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Xmobar.hs b/src/Xmobar.hs index fb0860d..d758301 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -87,6 +87,9 @@ startLoop xcfg@(XConf _ _ w _ conf) sig vs = do _ <- forkIO (eventer sig `catch` #endif \(SomeException _) -> void (putStrLn "Thread eventer failed")) +#ifdef DBUS + runIPC sig +#endif eventLoop tv xcfg sig where -- Reacts on events from X @@ -195,9 +198,6 @@ startCommand sig (com,s,ss) let cb str = atomically $ writeTVar var (s ++ str ++ ss) h <- forkIO $ start com cb _ <- forkIO $ trigger com ( maybe (return ()) (putMVar sig) ) -#ifdef DBUS - runIPC sig -#endif return (Just h,var) where is = s ++ "Updating..." ++ ss -- cgit v1.2.3 From b8cf77207eb7dfa99f842f5b7e63fee95efe3796 Mon Sep 17 00:00:00 2001 From: Jochen Keil <jochen.keil@gmail.com> Date: Mon, 13 Aug 2012 07:28:55 +0200 Subject: Revert lowerOnStart to its original behaviour I misunderstood the intention of lowerOnStart and changed the implementation to what I thought it would have to do. This was wrong indeed, so back to original behaviour. --- readme.md | 3 --- src/Window.hs | 1 + src/Xmobar.hs | 1 - 3 files changed, 1 insertion(+), 4 deletions(-) (limited to 'src') diff --git a/readme.md b/readme.md index 1c13d27..7d06087 100644 --- a/readme.md +++ b/readme.md @@ -221,9 +221,6 @@ Other configuration options: : position = Top -`lowerOnStart` -: When True the window is initially hidden (can be toggled) - `persistent` : When True the window status is fixed i.e. hiding or revealing is not possible. This option can be toggled at runtime. diff --git a/src/Window.hs b/src/Window.hs index 9024fff..50bfc56 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -24,6 +24,7 @@ createWin d fs c = do (r,o) = setPosition (position c) srs (fi ht) win <- newWindow d (defaultScreenOfDisplay d) rootw r o setProperties r c d win srs + when (lowerOnStart c) (lowerWindow d win) mapWindow d win return (r,win) diff --git a/src/Xmobar.hs b/src/Xmobar.hs index d758301..5328b6e 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -78,7 +78,6 @@ runX xc f = runReaderT f xc startLoop :: XConf -> MVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () startLoop xcfg@(XConf _ _ w _ conf) sig vs = do tv <- atomically $ newTVar [] - when (lowerOnStart conf) $ putMVar sig Hide _ <- forkIO (checker tv [] vs sig `catch` \(SomeException _) -> void (putStrLn "Thread checker failed")) #ifdef THREADED_RUNTIME -- cgit v1.2.3 From b3bdd804bda130d1ec0a66192e633ee0e0a476ca Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz <jao@gnu.org> Date: Mon, 13 Aug 2012 14:57:31 +0200 Subject: Missing import for 'when' --- src/Window.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/Window.hs b/src/Window.hs index 50bfc56..a069f1f 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -1,6 +1,7 @@ module Window where import Prelude hiding (catch) +import Control.Monad (when) import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama -- cgit v1.2.3 From bf525097ee78c008f2c96653b3c4eb03f4923246 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz <jao@gnu.org> Date: Mon, 13 Aug 2012 15:09:42 +0200 Subject: Missing file headers and linting --- src/Signal.hs | 16 ++++++++++++++++ src/Window.hs | 15 +++++++++++++++ src/Xmobar.hs | 2 +- 3 files changed, 32 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Signal.hs b/src/Signal.hs index f634c16..3c341f9 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -1,5 +1,21 @@ {-# LANGUAGE DeriveDataTypeable, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Signal +-- Copyright : (c) Andrea Rosatto +-- : (c) Jose A. Ortega Ruiz +-- : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Signal handling, including DBUS when available +-- +----------------------------------------------------------------------------- + module Signal where import Data.Typeable (Typeable) diff --git a/src/Window.hs b/src/Window.hs index a069f1f..0ffa139 100644 --- a/src/Window.hs +++ b/src/Window.hs @@ -1,3 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Window +-- Copyright : (c) 2011-12 Jose A. Ortega Ruiz +-- : (c) 2012 Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Window manipulation functions +-- +----------------------------------------------------------------------------- + module Window where import Prelude hiding (catch) diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 5328b6e..2dbba11 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -76,7 +76,7 @@ runX xc f = runReaderT f xc -- | Starts the main event loop and threads startLoop :: XConf -> MVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () -startLoop xcfg@(XConf _ _ w _ conf) sig vs = do +startLoop xcfg@(XConf _ _ w _ _) sig vs = do tv <- atomically $ newTVar [] _ <- forkIO (checker tv [] vs sig `catch` \(SomeException _) -> void (putStrLn "Thread checker failed")) -- cgit v1.2.3