Merge for pull request #53

1 files changed, 37 insertions, 158 deletions

diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index c348f99..2dbba11 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -39,19 +39,21 @@ import Control.Arrow ((&&&))
 import Control.Monad.Reader
 import Control.Concurrent
 import Control.Concurrent.STM
-import Control.Exception hiding (handle)
+import Control.Exception (catch, SomeException(..))
 import Data.Bits
-import Data.Maybe(fromMaybe)
-import Data.Typeable (Typeable)
-import System.Posix.Process (getProcessID)
-import System.Posix.Signals
 
 import Config
 import Parsers
 import Commands
 import Runnable
+import Signal
+import Window
 import XUtil
 
+#ifdef DBUS
+import IPC.DBus
+#endif
+
 -- $main
 --
 -- The Xmobar data type and basic loops and functions.
@@ -72,16 +74,10 @@ data XConf =
 runX :: XConf -> X () -> IO ()
 runX xc f = runReaderT f xc
 
-data WakeUp = WakeUp deriving (Show,Typeable)
-instance Exception WakeUp
-
-data SignalType = Wakeup | Reposition | ChangeScreen
-
 -- | Starts the main event loop and threads
-startLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO ()
-startLoop xcfg@(XConf _ _ w _ _) vs = do
+startLoop :: XConf -> MVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO ()
+startLoop xcfg@(XConf _ _ w _ _) sig vs = do
     tv <- atomically $ newTVar []
-    sig <- setupSignalHandler
     _ <- forkIO (checker tv [] vs sig `catch`
                    \(SomeException _) -> void (putStrLn "Thread checker failed"))
 #ifdef THREADED_RUNTIME
@@ -90,6 +86,9 @@ startLoop xcfg@(XConf _ _ w _ _) vs = do
     _ <- forkIO (eventer sig `catch`
 #endif
                    \(SomeException _) -> void (putStrLn "Thread eventer failed"))
+#ifdef DBUS
+    runIPC sig
+#endif
     eventLoop tv xcfg sig
   where
     -- Reacts on events from X
@@ -147,7 +146,27 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do
             ncfg <- updateConfigPosition cfg
             reposWindow ncfg
 
+         Hide ->   hide
+         Reveal -> reveal
+         Toggle -> toggle
+
+         TogglePersistent -> eventLoop
+            tv xc { config = cfg { persistent = not $ persistent cfg } } signal
+
     where
+        isPersistent = not $ persistent cfg
+
+        hide   = when isPersistent (hideWindow d w) >> eventLoop tv xc signal
+
+        reveal = if isPersistent
+            then do
+                r' <- repositionWin d w fs cfg
+                showWindow d w
+                eventLoop tv (XConf d r' w fs cfg) signal
+            else eventLoop tv xc signal
+
+        toggle = isMapped d w >>= \b -> if b then hide else reveal
+
         reposWindow rcfg = do
           r' <- repositionWin d w fs rcfg
           eventLoop tv (XConf d r' w fs rcfg) signal
@@ -163,149 +182,24 @@ eventLoop tv xc@(XConf d _ w fs cfg) signal = do
             o ->
               return (ocfg {position = OnScreen 1 o})
 
-
--- | Signal handling
-setupSignalHandler :: IO (MVar SignalType)
-setupSignalHandler = do
-   tid   <- newEmptyMVar
-   installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing
-   installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing
-   return tid
-
-updatePosHandler :: MVar SignalType -> IO ()
-updatePosHandler sig = do
-   putMVar sig Reposition
-   return ()
-
-changeScreenHandler :: MVar SignalType -> IO ()
-changeScreenHandler sig = do
-   putMVar sig ChangeScreen
-   return ()
-
 -- $command
 
 -- | Runs a command as an independent thread and returns its thread id
 -- and the TVar the command will be writing to.
-startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String)
-startCommand (com,s,ss)
+startCommand :: MVar SignalType
+             -> (Runnable,String,String)
+             -> IO (Maybe ThreadId, TVar String)
+startCommand sig (com,s,ss)
     | alias com == "" = do var <- atomically $ newTVar is
                            atomically $ writeTVar var (s ++ ss)
                            return (Nothing,var)
     | otherwise       = do var <- atomically $ newTVar is
                            let cb str = atomically $ writeTVar var (s ++ str ++ ss)
                            h <- forkIO $ start com cb
+                           _ <- forkIO $ trigger com ( maybe (return ()) (putMVar sig) )
                            return (Just h,var)
     where is = s ++ "Updating..." ++ ss
 
--- $window
-
--- | The function to create the initial window
-createWin :: Display -> XFont -> Config -> IO (Rectangle,Window)
-createWin d fs c = do
-  let dflt = defaultScreen d
-  srs     <- getScreenInfo d
-  rootw   <- rootWindow d dflt
-  (as,ds) <- textExtents fs "0"
-  let ht    = as + ds + 4
-      (r,o) = setPosition (position c) srs (fi ht)
-  win <- newWindow  d (defaultScreenOfDisplay d) rootw r o
-  setProperties r c d win srs
-  when (lowerOnStart c) (lowerWindow d win)
-  mapWindow         d win
-  return (r,win)
-
--- | Updates the size and position of the window
-repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle
-repositionWin d win fs c = do
-  srs     <- getScreenInfo d
-  (as,ds) <- textExtents fs "0"
-  let ht    = as + ds + 4
-      (r,_) = setPosition (position c) srs (fi ht)
-  moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r)
-  setProperties r c d win srs
-  return r
-
-setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool)
-setPosition p rs ht =
-  case p' of
-    Top -> (Rectangle rx ry rw h, True)
-    TopW a i -> (Rectangle (ax a i) ry (nw i) h, True)
-    TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True)
-    Bottom -> (Rectangle rx ny rw h, True)
-    BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True)
-    BottomSize a i ch  -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True)
-    Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True)
-    OnScreen _ p'' -> setPosition p'' [scr] ht
-  where
-    (scr@(Rectangle rx ry rw rh), p') =
-      case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x)
-                _ -> (head rs, p)
-    ny       = ry + fi (rh - ht)
-    center i = rx + fi (div (remwid i) 2)
-    right  i = rx + fi (remwid i)
-    remwid i = rw - pw (fi i)
-    ax L     = const rx
-    ax R     = right
-    ax C     = center
-    pw i     = rw * min 100 i `div` 100
-    nw       = fi . pw . fi
-    h        = fi ht
-    mh h'    = max (fi h') h
-    ny' h'   = ry + fi (rh - mh h')
-    safeIndex i = lookup i . zip [0..]
-
-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
-
-  setTextProperty d w "xmobar" wM_CLASS
-  setTextProperty d w "xmobar" wM_NAME
-
-  changeProperty32 d w a1 c1 propModeReplace $ map fi $
-    getStrutValues r (position c) (getRootWindowHeight srs)
-  changeProperty32 d w a2 c2 propModeReplace [fromIntegral v]
-
-  getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral
-
-getRootWindowHeight :: [Rectangle] -> Int
-getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs)
-  where
-    getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr)
-
-getStrutValues :: Rectangle -> XPosition -> Int -> [Int]
-getStrutValues r@(Rectangle x y w h) p rwh =
-    case p of
-    OnScreen _ p'   -> getStrutValues r p' rwh
-    Top             -> [0, 0, st,  0, 0, 0, 0, 0, nx, nw,  0,  0]
-    TopW    _ _     -> [0, 0, st,  0, 0, 0, 0, 0, nx, nw,  0,  0]
-    TopSize      {} -> [0, 0, st,  0, 0, 0, 0, 0, nx, nw,  0,  0]
-    Bottom          -> [0, 0,  0, sb, 0, 0, 0, 0,  0,  0, nx, nw]
-    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)
-
--- get some reaonable strut values for static placement.
-getStaticStrutValues :: XPosition -> Int -> [Int]
-getStaticStrutValues (Static cx cy cw ch) rwh
-    -- if the yPos is in the top half of the screen, then assume a Top
-    -- placement, otherwise, it's a Bottom placement
-    | cy < (rwh `div` 2) = [0, 0, st,  0, 0, 0, 0, 0, xs, xe,  0,  0]
-    | otherwise          = [0, 0,  0, sb, 0, 0, 0, 0,  0,  0, xs, xe]
-    where st = cy + ch
-          sb = rwh - cy
-          xs = cx -- a simple calculation for horizontal (x) placement
-          xe = xs + cw
-getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
-
 updateWin :: TVar [String] -> X ()
 updateWin v = do
   xc <- ask
@@ -346,21 +240,6 @@ drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do
     -- resync
     io $ sync       d True
 
-drawBorder :: Border -> Display -> Drawable -> GC -> Pixel
-              -> Dimension -> Dimension -> IO ()
-drawBorder b d p gc c wi ht =  case b of
-  NoBorder -> return ()
-  TopB       -> drawBorder (TopBM 0) d p gc c w h
-  BottomB    -> drawBorder (BottomBM 0) d p gc c w h
-  FullB      -> drawBorder (FullBM 0) d p gc c w h
-  TopBM m    -> sf >> drawLine d p gc 0 (fi m) (fi w) 0
-  BottomBM m -> let rw = fi h - fi m in
-                 sf >> drawLine d p gc 0 rw (fi w) rw
-  FullBM m   -> let pad = 2 * fi m; mp = fi m in
-                 sf >> drawRectangle d p gc mp mp (w - pad) (h - pad)
-  where sf = setForeground d gc c
-        (w, h) = (wi - 1, ht - 1)
-
 -- | An easy way to print the stuff we need to print
 printStrings :: Drawable -> GC -> XFont -> Position
              -> Align -> [(String, String, Position)] -> X ()