{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ImpredicativeTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Context
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- The "System.Taffybar.Context" module provides the core functionality of the
-- taffybar library. It gets its name from the 'Context' record, which stores
-- runtime information and objects, which are used by many of the widgets that
-- taffybar provides. 'Context' is typically accessed through the 'Reader'
-- interface of 'TaffyIO'.
-----------------------------------------------------------------------------

module System.Taffybar.Context
  ( Context(..)
  , TaffybarConfig(..)
  , Taffy
  , TaffyIO
  , BarConfig(..)
  , BarConfigGetter
  , appendHook
  , buildContext
  , buildEmptyContext
  , defaultTaffybarConfig
  , getState
  , getStateDefault
  , putState
  , forceRefreshTaffyWindows
  , refreshTaffyWindows
  , runX11
  , runX11Def
  , subscribeToAll
  , subscribeToPropertyEvents
  , taffyFork
  , unsubscribe
  ) where

import           Control.Arrow ((&&&))
import           Control.Concurrent (forkIO)
import qualified Control.Concurrent.MVar as MV
import           Control.Exception.Enclosed (catchAny)
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Reader
import qualified DBus.Client as DBus
import           Data.Data
import           Data.Default (Default(..))
import           Data.GI.Base.ManagedPtr (unsafeCastTo)
import           Data.Int
import           Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import           Data.Tuple.Select
import           Data.Tuple.Sequence
import           Data.Unique
import qualified GI.Gdk
import qualified GI.GdkX11 as GdkX11
import           GI.GdkX11.Objects.X11Window
import qualified GI.Gtk as Gtk
import           Graphics.UI.GIGtkStrut
import           StatusNotifier.TransparentWindow
import           System.Log.Logger
import           System.Taffybar.Information.SafeX11
import           System.Taffybar.Information.X11DesktopInfo
import           System.Taffybar.Util
import           System.Taffybar.Widget.Util
import           Text.Printf
import           Unsafe.Coerce

logIO :: System.Log.Logger.Priority -> String -> IO ()
logIO :: Priority -> String -> IO ()
logIO = String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Context"

logC :: MonadIO m => System.Log.Logger.Priority -> String -> m ()
logC :: forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
p = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> String -> IO ()
logIO Priority
p

-- | 'Taffy' is a monad transformer that provides 'Reader' for 'Context'.
type Taffy m v = ReaderT Context m v

-- | 'TaffyIO' is 'IO' wrapped with a 'ReaderT' providing 'Context'. This is the
-- type of most widgets and callback in taffybar.
type TaffyIO v = ReaderT Context IO v

type Listener = Event -> Taffy IO ()
type SubscriptionList = [(Unique, Listener)]
data Value = forall t. Typeable t => Value t

fromValue :: forall t. Typeable t => Value -> Maybe t
fromValue :: forall t. Typeable t => Value -> Maybe t
fromValue (Value t
v) =
  if t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf t
v TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) then
    t -> Maybe t
forall a. a -> Maybe a
Just (t -> Maybe t) -> t -> Maybe t
forall a b. (a -> b) -> a -> b
$ t -> t
forall a b. a -> b
unsafeCoerce t
v
  else
    Maybe t
forall a. Maybe a
Nothing

-- | 'BarConfig' specifies the configuration for a single taffybar window.
data BarConfig = BarConfig
  {
  -- | The strut configuration to use for the bar
    BarConfig -> StrutConfig
strutConfig :: StrutConfig
  -- | The amount of spacing in pixels between bar widgets
  , BarConfig -> Int32
widgetSpacing :: Int32
  -- | Constructors for widgets that should be placed at the beginning of the bar.
  , BarConfig -> [TaffyIO Widget]
startWidgets :: [TaffyIO Gtk.Widget]
  -- | Constructors for widgets that should be placed in the center of the bar.
  , BarConfig -> [TaffyIO Widget]
centerWidgets :: [TaffyIO Gtk.Widget]
  -- | Constructors for widgets that should be placed at the end of the bar.
  , BarConfig -> [TaffyIO Widget]
endWidgets :: [TaffyIO Gtk.Widget]
  -- | A unique identifier for the bar, that can be used e.g. when toggling.
  , BarConfig -> Unique
barId :: Unique
  }

instance Eq BarConfig where
  BarConfig
a == :: BarConfig -> BarConfig -> Bool
== BarConfig
b = BarConfig -> Unique
barId BarConfig
a Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== BarConfig -> Unique
barId BarConfig
b

type BarConfigGetter = TaffyIO [BarConfig]

-- | 'TaffybarConfig' provides an advanced interface for configuring taffybar.
-- Through the 'getBarConfigsParam', it is possible to specify different
-- taffybar configurations depending on the number of monitors present, and even
-- to specify different taffybar configurations for each monitor.
data TaffybarConfig = TaffybarConfig
  {
  -- | An optional dbus client to use.
    TaffybarConfig -> Maybe Client
dbusClientParam :: Maybe DBus.Client
  -- | Hooks that should be executed at taffybar startup.
  , TaffybarConfig -> TaffyIO ()
startupHook :: TaffyIO ()
  -- | A 'TaffyIO' action that returns a list of 'BarConfig' where each element
  -- describes a taffybar window that should be spawned.
  , TaffybarConfig -> BarConfigGetter
getBarConfigsParam :: BarConfigGetter
  -- | A list of 'FilePath' each of which should be loaded as css files at
  -- startup.
  , TaffybarConfig -> [String]
cssPaths :: [FilePath]
  -- | A field used (only) by dyre to provide an error message.
  , TaffybarConfig -> Maybe String
errorMsg :: Maybe String
  }


-- | Append the provided 'TaffyIO' hook to the 'startupHook' of the given
-- 'TaffybarConfig'.
appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig
appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig
appendHook TaffyIO ()
hook TaffybarConfig
config = TaffybarConfig
config
  { startupHook :: TaffyIO ()
startupHook = TaffybarConfig -> TaffyIO ()
startupHook TaffybarConfig
config TaffyIO () -> TaffyIO () -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> ReaderT Context IO b -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TaffyIO ()
hook }

-- | Default values for a 'TaffybarConfig'. Not usuable without at least
-- properly setting 'getBarConfigsParam'.
defaultTaffybarConfig :: TaffybarConfig
defaultTaffybarConfig :: TaffybarConfig
defaultTaffybarConfig = TaffybarConfig
  { dbusClientParam :: Maybe Client
dbusClientParam = Maybe Client
forall a. Maybe a
Nothing
  , startupHook :: TaffyIO ()
startupHook = () -> TaffyIO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  , getBarConfigsParam :: BarConfigGetter
getBarConfigsParam = [BarConfig] -> BarConfigGetter
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  , cssPaths :: [String]
cssPaths = []
  , errorMsg :: Maybe String
errorMsg = Maybe String
forall a. Maybe a
Nothing
  }

instance Default TaffybarConfig where
  def :: TaffybarConfig
def = TaffybarConfig
defaultTaffybarConfig

-- | A "Context" value holds all of the state associated with a single running
-- instance of taffybar. It is typically accessed from a widget constructor
-- through the "TaffyIO" monad transformer stack.
data Context = Context
  {
  -- | The X11Context that will be used to service X11Property requests.
    Context -> MVar X11Context
x11ContextVar :: MV.MVar X11Context
  -- | The handlers which will be evaluated against incoming X11 events.
  , Context -> MVar SubscriptionList
listeners :: MV.MVar SubscriptionList
  -- | A collection of miscellaneous pieces of state which are keyed by their
  -- types. Most new pieces of state should go here, rather than in a new field
  -- in 'Context'. State stored here is typically accessed through
  -- 'getStateDefault'.
  , Context -> MVar (Map TypeRep Value)
contextState :: MV.MVar (M.Map TypeRep Value)
  -- | Used to track the windows that taffybar is currently controlling, and
  -- which 'BarConfig' objects they are associated with.
  , Context -> MVar [(BarConfig, Window)]
existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]
  -- | The shared user session 'DBus.Client'.
  , Context -> Client
sessionDBusClient :: DBus.Client
  -- | The shared system session 'DBus.Client'.
  , Context -> Client
systemDBusClient :: DBus.Client
  -- | The action that will be evaluated to get the bar configs associated with
  -- each active monitor taffybar should run on.
  , Context -> BarConfigGetter
getBarConfigs :: BarConfigGetter
  -- | Populated with the BarConfig that resulted in the creation of a given
  -- widget, when its constructor is called. This lets widgets access thing like
  -- who their neighbors are. Note that the value of 'contextBarConfig' is
  -- different for widgets belonging to bar windows on different monitors.
  , Context -> Maybe BarConfig
contextBarConfig :: Maybe BarConfig
  }

-- | Build the "Context" for a taffybar process.
buildContext :: TaffybarConfig -> IO Context
buildContext :: TaffybarConfig -> IO Context
buildContext TaffybarConfig
               { dbusClientParam :: TaffybarConfig -> Maybe Client
dbusClientParam = Maybe Client
maybeDBus
               , getBarConfigsParam :: TaffybarConfig -> BarConfigGetter
getBarConfigsParam = BarConfigGetter
barConfigGetter
               , startupHook :: TaffybarConfig -> TaffyIO ()
startupHook = TaffyIO ()
startup
               } = do
  Priority -> String -> IO ()
logIO Priority
DEBUG String
"Building context"
  Client
dbusC <- IO Client -> (Client -> IO Client) -> Maybe Client -> IO Client
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Client
DBus.connectSession Client -> IO Client
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Client
maybeDBus
  Client
sDBusC <- IO Client
DBus.connectSystem
  RequestNameReply
_ <- Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
DBus.requestName Client
dbusC BusName
"org.taffybar.Bar"
       [RequestNameFlag
DBus.nameAllowReplacement, RequestNameFlag
DBus.nameReplaceExisting]
  MVar SubscriptionList
listenersVar <- SubscriptionList -> IO (MVar SubscriptionList)
forall a. a -> IO (MVar a)
MV.newMVar []
  MVar (Map TypeRep Value)
state <- Map TypeRep Value -> IO (MVar (Map TypeRep Value))
forall a. a -> IO (MVar a)
MV.newMVar Map TypeRep Value
forall k a. Map k a
M.empty
  MVar X11Context
x11Context <- IO X11Context
getDefaultCtx IO X11Context
-> (X11Context -> IO (MVar X11Context)) -> IO (MVar X11Context)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X11Context -> IO (MVar X11Context)
forall a. a -> IO (MVar a)
MV.newMVar
  MVar [(BarConfig, Window)]
windowsVar <- [(BarConfig, Window)] -> IO (MVar [(BarConfig, Window)])
forall a. a -> IO (MVar a)
MV.newMVar []
  let context :: Context
context = Context
                { x11ContextVar :: MVar X11Context
x11ContextVar = MVar X11Context
x11Context
                , listeners :: MVar SubscriptionList
listeners = MVar SubscriptionList
listenersVar
                , contextState :: MVar (Map TypeRep Value)
contextState = MVar (Map TypeRep Value)
state
                , sessionDBusClient :: Client
sessionDBusClient = Client
dbusC
                , systemDBusClient :: Client
systemDBusClient = Client
sDBusC
                , getBarConfigs :: BarConfigGetter
getBarConfigs = BarConfigGetter
barConfigGetter
                , existingWindows :: MVar [(BarConfig, Window)]
existingWindows = MVar [(BarConfig, Window)]
windowsVar
                , contextBarConfig :: Maybe BarConfig
contextBarConfig = Maybe BarConfig
forall a. Maybe a
Nothing
                }
  Maybe CULong
_ <- MaybeT IO CULong -> IO (Maybe CULong)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO CULong -> IO (Maybe CULong))
-> MaybeT IO CULong -> IO (Maybe CULong)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Display) -> MaybeT IO Display
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Display)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Maybe Display)
GI.Gdk.displayGetDefault MaybeT IO Display
-> (Display -> MaybeT IO Screen) -> MaybeT IO Screen
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
              (IO Screen -> MaybeT IO Screen
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Screen -> MaybeT IO Screen)
-> (Display -> IO Screen) -> Display -> MaybeT IO Screen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> IO Screen
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDisplay a) =>
a -> m Screen
GI.Gdk.displayGetDefaultScreen) MaybeT IO Screen
-> (Screen -> MaybeT IO CULong) -> MaybeT IO CULong
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
              (IO CULong -> MaybeT IO CULong
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO CULong -> MaybeT IO CULong)
-> (Screen -> IO CULong) -> Screen -> MaybeT IO CULong
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen -> ((?self::Screen) => IO ()) -> IO CULong)
-> ((?self::Screen) => IO ()) -> Screen -> IO CULong
forall a b c. (a -> b -> c) -> b -> a -> c
flip Screen -> ((?self::Screen) => IO ()) -> IO CULong
forall a (m :: * -> *).
(IsScreen a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m CULong
GI.Gdk.afterScreenMonitorsChanged
               -- XXX: We have to do a force refresh here because there is no
               -- way to reliably move windows, since the window manager can do
               -- whatever it pleases.
               (TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TaffyIO ()
forceRefreshTaffyWindows Context
context))
  (TaffyIO () -> Context -> IO ()) -> Context -> TaffyIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
context (TaffyIO () -> IO ()) -> TaffyIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Priority -> String -> TaffyIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
DEBUG String
"Starting X11 Handler"
    TaffyIO ()
startX11EventHandler
    Priority -> String -> TaffyIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
DEBUG String
"Running startup hook"
    TaffyIO ()
startup
    Priority -> String -> TaffyIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
DEBUG String
"Queing build windows command"
    TaffyIO ()
refreshTaffyWindows
  Priority -> String -> IO ()
logIO Priority
DEBUG String
"Context build finished"
  Context -> IO Context
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Context
context

-- | Build an empty taffybar context. This function is mostly useful for
-- invoking functions that yield 'TaffyIO' values in a testing setting (e.g. in
-- a repl).
buildEmptyContext :: IO Context
buildEmptyContext :: IO Context
buildEmptyContext = TaffybarConfig -> IO Context
buildContext TaffybarConfig
forall a. Default a => a
def

buildBarWindow :: Context -> BarConfig -> IO Gtk.Window
buildBarWindow :: Context -> BarConfig -> IO Window
buildBarWindow Context
context BarConfig
barConfig = do
  let thisContext :: Context
thisContext = Context
context { contextBarConfig :: Maybe BarConfig
contextBarConfig = BarConfig -> Maybe BarConfig
forall a. a -> Maybe a
Just BarConfig
barConfig }
  Priority -> String -> IO ()
logIO Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Building bar window with StrutConfig: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
      StrutConfig -> String
forall a. Show a => a -> String
show (StrutConfig -> String) -> StrutConfig -> String
forall a b. (a -> b) -> a -> b
$ BarConfig -> StrutConfig
strutConfig BarConfig
barConfig

  Window
window <- WindowType -> IO Window
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
WindowType -> m Window
Gtk.windowNew WindowType
Gtk.WindowTypeToplevel
  Box
box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal (Int32 -> IO Box) -> Int32 -> IO Box
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$
         BarConfig -> Int32
widgetSpacing BarConfig
barConfig
  Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
box Text
"taffy-box"
  Box
centerBox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal (Int32 -> IO Box) -> Int32 -> IO Box
forall a b. (a -> b) -> a -> b
$
               Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ BarConfig -> Int32
widgetSpacing BarConfig
barConfig

  Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
centerBox Text
"center-box"
  Box -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
Gtk.widgetSetVexpand Box
centerBox Bool
True
  Box -> Align -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetValign Box
centerBox Align
Gtk.AlignFill
  Box -> Align -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetHalign Box
centerBox Align
Gtk.AlignCenter
  Box -> Maybe Box -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> Maybe b -> m ()
Gtk.boxSetCenterWidget Box
box (Box -> Maybe Box
forall a. a -> Maybe a
Just Box
centerBox)

  StrutConfig -> Window -> IO ()
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
StrutConfig -> Window -> m ()
setupStrutWindow (BarConfig -> StrutConfig
strutConfig BarConfig
barConfig) Window
window
  Window -> Box -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Window
window Box
box

  Window
_ <- Window -> Text -> IO Window
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Window
window Text
"taffy-window"

  let addWidgetWith :: (Int -> Widget -> IO ()) -> (Int, TaffyIO Widget) -> IO ()
addWidgetWith Int -> Widget -> IO ()
widgetAdd (Int
count, TaffyIO Widget
buildWidget) =
        TaffyIO Widget -> Context -> IO Widget
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TaffyIO Widget
buildWidget Context
thisContext IO Widget -> (Widget -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Widget -> IO ()
widgetAdd Int
count
      addToStart :: Int -> Widget -> IO ()
addToStart Int
count Widget
widget = do
        Widget
_ <- Widget -> Text -> IO Widget
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Widget
widget (Text -> IO Widget) -> Text -> IO Widget
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"left-%d" (Int
count :: Int)
        Box -> Widget -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
Gtk.boxPackStart Box
box Widget
widget Bool
False Bool
False Word32
0
      addToEnd :: Int -> Widget -> IO ()
addToEnd Int
count Widget
widget = do
        Widget
_ <- Widget -> Text -> IO Widget
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Widget
widget (Text -> IO Widget) -> Text -> IO Widget
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"right-%d" (Int
count :: Int)
        Box -> Widget -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
Gtk.boxPackEnd Box
box Widget
widget Bool
False Bool
False Word32
0
      addToCenter :: Int -> Widget -> IO ()
addToCenter Int
count Widget
widget = do
        Widget
_ <- Widget -> Text -> IO Widget
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Widget
widget (Text -> IO Widget) -> Text -> IO Widget
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"center-%d" (Int
count :: Int)
        Box -> Widget -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
Gtk.boxPackStart Box
centerBox Widget
widget Bool
False Bool
False Word32
0

  Priority -> String -> IO ()
logIO Priority
DEBUG String
"Building start widgets"
  ((Int, TaffyIO Widget) -> IO ())
-> [(Int, TaffyIO Widget)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Int -> Widget -> IO ()) -> (Int, TaffyIO Widget) -> IO ()
addWidgetWith Int -> Widget -> IO ()
addToStart) ([(Int, TaffyIO Widget)] -> IO ())
-> [(Int, TaffyIO Widget)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [TaffyIO Widget] -> [(Int, TaffyIO Widget)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (BarConfig -> [TaffyIO Widget]
startWidgets BarConfig
barConfig)
  Priority -> String -> IO ()
logIO Priority
DEBUG String
"Building center widgets"
  ((Int, TaffyIO Widget) -> IO ())
-> [(Int, TaffyIO Widget)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Int -> Widget -> IO ()) -> (Int, TaffyIO Widget) -> IO ()
addWidgetWith Int -> Widget -> IO ()
addToCenter) ([(Int, TaffyIO Widget)] -> IO ())
-> [(Int, TaffyIO Widget)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [TaffyIO Widget] -> [(Int, TaffyIO Widget)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (BarConfig -> [TaffyIO Widget]
centerWidgets BarConfig
barConfig)
  Priority -> String -> IO ()
logIO Priority
DEBUG String
"Building end widgets"
  ((Int, TaffyIO Widget) -> IO ())
-> [(Int, TaffyIO Widget)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Int -> Widget -> IO ()) -> (Int, TaffyIO Widget) -> IO ()
addWidgetWith Int -> Widget -> IO ()
addToEnd) ([(Int, TaffyIO Widget)] -> IO ())
-> [(Int, TaffyIO Widget)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [TaffyIO Widget] -> [(Int, TaffyIO Widget)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (BarConfig -> [TaffyIO Widget]
endWidgets BarConfig
barConfig)

  Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
makeWindowTransparent Window
window

  Priority -> String -> IO ()
logIO Priority
DEBUG String
"Showing window"
  Window -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Window
window
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Box
box
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Box
centerBox

  Context -> () -> X11Property () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context -> a -> X11Property a -> m a
runX11Context Context
context () (X11Property () -> IO ()) -> X11Property () -> IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT X11Context IO (Maybe ()) -> X11Property ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT X11Context IO (Maybe ()) -> X11Property ())
-> ReaderT X11Context IO (Maybe ()) -> X11Property ()
forall a b. (a -> b) -> a -> b
$ MaybeT (ReaderT X11Context IO) ()
-> ReaderT X11Context IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT X11Context IO) ()
 -> ReaderT X11Context IO (Maybe ()))
-> MaybeT (ReaderT X11Context IO) ()
-> ReaderT X11Context IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
    Window
gdkWindow <- ReaderT X11Context IO (Maybe Window)
-> MaybeT (ReaderT X11Context IO) Window
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ReaderT X11Context IO (Maybe Window)
 -> MaybeT (ReaderT X11Context IO) Window)
-> ReaderT X11Context IO (Maybe Window)
-> MaybeT (ReaderT X11Context IO) Window
forall a b. (a -> b) -> a -> b
$ Window -> ReaderT X11Context IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m (Maybe Window)
Gtk.widgetGetWindow Window
window
    CULong
xid <- X11Window -> MaybeT (ReaderT X11Context IO) CULong
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsX11Window a) =>
a -> m CULong
GdkX11.x11WindowGetXid (X11Window -> MaybeT (ReaderT X11Context IO) CULong)
-> MaybeT (ReaderT X11Context IO) X11Window
-> MaybeT (ReaderT X11Context IO) CULong
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO X11Window -> MaybeT (ReaderT X11Context IO) X11Window
forall a. IO a -> MaybeT (ReaderT X11Context IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((ManagedPtr X11Window -> X11Window) -> Window -> IO X11Window
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo ManagedPtr X11Window -> X11Window
X11Window Window
gdkWindow)
    Priority -> String -> MaybeT (ReaderT X11Context IO) ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
DEBUG (String -> MaybeT (ReaderT X11Context IO) ())
-> String -> MaybeT (ReaderT X11Context IO) ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Lowering X11 window %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CULong -> String
forall a. Show a => a -> String
show CULong
xid
    X11Property () -> MaybeT (ReaderT X11Context IO) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (X11Property () -> MaybeT (ReaderT X11Context IO) ())
-> X11Property () -> MaybeT (ReaderT X11Context IO) ()
forall a b. (a -> b) -> a -> b
$ Atom -> X11Property ()
doLowerWindow (CULong -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULong
xid)

  Window -> IO Window
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Window
window

-- | Use the "barConfigGetter" field of "Context" to get the set of taffybar
-- windows that should active. Will avoid recreating windows if there is already
-- a window with the appropriate geometry and "BarConfig".
refreshTaffyWindows :: TaffyIO ()
refreshTaffyWindows :: TaffyIO ()
refreshTaffyWindows = (IO () -> IO ()) -> TaffyIO () -> TaffyIO ()
forall (m :: * -> *) (m1 :: * -> *) a b r.
Monad m =>
(m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b
liftReader IO () -> IO ()
postGUIASync (TaffyIO () -> TaffyIO ()) -> TaffyIO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ do
  Priority -> String -> TaffyIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
DEBUG String
"Refreshing windows"
  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  MVar [(BarConfig, Window)]
windowsVar <- (Context -> MVar [(BarConfig, Window)])
-> ReaderT Context IO (MVar [(BarConfig, Window)])
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> MVar [(BarConfig, Window)]
existingWindows

  let rebuildWindows :: [(BarConfig, Window)] -> IO [(BarConfig, Window)]
rebuildWindows [(BarConfig, Window)]
currentWindows = (ReaderT Context IO [(BarConfig, Window)]
 -> Context -> IO [(BarConfig, Window)])
-> Context
-> ReaderT Context IO [(BarConfig, Window)]
-> IO [(BarConfig, Window)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO [(BarConfig, Window)]
-> Context -> IO [(BarConfig, Window)]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (ReaderT Context IO [(BarConfig, Window)]
 -> IO [(BarConfig, Window)])
-> ReaderT Context IO [(BarConfig, Window)]
-> IO [(BarConfig, Window)]
forall a b. (a -> b) -> a -> b
$
        do
          [BarConfig]
barConfigs <- ReaderT Context IO BarConfigGetter -> BarConfigGetter
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ReaderT Context IO BarConfigGetter -> BarConfigGetter)
-> ReaderT Context IO BarConfigGetter -> BarConfigGetter
forall a b. (a -> b) -> a -> b
$ (Context -> BarConfigGetter) -> ReaderT Context IO BarConfigGetter
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> BarConfigGetter
getBarConfigs

          let currentConfigs :: [BarConfig]
currentConfigs = ((BarConfig, Window) -> BarConfig)
-> [(BarConfig, Window)] -> [BarConfig]
forall a b. (a -> b) -> [a] -> [b]
map (BarConfig, Window) -> BarConfig
forall a b. Sel1 a b => a -> b
sel1 [(BarConfig, Window)]
currentWindows
              newConfs :: [BarConfig]
newConfs = (BarConfig -> Bool) -> [BarConfig] -> [BarConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter (BarConfig -> [BarConfig] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BarConfig]
currentConfigs) [BarConfig]
barConfigs
              ([(BarConfig, Window)]
remainingWindows, [(BarConfig, Window)]
removedWindows) =
                ((BarConfig, Window) -> Bool)
-> [(BarConfig, Window)]
-> ([(BarConfig, Window)], [(BarConfig, Window)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((BarConfig -> [BarConfig] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BarConfig]
barConfigs) (BarConfig -> Bool)
-> ((BarConfig, Window) -> BarConfig)
-> (BarConfig, Window)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BarConfig, Window) -> BarConfig
forall a b. Sel1 a b => a -> b
sel1) [(BarConfig, Window)]
currentWindows
              setPropertiesFromPair :: (BarConfig, Window) -> m ()
setPropertiesFromPair (BarConfig
barConf, Window
window) =
                StrutConfig -> Window -> m ()
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
StrutConfig -> Window -> m ()
setupStrutWindow (BarConfig -> StrutConfig
strutConfig BarConfig
barConf) Window
window

          [(BarConfig, Window)]
newWindowPairs <- IO [(BarConfig, Window)]
-> ReaderT Context IO [(BarConfig, Window)]
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [(BarConfig, Window)]
 -> ReaderT Context IO [(BarConfig, Window)])
-> IO [(BarConfig, Window)]
-> ReaderT Context IO [(BarConfig, Window)]
forall a b. (a -> b) -> a -> b
$ do
            Priority -> String -> IO ()
logIO Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"removedWindows: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                  [StrutConfig] -> String
forall a. Show a => a -> String
show ([StrutConfig] -> String) -> [StrutConfig] -> String
forall a b. (a -> b) -> a -> b
$ ((BarConfig, Window) -> StrutConfig)
-> [(BarConfig, Window)] -> [StrutConfig]
forall a b. (a -> b) -> [a] -> [b]
map (BarConfig -> StrutConfig
strutConfig (BarConfig -> StrutConfig)
-> ((BarConfig, Window) -> BarConfig)
-> (BarConfig, Window)
-> StrutConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BarConfig, Window) -> BarConfig
forall a b. Sel1 a b => a -> b
sel1) [(BarConfig, Window)]
removedWindows
            Priority -> String -> IO ()
logIO Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"remainingWindows: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                  [StrutConfig] -> String
forall a. Show a => a -> String
show ([StrutConfig] -> String) -> [StrutConfig] -> String
forall a b. (a -> b) -> a -> b
$ ((BarConfig, Window) -> StrutConfig)
-> [(BarConfig, Window)] -> [StrutConfig]
forall a b. (a -> b) -> [a] -> [b]
map (BarConfig -> StrutConfig
strutConfig (BarConfig -> StrutConfig)
-> ((BarConfig, Window) -> BarConfig)
-> (BarConfig, Window)
-> StrutConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BarConfig, Window) -> BarConfig
forall a b. Sel1 a b => a -> b
sel1) [(BarConfig, Window)]
remainingWindows
            Priority -> String -> IO ()
logIO Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"newWindows: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                  [StrutConfig] -> String
forall a. Show a => a -> String
show ([StrutConfig] -> String) -> [StrutConfig] -> String
forall a b. (a -> b) -> a -> b
$ (BarConfig -> StrutConfig) -> [BarConfig] -> [StrutConfig]
forall a b. (a -> b) -> [a] -> [b]
map BarConfig -> StrutConfig
strutConfig [BarConfig]
newConfs
            Priority -> String -> IO ()
logIO Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"barConfigs: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                  [StrutConfig] -> String
forall a. Show a => a -> String
show ([StrutConfig] -> String) -> [StrutConfig] -> String
forall a b. (a -> b) -> a -> b
$ (BarConfig -> StrutConfig) -> [BarConfig] -> [StrutConfig]
forall a b. (a -> b) -> [a] -> [b]
map BarConfig -> StrutConfig
strutConfig [BarConfig]
barConfigs

            Priority -> String -> IO ()
logIO Priority
DEBUG String
"Removing windows"
            ((BarConfig, Window) -> IO ()) -> [(BarConfig, Window)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Window -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (Window -> IO ())
-> ((BarConfig, Window) -> Window) -> (BarConfig, Window) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BarConfig, Window) -> Window
forall a b. Sel2 a b => a -> b
sel2) [(BarConfig, Window)]
removedWindows

            -- TODO: This should actually use the config that is provided from
            -- getBarConfigs so that the strut properties of the window can be
            -- altered.
            Priority -> String -> IO ()
logIO Priority
DEBUG String
"Updating strut properties for existing windows"
            ((BarConfig, Window) -> IO ()) -> [(BarConfig, Window)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BarConfig, Window) -> IO ()
forall {m :: * -> *}.
(MonadFail m, MonadIO m) =>
(BarConfig, Window) -> m ()
setPropertiesFromPair [(BarConfig, Window)]
remainingWindows

            Priority -> String -> IO ()
logIO Priority
DEBUG String
"Constructing new windows"
            (BarConfig -> IO (BarConfig, Window))
-> [BarConfig] -> IO [(BarConfig, Window)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((IO BarConfig, IO Window) -> IO (BarConfig, Window)
forall a b. SequenceT a b => a -> b
sequenceT ((IO BarConfig, IO Window) -> IO (BarConfig, Window))
-> (BarConfig -> (IO BarConfig, IO Window))
-> BarConfig
-> IO (BarConfig, Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return :: a -> IO a) (BarConfig -> IO BarConfig)
-> (BarConfig -> IO Window)
-> BarConfig
-> (IO BarConfig, IO Window)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Context -> BarConfig -> IO Window
buildBarWindow Context
ctx))
                 [BarConfig]
newConfs

          [(BarConfig, Window)] -> ReaderT Context IO [(BarConfig, Window)]
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(BarConfig, Window)] -> ReaderT Context IO [(BarConfig, Window)])
-> [(BarConfig, Window)]
-> ReaderT Context IO [(BarConfig, Window)]
forall a b. (a -> b) -> a -> b
$ [(BarConfig, Window)]
newWindowPairs [(BarConfig, Window)]
-> [(BarConfig, Window)] -> [(BarConfig, Window)]
forall a. [a] -> [a] -> [a]
++ [(BarConfig, Window)]
remainingWindows

  IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ()) -> IO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ MVar [(BarConfig, Window)]
-> ([(BarConfig, Window)] -> IO [(BarConfig, Window)]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar [(BarConfig, Window)]
windowsVar [(BarConfig, Window)] -> IO [(BarConfig, Window)]
rebuildWindows
  Priority -> String -> TaffyIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
logC Priority
DEBUG String
"Finished refreshing windows"
  () -> TaffyIO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Forcibly refresh taffybar windows, even if there are existing windows that
-- correspond to the uniques in the bar configs yielded by 'barConfigGetter'.
forceRefreshTaffyWindows :: TaffyIO ()
forceRefreshTaffyWindows :: TaffyIO ()
forceRefreshTaffyWindows =
  (Context -> MVar [(BarConfig, Window)])
-> ReaderT Context IO (MVar [(BarConfig, Window)])
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> MVar [(BarConfig, Window)]
existingWindows ReaderT Context IO (MVar [(BarConfig, Window)])
-> (MVar [(BarConfig, Window)] -> TaffyIO ()) -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ())
-> (MVar [(BarConfig, Window)] -> IO ())
-> MVar [(BarConfig, Window)]
-> TaffyIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar [(BarConfig, Window)]
 -> ([(BarConfig, Window)] -> IO [(BarConfig, Window)]) -> IO ())
-> ([(BarConfig, Window)] -> IO [(BarConfig, Window)])
-> MVar [(BarConfig, Window)]
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MVar [(BarConfig, Window)]
-> ([(BarConfig, Window)] -> IO [(BarConfig, Window)]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ [(BarConfig, Window)] -> IO [(BarConfig, Window)]
forall {b} {t :: * -> *} {m :: * -> *} {a} {a}.
(IsDescendantOf Widget b, Foldable t, MonadIO m, GObject b,
 Sel2 a b) =>
t a -> m [a]
deleteWindows TaffyIO () -> TaffyIO () -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> ReaderT Context IO b -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
       TaffyIO ()
refreshTaffyWindows
    where deleteWindows :: t a -> m [a]
deleteWindows t a
windows =
            do
              (a -> m ()) -> t a -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (b -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (b -> m ()) -> (a -> b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. Sel2 a b => a -> b
sel2) t a
windows
              [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b
asksContextVar :: forall r b. (r -> MVar b) -> ReaderT r IO b
asksContextVar r -> MVar b
getter = (r -> MVar b) -> ReaderT r IO (MVar b)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks r -> MVar b
getter ReaderT r IO (MVar b)
-> (MVar b -> ReaderT r IO b) -> ReaderT r IO b
forall a b.
ReaderT r IO a -> (a -> ReaderT r IO b) -> ReaderT r IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO b -> ReaderT r IO b
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO b -> ReaderT r IO b)
-> (MVar b -> IO b) -> MVar b -> ReaderT r IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar b -> IO b
forall a. MVar a -> IO a
MV.readMVar

-- | Run a function needing an X11 connection in 'TaffyIO'.
runX11 :: X11Property a -> TaffyIO a
runX11 :: forall a. X11Property a -> TaffyIO a
runX11 X11Property a
action =
  (Context -> MVar X11Context) -> ReaderT Context IO X11Context
forall r b. (r -> MVar b) -> ReaderT r IO b
asksContextVar Context -> MVar X11Context
x11ContextVar ReaderT Context IO X11Context
-> (X11Context -> ReaderT Context IO a) -> ReaderT Context IO a
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT Context IO a)
-> (X11Context -> IO a) -> X11Context -> ReaderT Context IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X11Property a -> X11Context -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT X11Property a
action

-- | Use 'runX11' together with 'postX11RequestSyncProp' on the provided
-- property. Return the provided default if 'Nothing' is returned
-- 'postX11RequestSyncProp'.
runX11Def :: a -> X11Property a -> TaffyIO a
runX11Def :: forall a. a -> X11Property a -> TaffyIO a
runX11Def a
dflt X11Property a
prop = X11Property a -> TaffyIO a
forall a. X11Property a -> TaffyIO a
runX11 (X11Property a -> TaffyIO a) -> X11Property a -> TaffyIO a
forall a b. (a -> b) -> a -> b
$ X11Property a -> a -> X11Property a
forall a. X11Property a -> a -> X11Property a
postX11RequestSyncProp X11Property a
prop a
dflt

runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a
runX11Context :: forall (m :: * -> *) a.
MonadIO m =>
Context -> a -> X11Property a -> m a
runX11Context Context
context a
dflt X11Property a
prop =
  IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT Context IO a -> Context -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> X11Property a -> ReaderT Context IO a
forall a. a -> X11Property a -> TaffyIO a
runX11Def a
dflt X11Property a
prop) Context
context

-- | Get a state value by type from the 'contextState' field of 'Context'.
getState :: forall t. Typeable t => Taffy IO (Maybe t)
getState :: forall t. Typeable t => Taffy IO (Maybe t)
getState = do
  Map TypeRep Value
stateMap <- (Context -> MVar (Map TypeRep Value))
-> ReaderT Context IO (Map TypeRep Value)
forall r b. (r -> MVar b) -> ReaderT r IO b
asksContextVar Context -> MVar (Map TypeRep Value)
contextState
  let maybeValue :: Maybe Value
maybeValue = TypeRep -> Map TypeRep Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t)) Map TypeRep Value
stateMap
  Maybe t -> Taffy IO (Maybe t)
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe t -> Taffy IO (Maybe t)) -> Maybe t -> Taffy IO (Maybe t)
forall a b. (a -> b) -> a -> b
$ Maybe Value
maybeValue Maybe Value -> (Value -> Maybe t) -> Maybe t
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe t
forall t. Typeable t => Value -> Maybe t
fromValue

-- | Like "putState", but avoids aquiring a lock if the value is already in the
-- map.
getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t
getStateDefault :: forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault Taffy IO t
defaultGetter =
  Taffy IO (Maybe t)
forall t. Typeable t => Taffy IO (Maybe t)
getState Taffy IO (Maybe t) -> (Maybe t -> Taffy IO t) -> Taffy IO t
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Taffy IO t -> (t -> Taffy IO t) -> Maybe t -> Taffy IO t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Taffy IO t -> Taffy IO t
forall t. Typeable t => Taffy IO t -> Taffy IO t
putState Taffy IO t
defaultGetter) t -> Taffy IO t
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Get a value of the type returned by the provided action from the the
-- current taffybar state, unless the state does not exist, in which case the
-- action will be called to populate the state map.
putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t
putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t
putState Taffy IO t
getValue = do
  MVar (Map TypeRep Value)
contextVar <- (Context -> MVar (Map TypeRep Value))
-> ReaderT Context IO (MVar (Map TypeRep Value))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> MVar (Map TypeRep Value)
contextState
  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO t -> Taffy IO t
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO t -> Taffy IO t) -> IO t -> Taffy IO t
forall a b. (a -> b) -> a -> b
$ MVar (Map TypeRep Value)
-> (Map TypeRep Value -> IO (Map TypeRep Value, t)) -> IO t
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar (Map TypeRep Value)
contextVar ((Map TypeRep Value -> IO (Map TypeRep Value, t)) -> IO t)
-> (Map TypeRep Value -> IO (Map TypeRep Value, t)) -> IO t
forall a b. (a -> b) -> a -> b
$ \Map TypeRep Value
contextStateMap ->
    let theType :: TypeRep
theType = Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t)
        currentValue :: Maybe Value
currentValue = TypeRep -> Map TypeRep Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TypeRep
theType Map TypeRep Value
contextStateMap
        insertAndReturn :: t -> (Map TypeRep Value, t)
insertAndReturn t
value =
          (TypeRep -> Value -> Map TypeRep Value -> Map TypeRep Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TypeRep
theType (t -> Value
forall t. Typeable t => t -> Value
Value t
value) Map TypeRep Value
contextStateMap, t
value)
    in (ReaderT Context IO (Map TypeRep Value, t)
 -> Context -> IO (Map TypeRep Value, t))
-> Context
-> ReaderT Context IO (Map TypeRep Value, t)
-> IO (Map TypeRep Value, t)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO (Map TypeRep Value, t)
-> Context -> IO (Map TypeRep Value, t)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (ReaderT Context IO (Map TypeRep Value, t)
 -> IO (Map TypeRep Value, t))
-> ReaderT Context IO (Map TypeRep Value, t)
-> IO (Map TypeRep Value, t)
forall a b. (a -> b) -> a -> b
$  ReaderT Context IO (Map TypeRep Value, t)
-> (t -> ReaderT Context IO (Map TypeRep Value, t))
-> Maybe t
-> ReaderT Context IO (Map TypeRep Value, t)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
         (t -> (Map TypeRep Value, t)
insertAndReturn  (t -> (Map TypeRep Value, t))
-> Taffy IO t -> ReaderT Context IO (Map TypeRep Value, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Taffy IO t
getValue)
         ((Map TypeRep Value, t) -> ReaderT Context IO (Map TypeRep Value, t)
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Map TypeRep Value, t)
 -> ReaderT Context IO (Map TypeRep Value, t))
-> (t -> (Map TypeRep Value, t))
-> t
-> ReaderT Context IO (Map TypeRep Value, t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map TypeRep Value
contextStateMap,))
         (Maybe Value
currentValue Maybe Value -> (Value -> Maybe t) -> Maybe t
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe t
forall t. Typeable t => Value -> Maybe t
fromValue)

-- | A version of "forkIO" in "TaffyIO".
taffyFork :: ReaderT r IO () -> ReaderT r IO ()
taffyFork :: forall r. ReaderT r IO () -> ReaderT r IO ()
taffyFork = ReaderT r IO ThreadId -> ReaderT r IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT r IO ThreadId -> ReaderT r IO ())
-> (ReaderT r IO () -> ReaderT r IO ThreadId)
-> ReaderT r IO ()
-> ReaderT r IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> IO ThreadId) -> ReaderT r IO () -> ReaderT r IO ThreadId
forall (m :: * -> *) (m1 :: * -> *) a b r.
Monad m =>
(m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b
liftReader IO () -> IO ThreadId
forkIO

startX11EventHandler :: Taffy IO ()
startX11EventHandler :: TaffyIO ()
startX11EventHandler = TaffyIO () -> TaffyIO ()
forall r. ReaderT r IO () -> ReaderT r IO ()
taffyFork (TaffyIO () -> TaffyIO ()) -> TaffyIO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ do
  Context
c <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  -- XXX: The event loop needs its own X11Context to separately handle
  -- communications from the X server. We deliberately avoid using the context
  -- from x11ContextVar here.
  IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ()) -> IO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ X11Property () -> IO ()
forall a. X11Property a -> IO a
withDefaultCtx (X11Property () -> IO ()) -> X11Property () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Event -> IO ()) -> X11Property ()
eventLoop
         (\Event
e -> TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Event -> TaffyIO ()
handleX11Event Event
e) Context
c)

-- | Remove the listener associated with the provided "Unique" from the
-- collection of listeners.
unsubscribe :: Unique -> Taffy IO ()
unsubscribe :: Unique -> TaffyIO ()
unsubscribe Unique
identifier = do
  MVar SubscriptionList
listenersVar <- (Context -> MVar SubscriptionList)
-> ReaderT Context IO (MVar SubscriptionList)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> MVar SubscriptionList
listeners
  IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ()) -> IO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ MVar SubscriptionList
-> (SubscriptionList -> IO SubscriptionList) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar SubscriptionList
listenersVar ((SubscriptionList -> IO SubscriptionList) -> IO ())
-> (SubscriptionList -> IO SubscriptionList) -> IO ()
forall a b. (a -> b) -> a -> b
$ SubscriptionList -> IO SubscriptionList
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SubscriptionList -> IO SubscriptionList)
-> (SubscriptionList -> SubscriptionList)
-> SubscriptionList
-> IO SubscriptionList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, Event -> TaffyIO ()) -> Bool)
-> SubscriptionList -> SubscriptionList
forall a. (a -> Bool) -> [a] -> [a]
filter ((Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
identifier) (Unique -> Bool)
-> ((Unique, Event -> TaffyIO ()) -> Unique)
-> (Unique, Event -> TaffyIO ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique, Event -> TaffyIO ()) -> Unique
forall a b. (a, b) -> a
fst)

-- | Subscribe to all incoming events on the X11 event loop. The returned
-- "Unique" value can be used to unregister the listener using "unsuscribe".
subscribeToAll :: Listener -> Taffy IO Unique
subscribeToAll :: (Event -> TaffyIO ()) -> Taffy IO Unique
subscribeToAll Event -> TaffyIO ()
listener = do
  Unique
identifier <- IO Unique -> Taffy IO Unique
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Unique
newUnique
  MVar SubscriptionList
listenersVar <- (Context -> MVar SubscriptionList)
-> ReaderT Context IO (MVar SubscriptionList)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> MVar SubscriptionList
listeners
  let
    -- XXX: This type annotation probably has something to do with the warnings
    -- that occur without MonoLocalBinds, but it still seems to be necessary
    addListener :: SubscriptionList -> SubscriptionList
    addListener :: SubscriptionList -> SubscriptionList
addListener = ((Unique
identifier, Event -> TaffyIO ()
listener)(Unique, Event -> TaffyIO ())
-> SubscriptionList -> SubscriptionList
forall a. a -> [a] -> [a]
:)
  IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ()) -> IO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ MVar SubscriptionList
-> (SubscriptionList -> IO SubscriptionList) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar SubscriptionList
listenersVar (SubscriptionList -> IO SubscriptionList
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SubscriptionList -> IO SubscriptionList)
-> (SubscriptionList -> SubscriptionList)
-> SubscriptionList
-> IO SubscriptionList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubscriptionList -> SubscriptionList
addListener)
  Unique -> Taffy IO Unique
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
identifier

-- | Subscribe to X11 "PropertyEvent"s where the property changed is in the
-- provided list.
subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents :: [String] -> (Event -> TaffyIO ()) -> Taffy IO Unique
subscribeToPropertyEvents [String]
eventNames Event -> TaffyIO ()
listener = do
  [Atom]
eventAtoms <- (String -> ReaderT Context IO Atom)
-> [String] -> ReaderT Context IO [Atom]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (X11Property Atom -> ReaderT Context IO Atom
forall a. X11Property a -> TaffyIO a
runX11 (X11Property Atom -> ReaderT Context IO Atom)
-> (String -> X11Property Atom)
-> String
-> ReaderT Context IO Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> X11Property Atom
getAtom) [String]
eventNames
  let filteredListener :: Event -> TaffyIO ()
filteredListener event :: Event
event@PropertyEvent { ev_atom :: Event -> Atom
ev_atom = Atom
atom } =
        Bool -> TaffyIO () -> TaffyIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
atom Atom -> [Atom] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Atom]
eventAtoms) (TaffyIO () -> TaffyIO ()) -> TaffyIO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$
             TaffyIO () -> (SomeException -> TaffyIO ()) -> TaffyIO ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny (Event -> TaffyIO ()
listener Event
event) (TaffyIO () -> SomeException -> TaffyIO ()
forall a b. a -> b -> a
const (TaffyIO () -> SomeException -> TaffyIO ())
-> TaffyIO () -> SomeException -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ () -> TaffyIO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
      filteredListener Event
_ = () -> TaffyIO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (Event -> TaffyIO ()) -> Taffy IO Unique
subscribeToAll Event -> TaffyIO ()
filteredListener

handleX11Event :: Event -> Taffy IO ()
handleX11Event :: Event -> TaffyIO ()
handleX11Event Event
event =
  (Context -> MVar SubscriptionList)
-> ReaderT Context IO SubscriptionList
forall r b. (r -> MVar b) -> ReaderT r IO b
asksContextVar Context -> MVar SubscriptionList
listeners ReaderT Context IO SubscriptionList
-> (SubscriptionList -> TaffyIO ()) -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Unique, Event -> TaffyIO ()) -> TaffyIO ())
-> SubscriptionList -> TaffyIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Unique, Event -> TaffyIO ()) -> TaffyIO ()
applyListener
  where applyListener :: (Unique, Listener) -> Taffy IO ()
        applyListener :: (Unique, Event -> TaffyIO ()) -> TaffyIO ()
applyListener (Unique
_, Event -> TaffyIO ()
listener) = TaffyIO () -> TaffyIO ()
forall r. ReaderT r IO () -> ReaderT r IO ()
taffyFork (TaffyIO () -> TaffyIO ()) -> TaffyIO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ Event -> TaffyIO ()
listener Event
event