summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--src/Actions.hs17
-rw-r--r--src/Bitmap.hs2
-rw-r--r--src/Parsers.hs56
-rw-r--r--src/Signal.hs3
-rw-r--r--src/Xmobar.hs24
5 files changed, 67 insertions, 35 deletions
diff --git a/src/Actions.hs b/src/Actions.hs
index 42b9545..2befe77 100644
--- a/src/Actions.hs
+++ b/src/Actions.hs
@@ -14,14 +14,21 @@ module Actions (Action(..), runAction, stripActions) where
import System.Process (system)
import Control.Monad (void)
-import Text.Regex (subRegex, mkRegex)
+import Text.Regex (Regex, subRegex, mkRegex, matchRegex)
+import Graphics.X11.Types (Button)
-data Action = Spawn String
+data Action = Spawn Button String
deriving (Eq)
runAction :: Action -> IO ()
-runAction (Spawn s) = void $ system (s ++ "&")
+runAction (Spawn _ s) = void $ system (s ++ "&")
stripActions :: String -> String
-stripActions s = subRegex actionRegex s "[action=\1]\2[action]"
- where actionRegex = mkRegex "<action=([^>])*>(.+)</action>"
+stripActions s = case matchRegex actionRegex s of
+ Nothing -> s
+ Just _ -> stripActions strippedOneLevel
+ where
+ strippedOneLevel = subRegex actionRegex s $ "[\\1=\\2]\\3[\\4]"
+
+actionRegex :: Regex
+actionRegex = mkRegex "<(action|button.)=([^>]*)>(.+)</(action|button.)>"
diff --git a/src/Bitmap.hs b/src/Bitmap.hs
index 2045e1a..3673b7a 100644
--- a/src/Bitmap.hs
+++ b/src/Bitmap.hs
@@ -30,7 +30,7 @@ data Bitmap = Bitmap { width :: Dimension
}
updateCache :: Display -> Window -> Map FilePath Bitmap ->
- [[(Widget, String, Maybe Action)]] -> IO (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
diff --git a/src/Parsers.hs b/src/Parsers.hs
index 919ce68..2b00f37 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -28,13 +28,14 @@ import Actions
import qualified Data.Map as Map
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Perm
+import Graphics.X11.Types (Button)
data Widget = Icon String | Text String
type ColorString = String
-- | Runs the string parser
-parseString :: Config -> String -> IO [(Widget, ColorString, Maybe Action)]
+parseString :: Config -> String -> IO [(Widget, ColorString, Maybe [Action])]
parseString c s =
case parse (stringParser (fgColor c) Nothing) "" s of
Left _ -> return [(Text $ "Could not parse string: " ++ s
@@ -43,23 +44,28 @@ parseString c s =
Right x -> return (concat x)
-- | Gets the string and combines the needed parsers
-stringParser :: String -> Maybe Action
- -> Parser [[(Widget, ColorString, Maybe Action)]]
+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
+ try (actionParser c a) <|> colorParser a) eof
-- | Parses a maximal string without color markup.
-textParser :: String -> Maybe Action
- -> Parser [(Widget, ColorString, Maybe Action)]
+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 (tryChoice openings) <|>
+ try (tryChoice closings) <|>
try (string "icon=") <|>
string "/fc>"))
return [(Text s, c, a)]
+ where
+ openings = map (++ "=") buttons
+ closings = map (\s -> '/' : s ++ ">") buttons
+
+ tryChoice strs = choice $ map (try . string) strs
-- | Wrapper for notFollowedBy that returns the result of the first parser.
@@ -70,28 +76,42 @@ notFollowedBy' p e = do x <- p
notFollowedBy $ try (e >> return '*')
return x
-iconParser :: String -> Maybe Action
- -> Parser [(Widget, ColorString, Maybe Action)]
+iconParser :: String -> Maybe [Action]
+ -> Parser [(Widget, ColorString, Maybe [Action])]
iconParser c a = do
string "<icon="
i <- manyTill (noneOf ">") (try (string "/>"))
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)
+actionParser :: String -> Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])]
+actionParser c act = do
+ string "<"
+ button <- choice $ map (try . string) buttons
+ command <- between (string "=") (string ">") (many1 (noneOf ">"))
+ let a = Spawn (toButton button) command
+ a' = case act of
+ Nothing -> Just [a]
+ Just act' -> Just $ a : act'
s <- manyTill (try (textParser c a') <|> try (iconParser c a') <|>
- try (colorParser a') <|> actionParser c)
- (try $ string "</action>")
+ try (colorParser a') <|> actionParser c a')
+ (try $ string $ "</" ++ button ++ ">")
return (concat s)
+-- List of accepted buttons plus action for backward compatibility
+buttons :: [String]
+buttons = "action" : zipWith (++) (repeat "button") (map show ([1..5] :: [Int]))
+
+toButton :: String -> Button
+toButton s = case s of
+ "action" -> 1
+ _ -> read $ [last s]
+
-- | Parsers a string wrapped in a color specification.
-colorParser :: Maybe Action -> Parser [(Widget, ColorString, Maybe Action)]
+colorParser :: Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])]
colorParser a = do
c <- between (string "<fc=") (string ">") colors
s <- manyTill (try (textParser c a) <|> try (iconParser c a) <|>
- try (colorParser a) <|> actionParser c) (try $ string "</fc>")
+ try (colorParser a) <|> actionParser c a) (try $ string "</fc>")
return (concat s)
-- | Parses a color specification (hex or named)
diff --git a/src/Signal.hs b/src/Signal.hs
index 34d8cd7..a828db6 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.Types (Button)
import Graphics.X11.Xlib.Types (Position)
#ifdef DBUS
@@ -41,7 +42,7 @@ data SignalType = Wakeup
| Reveal Int
| Toggle Int
| TogglePersistent
- | Action Position
+ | Action Button Position
deriving (Read, Show)
#ifdef DBUS
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 3cff475..653ca69 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -122,7 +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))
+ ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev))
_ -> return ()
-- | Send signal to eventLoop every time a var is updated
@@ -144,7 +144,7 @@ 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
@@ -169,7 +169,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
@@ -211,8 +211,12 @@ eventLoop tv xc@(XConf d r w fs is cfg) as 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
+ action button x = do
+ mapM_ runAction $
+ filter (\(Spawn b _) -> button == b) $
+ concatMap (\(a,_,_) -> a) $
+ filter (\(_, from, to) -> x >= from && x <= to) as
+ eventLoop tv xc as signal
-- $command
@@ -233,17 +237,17 @@ 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)
@@ -266,7 +270,7 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
-- $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