Merge pull request #189 from IvanMalison/fixCrashes

Share A Single connection to the X11 Server/Display Object

src/System/Information/Battery.hs

@@ -90,8 +90,8 @@ data BatteryInfo = BatteryInfo { batteryNativePath :: Text
 -}
                                }
 
--- | determin if a power source is a battery. The simple heuristic is
--- a substring search on 'BAT'.
+-- | determine if a power source is a battery. The simple heuristic is a
+-- substring search on 'BAT'.
 isBattery :: ObjectPath -> Bool
 isBattery = isInfixOf "BAT" . formatObjectPath
 

src/System/Information/X11DesktopInfo.hs

@@ -19,10 +19,11 @@
 -----------------------------------------------------------------------------
 
 module System.Information.X11DesktopInfo
-  ( X11Context
+  ( X11Context(..)
   , X11Property
   , X11Window
   , withDefaultCtx
+  , getDefaultCtx
   , readAsInt
   , readAsListOfInt
   , readAsString

src/System/Taffybar/LayoutSwitcher.hs

@@ -26,7 +26,8 @@ module System.Taffybar.LayoutSwitcher (
   layoutSwitcherNew
 ) where
 
-import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans
+import Control.Monad.Reader
 import qualified Graphics.UI.Gtk as Gtk
 import Graphics.X11.Xlib.Extras (Event)
 import System.Taffybar.Pager
@@ -66,43 +67,44 @@ layoutSwitcherNew pager = do
   -- This callback is run in a separate thread and needs to use
   -- postGUIAsync
   let cfg = config pager
-      callback = pagerCallback cfg label
+      callback = Gtk.postGUIAsync . (flip runReaderT pager) . (pagerCallback cfg label)
   subscribe pager callback xLayoutProp
-  assembleWidget label
+  assembleWidget pager label
 
 -- | Build a suitable callback function that can be registered as Listener
 -- of "_XMONAD_CURRENT_LAYOUT" custom events. These events are emitted by
 -- the PagerHints hook to notify of changes in the current layout.
-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO ()
-pagerCallback cfg label _ = Gtk.postGUIAsync $ do
-  layout <- withDefaultCtx $ readAsString Nothing xLayoutProp
+pagerCallback :: PagerConfig -> Gtk.Label -> Event -> PagerIO ()
+pagerCallback cfg label _ = do
+  layout <- liftPagerX11 $ readAsString Nothing xLayoutProp
   let decorate = activeLayout cfg
-  Gtk.labelSetMarkup label (decorate layout)
+  lift $ Gtk.labelSetMarkup label (decorate layout)
 
 -- | Build the graphical representation of the widget.
-assembleWidget :: Gtk.Label -> IO Gtk.Widget
-assembleWidget label = do
+assembleWidget :: Pager -> Gtk.Label -> IO Gtk.Widget
+assembleWidget pager label = do
   ebox <- Gtk.eventBoxNew
   Gtk.containerAdd ebox label
-  _ <- Gtk.on ebox Gtk.buttonPressEvent dispatchButtonEvent
+  _ <- Gtk.on ebox Gtk.buttonPressEvent (dispatchButtonEvent pager)
   Gtk.widgetShowAll ebox
   return $ Gtk.toWidget ebox
 
 -- | Call 'switch' with the appropriate argument (1 for left click, -1 for
 -- right click), depending on the click event received.
-dispatchButtonEvent :: Gtk.EventM Gtk.EButton Bool
-dispatchButtonEvent = do
+dispatchButtonEvent :: Pager -> Gtk.EventM Gtk.EButton Bool
+dispatchButtonEvent pager = do
   btn <- Gtk.eventButton
   let trigger = onClick [Gtk.SingleClick]
+      run = runWithPager pager
   case btn of
-    Gtk.LeftButton  -> trigger $ switch 1
-    Gtk.RightButton -> trigger $ switch (-1)
+    Gtk.LeftButton  -> trigger $ run $ switch 1
+    Gtk.RightButton -> trigger $ run $ switch (-1)
     _               -> return False
 
 -- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be
 -- intercepted by the PagerHints hook, which in turn can instruct XMonad to
 -- switch to a different layout.
-switch :: (MonadIO m) => Int -> m ()
-switch n = liftIO $ withDefaultCtx $ do
+switch :: Int -> X11Property ()
+switch n = do
   cmd <- getAtom xLayoutProp
   sendCommandEvent cmd (fromIntegral n)

src/System/Taffybar/Pager.hs

@@ -29,12 +29,15 @@
 -----------------------------------------------------------------------------
 
 module System.Taffybar.Pager
-  ( Pager (config)
+  ( Pager (..)
   , PagerConfig (..)
+  , PagerIO
   , defaultPagerConfig
   , pagerNew
   , subscribe
   , colorize
+  , liftPagerX11
+  , runWithPager
   , shorten
   , wrap
   , escape
@@ -81,8 +84,19 @@ data PagerConfig = PagerConfig
 data Pager = Pager
   { config  :: PagerConfig -- ^ the configuration settings.
   , clients :: SubscriptionList -- ^ functions to apply on incoming events depending on their types.
+  , pagerX11ContextVar :: IORef X11Context
   }
 
+type PagerIO a = ReaderT Pager IO a
+
+liftPagerX11 :: X11Property a -> PagerIO a
+liftPagerX11 prop = ask >>= lift . flip runWithPager prop
+
+runWithPager :: Pager -> X11Property a -> IO a
+runWithPager pager prop = do
+  x11Ctx <- readIORef $ pagerX11ContextVar pager
+  runReaderT prop x11Ctx
+
 -- | Default pretty printing options.
 defaultPagerConfig :: PagerConfig
 defaultPagerConfig   = PagerConfig
@@ -109,8 +123,10 @@ defaultPagerConfig   = PagerConfig
 pagerNew :: PagerConfig -> IO Pager
 pagerNew cfg = do
   ref <- newIORef []
-  let pager = Pager cfg ref
-  _ <- forkIO $ withDefaultCtx $ eventLoop (handleEvent ref)
+  ctx <- getDefaultCtx
+  ctxVar <- newIORef ctx
+  let pager = Pager cfg ref ctxVar
+  _ <- forkIO $ withDefaultCtx (eventLoop $ handleEvent ref)
   return pager
     where handleEvent :: SubscriptionList -> Event -> IO ()
           handleEvent ref event = do
@@ -131,7 +147,7 @@ notify event (listener, eventFilter) =
 -- the Pager, it will execute Listener on it.
 subscribe :: Pager -> Listener -> String -> IO ()
 subscribe pager listener filterName = do
-  eventFilter <- withDefaultCtx $ getAtom filterName
+  eventFilter <- runWithPager pager $ getAtom filterName
   registered <- readIORef (clients pager)
   let next = (listener, eventFilter)
   writeIORef (clients pager) (next : registered)

src/System/Taffybar/WindowSwitcher.hs

@@ -25,12 +25,12 @@ module System.Taffybar.WindowSwitcher (
   windowSwitcherNew
 ) where
 
-import Control.Monad (forM_)
+import Control.Monad.Reader
 import qualified Data.Map as M
-import Control.Monad.IO.Class ( liftIO )
 import qualified Graphics.UI.Gtk as Gtk
 import Graphics.X11.Xlib.Extras (Event)
 import System.Information.EWMHDesktopInfo
+import System.Information.X11DesktopInfo
 import System.Taffybar.Pager
 
 -- $usage
@@ -63,21 +63,20 @@ windowSwitcherNew pager = do
   -- callback in another thread.  We need to use postGUIAsync in it.
   let cfg = config pager
       callback = pagerCallback cfg label
-  subscribe pager callback "_NET_ACTIVE_WINDOW"
-  assembleWidget label
+  subscribe pager (runWithPager pager . callback) "_NET_ACTIVE_WINDOW"
+  assembleWidget pager label
 
 -- | Build a suitable callback function that can be registered as Listener
 -- of "_NET_ACTIVE_WINDOW" standard events. It will keep track of the
 -- currently focused window.
-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO ()
+pagerCallback :: PagerConfig -> Gtk.Label -> Event -> X11Property ()
 pagerCallback cfg label _ = do
-  title <- withDefaultCtx getActiveWindowTitle
+  title <- getActiveWindowTitle
   let decorate = activeWindow cfg
-  Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title)
+  lift $ Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title)
 
--- | Build the graphical representation of the widget.
-assembleWidget :: Gtk.Label -> IO Gtk.Widget
-assembleWidget label = do
+assembleWidget :: Pager -> Gtk.Label -> IO Gtk.Widget
+assembleWidget pager label = do
   ebox <- Gtk.eventBoxNew
   Gtk.widgetSetName ebox "WindowTitle"
   Gtk.containerAdd ebox label
@@ -107,22 +106,22 @@ assembleWidget label = do
   Gtk.menuItemSetSubmenu title menu
   -- These callbacks are run in the GUI thread automatically and do
   -- not need to use postGUIAsync
-  _ <- Gtk.on title Gtk.menuItemActivate $ fillMenu  menu
+  _ <- Gtk.on title Gtk.menuItemActivate $ fillMenu pager menu
   _ <- Gtk.on title Gtk.menuItemDeselect $ emptyMenu menu
 
   Gtk.widgetShowAll switcher
   return $ Gtk.toWidget switcher
 
 -- | Populate the given menu widget with the list of all currently open windows.
-fillMenu :: Gtk.MenuClass menu => menu -> IO ()
-fillMenu menu = withDefaultCtx $ do
+fillMenu :: Gtk.MenuClass menu => Pager -> menu -> IO ()
+fillMenu pager menu = runWithPager pager $ do
   handles <- getWindowHandles
   if null handles then return () else do
     wsNames <- getWorkspaceNames
     forM_ handles $ \handle -> liftIO $ do
       item <- Gtk.menuItemNewWithLabel (formatEntry (M.fromList wsNames) handle)
       _ <- Gtk.on item Gtk.buttonPressEvent $ liftIO $ do
-        withDefaultCtx (focusWindow $ snd handle)
+        runWithPager pager $ focusWindow $ snd handle
         return True
       Gtk.menuShellAppend menu item
       Gtk.widgetShow item