diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Actions.hs | 23 | ||||
| -rw-r--r-- | src/Bitmap.hs | 9 | ||||
| -rw-r--r-- | src/Parsers.hs | 48 | ||||
| -rw-r--r-- | src/Signal.hs | 2 | ||||
| -rw-r--r-- | src/Xmobar.hs | 68 |
5 files changed, 109 insertions, 41 deletions
diff --git a/src/Actions.hs b/src/Actions.hs new file mode 100644 index 0000000..156dc4e --- /dev/null +++ b/src/Actions.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Actions +-- Copyright : (c) Alexander Polakov +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Actions where + +import System.Process (system) +import Control.Monad (void) + +data Action = Spawn String + deriving (Eq) + +runAction :: Action -> IO () +runAction (Spawn s) = void $ system (s ++ "&") +runAction _ = return () diff --git a/src/Bitmap.hs b/src/Bitmap.hs index b073c9b..2045e1a 100644 --- a/src/Bitmap.hs +++ b/src/Bitmap.hs @@ -22,17 +22,18 @@ import System.Directory (doesFileExist) import System.Mem.Weak ( addFinalizer ) import ColorCache import Parsers (Widget(..)) +import Actions (Action) data Bitmap = Bitmap { width :: Dimension , height :: Dimension , pixmap :: Pixmap } -updateCache :: Display -> Window -> Map FilePath Bitmap -> [[(Widget, String)]] - -> IO (Map FilePath Bitmap) +updateCache :: Display -> Window -> Map FilePath Bitmap -> + [[(Widget, String, Maybe Action)]] -> IO (Map FilePath Bitmap) updateCache dpy win cache ps = do - let paths = map (\(Icon p, _) -> p) . concatMap (filter icons) $ ps - icons (Icon _, _) = True + let paths = map (\(Icon p, _, _) -> p) . concatMap (filter icons) $ ps + icons (Icon _, _, _) = True icons _ = False go m path = if member path m then return m diff --git a/src/Parsers.hs b/src/Parsers.hs index 62345fe..f3b0a2e 100644 --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -23,6 +23,7 @@ module Parsers import Config import Runnable import Commands +import Actions import qualified Data.Map as Map import Text.ParserCombinators.Parsec @@ -33,24 +34,26 @@ data Widget = Icon String | Text String type ColorString = String -- | Runs the string parser -parseString :: Config -> String -> IO [(Widget, ColorString)] +parseString :: Config -> String -> IO [(Widget, ColorString, Maybe Action)] parseString c s = - case parse (stringParser (fgColor c)) "" s of - Left _ -> return [(Text $ "Could not parse string: " ++ s, fgColor c)] + case parse (stringParser (fgColor c) Nothing) "" s of + Left _ -> return [(Text $ "Could not parse string: " ++ s, fgColor c, Nothing)] Right x -> return (concat x) -- | Gets the string and combines the needed parsers -stringParser :: String -> Parser [[(Widget, ColorString)]] -stringParser c = manyTill (textParser c <|> try (iconParser c) <|> colorParser) eof +stringParser :: String -> Maybe Action -> Parser [[(Widget, ColorString, Maybe Action)]] +stringParser c a = manyTill (textParser c a <|> try (iconParser c a) <|> try (actionParser c) <|> colorParser a) eof -- | Parses a maximal string without color markup. -textParser :: String -> Parser [(Widget, ColorString)] -textParser c = do s <- many1 $ - noneOf "<" <|> - (try $ notFollowedBy' (char '<') - (string "fc=" <|> - string "icon=" <|> string "/fc>")) - return [(Text s, c)] +textParser :: String -> Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +textParser c a = do s <- many1 $ + noneOf "<" <|> + (try $ notFollowedBy' (char '<') + (try (string "fc=") <|> + try (string "action=") <|> + try (string "/action>") <|> + try (string "icon=") <|> string "/fc>")) + return [(Text s, c, a)] -- | Wrapper for notFollowedBy that returns the result of the first parser. @@ -61,17 +64,24 @@ notFollowedBy' p e = do x <- p notFollowedBy $ try (e >> return '*') return x -iconParser :: String -> Parser [(Widget, ColorString)] -iconParser c = do +iconParser :: String -> Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +iconParser c a = do string "<icon=" i <- manyTill (noneOf ">") (try (string "/>")) - return [(Icon i, c)] - + return [(Icon i, c, a)] + +actionParser :: String -> Parser [(Widget, ColorString, Maybe Action)] +actionParser c = do + a <- between (string "<action=") (string ">") (many1 (noneOf ">")) + let a' = Just (Spawn a) + s <- manyTill (try (textParser c a') <|> try (iconParser c a') <|> try (colorParser a') <|> actionParser c) (try $ string "</action>") + return (concat s) + -- | Parsers a string wrapped in a color specification. -colorParser :: Parser [(Widget, ColorString)] -colorParser = do +colorParser :: Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +colorParser a = do c <- between (string "<fc=") (string ">") colors - s <- manyTill (try (textParser c <|> iconParser c) <|> colorParser) (try $ string "</fc>") + s <- manyTill (try (textParser c a) <|> try (iconParser c a) <|> try (colorParser a) <|> actionParser c) (try $ string "</fc>") return (concat s) -- | Parses a color specification (hex or named) diff --git a/src/Signal.hs b/src/Signal.hs index 8b3b325..34d8cd7 100644 --- a/src/Signal.hs +++ b/src/Signal.hs @@ -22,6 +22,7 @@ import Data.Typeable (Typeable) import Control.Concurrent.STM import Control.Exception hiding (handle) import System.Posix.Signals +import Graphics.X11.Xlib.Types (Position) #ifdef DBUS import DBus (IsVariant(..)) @@ -40,6 +41,7 @@ data SignalType = Wakeup | Reveal Int | Toggle Int | TogglePersistent + | Action Position deriving (Read, Show) #ifdef DBUS diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 67badaa..25d8fab 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -42,11 +42,13 @@ import Control.Concurrent.STM import Control.Exception (handle, SomeException(..)) import Data.Bits import Data.Map hiding (foldr, map, filter) +import Data.Maybe (fromJust) import Bitmap import Config import Parsers import Commands +import Actions import Runnable import Signal import Window @@ -98,7 +100,7 @@ startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do #ifdef DBUS runIPC sig #endif - eventLoop tv xcfg sig + eventLoop tv xcfg [] sig where handler thing (SomeException _) = void $ putStrLn ("Thread " ++ thing ++ " failed") @@ -107,7 +109,7 @@ startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do allocaXEvent $ \e -> do dpy <- openDisplay "" xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask) + selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) forever $ do #ifdef THREADED_RUNTIME @@ -120,6 +122,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)) _ -> return () -- | Send signal to eventLoop every time a var is updated @@ -141,15 +144,16 @@ checker tvar ov vs signal = do -- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO () -eventLoop tv xc@(XConf d r w fs is cfg) signal = do +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 } + as' <- updateActions xc r str runX xc' $ drawInWin r str - eventLoop tv xc' signal + eventLoop tv xc' as' signal Reposition -> reposWindow cfg @@ -163,36 +167,38 @@ eventLoop tv xc@(XConf d r w fs is cfg) signal = do Toggle t -> toggle t TogglePersistent -> eventLoop - tv xc { config = cfg { persistent = not $ persistent cfg } } signal + tv xc { config = cfg { persistent = not $ persistent cfg } } as signal + + Action x -> action x where isPersistent = not $ persistent cfg hide t | t == 0 = - when isPersistent (hideWindow d w) >> eventLoop tv xc signal + when isPersistent (hideWindow d w) >> eventLoop tv xc as signal | otherwise = do void $ forkIO $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc signal + eventLoop tv xc as signal reveal t | t == 0 = do when isPersistent (showWindow r cfg d w) - eventLoop tv xc signal + eventLoop tv xc as signal | otherwise = do void $ forkIO $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc signal + eventLoop tv xc as signal toggle t = do ismapped <- isMapped d w atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - eventLoop tv xc signal + eventLoop tv xc as signal reposWindow rcfg = do r' <- repositionWin d w fs rcfg - eventLoop tv (XConf d r' w fs is rcfg) signal + eventLoop tv (XConf d r' w fs is rcfg) as signal updateConfigPosition ocfg = case position ocfg of @@ -205,6 +211,9 @@ eventLoop tv xc@(XConf d r w fs is cfg) signal = do 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 + -- $command -- | Runs a command as an independent thread and returns its thread id @@ -224,24 +233,47 @@ startCommand sig (com,s,ss) return (Just h,var) where is = s ++ "Updating..." ++ ss -updateString :: Config -> TVar [String] -> IO [[(Widget, String)]] +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 conf (Rectangle _ _ wid _) ~[left,center,right] = do + let (d,fs) = (display &&& fontS) conf + 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) $ + scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) (Nothing, 0, off) xs + + totSLen = (\(_,_,len) -> fi len) . last + remWidth xs = fi wid - totSLen xs + offs = 1 + offset a xs = case a of + C -> (remWidth xs + offs) `div` 2 + R -> remWidth xs + L -> offs + + fmap concat $ mapM (\(a,xs) -> strLn xs >>= \xs' -> return $ partCoord (offset a xs') xs') $ + zip [L,C,R] [left,center,right] + -- $print -- | Draws in and updates the window -drawInWin :: Rectangle -> [[(Widget, String)]] -> X () +drawInWin :: Rectangle -> [[(Widget, String, Maybe Action)]] -> X () drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask let (c,d ) = (config &&& display) r (w,fs) = (window &&& fontS ) r strLn = io . mapM getWidth iconW i = maybe 0 Bitmap.width (lookup i $ iconS r) - getWidth (Text s,cl) = textWidth d fs s >>= \tw -> return (Text s,cl,fi tw) - getWidth (Icon s,cl) = return (Icon s,cl,fi $ iconW s) + getWidth (Text s,cl,_) = textWidth d fs s >>= \tw -> return (Text s,cl,fi tw) + getWidth (Icon s,cl,_) = return (Icon s,cl,fi $ iconW s) withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do gc <- io $ createGC d w @@ -272,8 +304,8 @@ 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) + Text t -> io $ textExtents fontst t + Icon _ -> return (0, 0) let (conf,d) = (config &&& display) r Rectangle _ _ wid ht = rect r totSLen = foldr (\(_,_,len) -> (+) len) 0 sl |