diff options
| -rw-r--r-- | src/Actions.hs | 17 | ||||
| -rw-r--r-- | src/Bitmap.hs | 2 | ||||
| -rw-r--r-- | src/Parsers.hs | 56 | ||||
| -rw-r--r-- | src/Signal.hs | 3 | ||||
| -rw-r--r-- | src/Xmobar.hs | 24 |
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 |