New allDesktops configuration parameter

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]