summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2013-04-25 01:38:18 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2013-04-25 01:38:18 +0200
commitc5926232e494786eb618458d743685a3f01a3c62 (patch)
tree1889403e495b021f469fb5edf319711a97af09c1 /src
parentf1bdd8115f201be09f60d77699048b9dac3e5950 (diff)
downloadxmobar-c5926232e494786eb618458d743685a3f01a3c62.tar.gz
xmobar-c5926232e494786eb618458d743685a3f01a3c62.tar.bz2
New allDesktops configuration parameter
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs56
-rw-r--r--src/Parsers.hs71
-rw-r--r--src/Window.hs49
3 files changed, 97 insertions, 79 deletions
diff --git a/src/Config.hs b/src/Config.hs
index 6ab3f8d..3eda6c3 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -51,24 +51,29 @@ import Plugins.DateZone
-- | The configuration data type
data Config =
- Config { font :: String -- ^ Font
- , bgColor :: String -- ^ Backgroud color
- , fgColor :: String -- ^ Default font color
- , position :: XPosition -- ^ Top Bottom or Static
- , border :: Border -- ^ NoBorder TopB BottomB or FullB
- , borderColor :: String -- ^ Border color
- , hideOnStart :: Bool -- ^ Hide (Unmap) the window on
- -- initialization
- , lowerOnStart :: Bool -- ^ Lower to the bottom of the
- -- window stack on initialization
- , persistent :: Bool -- ^ Whether automatic hiding should
- -- be enabled or disabled
- , commands :: [Runnable] -- ^ For setting the command, the command arguments
- -- and refresh rate for the programs to run (optional)
- , sepChar :: String -- ^ The character to be used for indicating
- -- commands in the output template (default '%')
- , alignSep :: String -- ^ Separators for left, center and right text alignment
- , template :: String -- ^ The output template
+ Config { font :: String -- ^ Font
+ , bgColor :: String -- ^ Backgroud color
+ , fgColor :: String -- ^ Default font color
+ , position :: XPosition -- ^ Top Bottom or Static
+ , border :: Border -- ^ NoBorder TopB BottomB or FullB
+ , borderColor :: String -- ^ Border color
+ , hideOnStart :: Bool -- ^ Hide (Unmap) the window on
+ -- initialization
+ , allDesktops :: Bool -- ^ Tell the WM to map to all desktops
+ , lowerOnStart :: Bool -- ^ lower to the bottom of the
+ -- window stack on initialization
+ , persistent :: Bool -- ^ Whether automatic hiding should
+ -- be enabled or disabled
+ , commands :: [Runnable] -- ^ For setting the command,
+ -- the command arguments
+ -- and refresh rate for the programs
+ -- to run (optional)
+ , sepChar :: String -- ^ The character to be used for indicating
+ -- commands in the output template
+ -- (default '%')
+ , alignSep :: String -- ^ Separators for left, center and
+ -- right text alignment
+ , template :: String -- ^ The output template
} deriving (Read)
data XPosition = Top
@@ -97,18 +102,19 @@ data Border = NoBorder
-- | The default configuration values
defaultConfig :: Config
defaultConfig =
- Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
- , bgColor = "#000000"
- , fgColor = "#BFBFBF"
+ Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+ , bgColor = "#000000"
+ , fgColor = "#BFBFBF"
, position = Top
, border = NoBorder
- , borderColor = "#BFBFBF"
- , hideOnStart = False
+ , borderColor = "#BFBFBF"
+ , hideOnStart = False
, lowerOnStart = True
- , persistent = False
+ , persistent = False
+ , allDesktops = False
, commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10
, Run StdinReader]
- , sepChar = "%"
+ , sepChar = "%"
, alignSep = "}{"
, template = "%StdinReader% }{ <fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>"
}
diff --git a/src/Parsers.hs b/src/Parsers.hs
index 9faacb9..efff506 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -48,12 +48,13 @@ stringParser c a = manyTill (textParser c a <|> try (iconParser c a) <|>
-- | Parses a maximal string without color markup.
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>"))
+ noneOf "<" <|>
+ try (notFollowedBy' (char '<')
+ (try (string "fc=") <|>
+ try (string "action=") <|>
+ try (string "/action>") <|>
+ try (string "icon=") <|>
+ string "/fc>"))
return [(Text s, c, a)]
@@ -78,7 +79,7 @@ actionParser c = do
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 :: Maybe Action -> Parser [(Widget, ColorString, Maybe Action)]
colorParser a = do
@@ -154,33 +155,33 @@ parseConfig = runParser parseConf fields "Config" . stripComments
return (x,s)
perms = permute $ Config
- <$?> pFont <|?> pBgColor
- <|?> pFgColor <|?> pPosition
- <|?> pBorder <|?> pBdColor
- <|?> pHideOnStart <|?> pLowerOnStart
- <|?> pPersistent <|?> pCommands
- <|?> pSepChar <|?> pAlignSep
- <|?> pTemplate
+ <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition
+ <|?> pBorder <|?> pBdColor <|?> pHideOnStart <|?> pAllDesktops
+ <|?> pLowerOnStart <|?> pPersistent <|?> pCommands
+ <|?> pSepChar <|?> pAlignSep <|?> pTemplate
fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep"
, "border", "borderColor" ,"template", "position"
- , "hideOnStart", "lowerOnStart", "persistent", "commands"
+ , "allDesktops", "hideOnStart", "lowerOnStart"
+ , "persistent", "commands"
]
- pFont = strField font "font"
- pBgColor = strField bgColor "bgColor"
- pFgColor = strField fgColor "fgColor"
- pBdColor = strField borderColor "borderColor"
- pSepChar = strField sepChar "sepChar"
+ pFont = strField font "font"
+ pBgColor = strField bgColor "bgColor"
+ pFgColor = strField fgColor "fgColor"
+ pBdColor = strField borderColor "borderColor"
+ pSepChar = strField sepChar "sepChar"
pAlignSep = strField alignSep "alignSep"
pTemplate = strField template "template"
- pPosition = field position "position" $ tillFieldEnd >>= read' "position"
- pHideOnStart = field hideOnStart "hideOnStart" $ tillFieldEnd >>= read' "hideOnStart"
- pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart"
- pPersistent = field persistent "persistent" $ tillFieldEnd >>= read' "persistent"
- pBorder = field border "border" $ tillFieldEnd >>= read' "border"
- pCommands = field commands "commands" $ readCommands
+ pPosition = readField position "position"
+ pHideOnStart = readField hideOnStart "hideOnStart"
+ pLowerOnStart = readField lowerOnStart "lowerOnStart"
+ pPersistent = readField persistent "persistent"
+ pBorder = readField border "border"
+ pAllDesktops = readField allDesktops "allDesktops"
+
+ pCommands = field commands "commands" readCommands
staticPos = do string "Static"
wrapSkip (string "{")
@@ -191,12 +192,17 @@ parseConfig = runParser parseConf fields "Config" . stripComments
tillFieldEnd = staticPos <|> many (noneOf ",}\n\r")
commandsEnd = wrapSkip (string "]") >> (string "}" <|> notNextRun)
- notNextRun = do { string ","; notFollowedBy $ wrapSkip $ string "Run"; return ","}
+ notNextRun = do {string ","
+ ; notFollowedBy $ wrapSkip $ string "Run"
+ ; return ","
+ }
readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]"
- strField e n = field e n . between (strDel "start" n) (strDel "end" n) . many $ noneOf "\"\n\r"
- strDel t n = char '"' <?> strErr t n
- strErr t n = "the " ++ t ++ " of the string field " ++ n ++ " - a double quote (\")."
+ strField e n = field e n . between (strDel "start" n) (strDel "end" n) .
+ many $ noneOf "\"\n\r"
+ strDel t n = char '"' <?> strErr t n
+ strErr t n = "the " ++ t ++ " of the string field " ++ n ++
+ " - a double quote (\")."
wrapSkip x = many space >> x >>= \r -> many space >> return r
sepEndSpc = mapM_ (wrapSkip . try . string)
@@ -204,12 +210,11 @@ parseConfig = runParser parseConf fields "Config" . stripComments
field e n c = (,) (e defaultConfig) $
updateState (filter (/= n)) >> sepEndSpc [n,"="] >>
wrapSkip c >>= \r -> fieldEnd >> return r
-
+ readField a n = field a n $ tillFieldEnd >>= read' n
read' d s = case reads s of
[(x, _)] -> return x
- _ -> fail $ "error reading the " ++ d ++ " field: " ++ s
+ _ -> fail $ "error reading the " ++ d ++ " field: " ++ s
commandsErr :: String
commandsErr = "commands: this usually means that a command could not be parsed.\n" ++
"The error could be located at the begining of the command which follows the offending one."
-
diff --git a/src/Window.hs b/src/Window.hs
index ec50883..aff2c95 100644
--- a/src/Window.hs
+++ b/src/Window.hs
@@ -16,7 +16,7 @@
module Window where
import Prelude
-import Control.Monad (when)
+import Control.Monad (when, unless)
import Graphics.X11.Xlib hiding (textExtents, textWidth)
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xinerama
@@ -40,7 +40,7 @@ createWin d fs c = do
(r,o) = setPosition (position c) srs (fi ht)
win <- newWindow d (defaultScreenOfDisplay d) rootw r o
when (lowerOnStart c) (lowerWindow d win)
- when (not $ hideOnStart c) $ showWindow r c d win
+ unless (hideOnStart c) $ showWindow r c d win
setProperties r c d win srs
return (r,win)
@@ -88,25 +88,32 @@ setPosition p rs ht =
setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle]
-> IO ()
-setProperties r c d w srs = do
- a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False
- c1 <- internAtom d "CARDINAL" False
- a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False
- c2 <- internAtom d "ATOM" False
- v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False
- p <- internAtom d "_NET_WM_PID" False
+setProperties r c d w rs = do
+ pstrut <- internAtom d "_NET_WM_STRUT_PARTIAL" False
+ strut <- internAtom d "_NET_WM_STRUT" False
+ card <- internAtom d "CARDINAL" False
+ wtype <- internAtom d "_NET_WM_WINDOW_TYPE" False
+ atom <- internAtom d "ATOM" False
+ dock <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False
+ pid <- internAtom d "_NET_WM_PID" False
setTextProperty d w "xmobar" wM_CLASS
setTextProperty d w "xmobar" wM_NAME
ismapped <- isMapped d w
- changeProperty32 d w a1 c1 propModeReplace $
- if ismapped
- then map fi $ getStrutValues r (position c) (getRootWindowHeight srs)
- else replicate 12 0
- changeProperty32 d w a2 c2 propModeReplace [fromIntegral v]
-
- getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral
+ let svs = if ismapped
+ then map fi $ getStrutValues r
+ (position c)
+ (getRootWindowHeight rs)
+ else replicate 12 0
+ changeProperty32 d w pstrut card propModeReplace svs
+ changeProperty32 d w strut card propModeReplace (take 4 svs)
+ changeProperty32 d w wtype atom propModeReplace [fi dock]
+ when (allDesktops c) $ do
+ desktop <- internAtom d "_NET_WM_DESKTOP" False
+ changeProperty32 d w desktop card propModeReplace [0xffffffff]
+
+ getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi
getRootWindowHeight :: [Rectangle] -> Int
getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs)
@@ -115,7 +122,7 @@ getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs)
getStrutValues :: Rectangle -> XPosition -> Int -> [Int]
getStrutValues r@(Rectangle x y w h) p rwh =
- case p of
+ case p of
OnScreen _ p' -> getStrutValues r p' rwh
Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]
TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0]
@@ -126,10 +133,10 @@ getStrutValues r@(Rectangle x y w h) p rwh =
BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]
BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw]
Static {} -> getStaticStrutValues p rwh
- where st = fi y + fi h
- sb = rwh - fi y
- nx = fi x
- nw = fi (x + fi w - 1)
+ where st = fi y + fi h
+ sb = rwh - fi y
+ nx = fi x
+ nw = fi (x + fi w - 1)
-- get some reaonable strut values for static placement.
getStaticStrutValues :: XPosition -> Int -> [Int]