Add support for multiple actions per item, activated depending on mouse button clicked

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