summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar.hs')
-rw-r--r--src/Xmobar.hs87
1 files changed, 53 insertions, 34 deletions
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 823b594..3016f75 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, CPP #-}
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Xmobar
@@ -36,13 +36,14 @@ import Graphics.X11.Xinerama
import Graphics.X11.Xrandr
import Control.Arrow ((&&&))
+import Control.Applicative ((<$>))
import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (handle, SomeException(..))
import Data.Bits
import Data.Map hiding (foldr, map, filter)
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isJust)
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
@@ -125,7 +126,7 @@ startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do
ConfigureEvent {} -> atomically $ putTMVar signal Reposition
ExposeEvent {} -> atomically $ putTMVar signal Wakeup
RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition
- ButtonEvent {} -> atomically $ putTMVar signal (Action (fi $ ev_x ev))
+ ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
_ -> return ()
-- | Send signal to eventLoop every time a var is updated
@@ -147,13 +148,13 @@ checker tvar ov vs signal = do
-- | Continuously wait for a signal from a thread or a interrupt handler
-eventLoop :: TVar [String] -> XConf -> [(Action, Position, Position)] -> TMVar SignalType -> IO ()
+eventLoop :: TVar [String] -> XConf -> [([Action], Position, Position)] -> TMVar SignalType -> IO ()
eventLoop tv xc@(XConf d r w fs is cfg) as signal = do
typ <- atomically $ takeTMVar signal
case typ of
Wakeup -> do
str <- updateString cfg tv
- xc' <- updateCache d w is str >>= \c -> return xc { iconS = c }
+ xc' <- updateCache d w is (iconRoot cfg) str >>= \c -> return xc { iconS = c }
as' <- updateActions xc r str
runX xc' $ drawInWin r str
eventLoop tv xc' as' signal
@@ -172,7 +173,7 @@ eventLoop tv xc@(XConf d r w fs is cfg) as signal = do
TogglePersistent -> eventLoop
tv xc { config = cfg { persistent = not $ persistent cfg } } as signal
- Action x -> action x
+ Action but x -> action but x
where
isPersistent = not $ persistent cfg
@@ -207,15 +208,20 @@ eventLoop tv xc@(XConf d r w fs is cfg) as signal = do
case position ocfg of
OnScreen n o -> do
srs <- getScreenInfo d
- if n == length srs then
- return (ocfg {position = OnScreen 1 o})
- else
- return (ocfg {position = OnScreen (n+1) o})
+ return (if n == length srs
+ then
+ (ocfg {position = OnScreen 1 o})
+ else
+ (ocfg {position = OnScreen (n+1) o}))
o ->
return (ocfg {position = OnScreen 1 o})
- action x = do mapM_ (\(a,_,_) -> runAction a) $ filter (\(_, from, to) -> x >= from && x <= to) as
- eventLoop tv xc as signal
+ action button x = do
+ mapM_ runAction $
+ filter (\(Spawn b _) -> button `elem` b) $
+ concatMap (\(a,_,_) -> a) $
+ filter (\(_, from, to) -> x >= from && x <= to) as
+ eventLoop tv xc as signal
-- $command
@@ -236,23 +242,24 @@ startCommand sig (com,s,ss)
return (Just h,var)
where is = s ++ "Updating..." ++ ss
-updateString :: Config -> TVar [String] -> IO [[(Widget, String, Maybe Action)]]
+updateString :: Config -> TVar [String] ->
+ IO [[(Widget, String, Maybe [Action])]]
updateString conf v = do
s <- atomically $ readTVar v
let l:c:r:_ = s ++ repeat ""
io $ mapM (parseString conf) [l, c, r]
-updateActions :: XConf -> Rectangle -> [[(Widget, String, Maybe Action)]] ->
- IO [(Action, Position, Position)]
+updateActions :: XConf -> Rectangle -> [[(Widget, String, Maybe [Action])]] ->
+ IO [([Action], Position, Position)]
updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
let (d,fs) = (display &&& fontS) conf
- strLn :: [(Widget, String, Maybe Action)] -> IO [(Maybe Action, Position, Position)]
+ strLn :: [(Widget, String, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
strLn = io . mapM getCoords
iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf)
getCoords (Text s,_,a) = textWidth d fs s >>= \tw -> return (a, 0, fi tw)
getCoords (Icon s,_,a) = return (a, 0, fi $ iconW s)
partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $
- filter (\(a, _,_) -> a /= Nothing) $
+ filter (\(a, _,_) -> isJust a) $
scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) (Nothing, 0, off) xs
totSLen = foldr (\(_,_,len) -> (+) len) 0
@@ -263,13 +270,13 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
R -> remWidth xs
L -> offs
- fmap concat $ mapM (\(a,xs) -> fmap (\xs' -> partCoord (offset a xs') xs') $ strLn xs) $
+ fmap concat $ mapM (\(a,xs) -> (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $
zip [L,C,R] [left,center,right]
-- $print
-- | Draws in and updates the window
-drawInWin :: Rectangle -> [[(Widget, String, Maybe Action)]] -> X ()
+drawInWin :: Rectangle -> [[(Widget, String, Maybe [Action])]] -> X ()
drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
r <- ask
let (c,d ) = (config &&& display) r
@@ -315,7 +322,7 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
printStrings p gc fs 1 R =<< strLn right
printStrings p gc fs 1 C =<< strLn center
-- draw 1 pixel border if requested
- io $ drawBorder (border c) d p gc bdcolor wid ht
+ io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht
-- copy the pixmap with the new string to the window
io $ copyArea d p w gc 0 0 wid ht 0 0
-- free up everything (we do not want to leak memory!)
@@ -324,27 +331,39 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
-- resync
io $ sync d True
+verticalOffset :: (Integral b, Integral a, MonadIO m) =>
+ a -> Widget -> XFont -> Config -> m b
+verticalOffset ht (Text t) fontst conf
+ | textOffset conf > -1 = return $ fi (textOffset conf)
+ | otherwise = do
+ (as,ds) <- io $ textExtents fontst t
+ let bwidth = borderOffset (border conf) (borderWidth conf)
+ verticalMargin = (fi ht) - fi (as + ds) - 2 * fi (abs bwidth)
+ return $ (fi ht) - (fi ds) - (verticalMargin `div` 2) + bwidth + 1
+verticalOffset _ (Icon _) _ conf
+ | iconOffset conf > -1 = return $ fi (iconOffset conf)
+ | otherwise = do
+ let bwidth = borderOffset (border conf) (borderWidth conf)
+ return $ bwidth + 1
+
-- | An easy way to print the stuff we need to print
printStrings :: Drawable -> GC -> XFont -> Position
-> Align -> [(Widget, String, Position)] -> X ()
printStrings _ _ _ _ _ [] = return ()
printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
r <- ask
- (as,ds) <- case s of
- Text t -> io $ textExtents fontst t
- Icon _ -> return (0, 0)
- let (conf,d) = (config &&& display) r
+ let (conf,d) = (config &&& display) r
Rectangle _ _ wid ht = rect r
- totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
- valign = -1 + (fi ht + fi (as + ds)) `div` 2
- remWidth = fi wid - fi totSLen
- offset = case a of
- C -> (remWidth + offs) `div` 2
- R -> remWidth
- L -> offs
- (fc,bc) = case break (==',') c of
- (f,',':b) -> (f, b )
- (f, _) -> (f, bgColor conf)
+ totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
+ remWidth = fi wid - fi totSLen
+ offset = case a of
+ C -> (remWidth + offs) `div` 2
+ R -> remWidth
+ L -> offs
+ (fc,bc) = case break (==',') c of
+ (f,',':b) -> (f, b )
+ (f, _) -> (f, bgColor conf)
+ valign <- verticalOffset ht s fontst conf
case s of
(Text t) -> io $ printString d dr fontst gc fc bc offset valign t
(Icon p) -> io $ maybe (return ()) (drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r))
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-12 08:06:44 +0000