{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ImpredicativeTypes #-}
module System.Taffybar.Context 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.GI.Base.ManagedPtr (unsafeCastTo)
import Data.Int
import Data.List
import qualified Data.Map as M
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 :: Priority -> String -> m ()
logC Priority
p = IO () -> m ()
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
type Taffy m v = MonadIO m => ReaderT Context m v
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 :: 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
data BarConfig = BarConfig
{ BarConfig -> StrutConfig
strutConfig :: StrutConfig
, BarConfig -> Int32
widgetSpacing :: Int32
, BarConfig -> [TaffyIO Widget]
startWidgets :: [TaffyIO Gtk.Widget]
, BarConfig -> [TaffyIO Widget]
centerWidgets :: [TaffyIO Gtk.Widget]
, BarConfig -> [TaffyIO Widget]
endWidgets :: [TaffyIO Gtk.Widget]
, 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]
data TaffybarConfig = TaffybarConfig
{ TaffybarConfig -> Maybe Client
dbusClientParam :: Maybe DBus.Client
, TaffybarConfig -> TaffyIO ()
startupHook :: TaffyIO ()
, TaffybarConfig -> BarConfigGetter
getBarConfigsParam :: BarConfigGetter
, TaffybarConfig -> Maybe String
cssPath :: Maybe FilePath
, TaffybarConfig -> Maybe String
errorMsg :: Maybe String
}
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TaffyIO ()
hook }
defaultTaffybarConfig :: TaffybarConfig
defaultTaffybarConfig :: TaffybarConfig
defaultTaffybarConfig = TaffybarConfig :: Maybe Client
-> TaffyIO ()
-> BarConfigGetter
-> Maybe String
-> Maybe String
-> TaffybarConfig
TaffybarConfig
{ dbusClientParam :: Maybe Client
dbusClientParam = Maybe Client
forall a. Maybe a
Nothing
, startupHook :: TaffyIO ()
startupHook = () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, getBarConfigsParam :: BarConfigGetter
getBarConfigsParam = [BarConfig] -> BarConfigGetter
forall (m :: * -> *) a. Monad m => a -> m a
return []
, cssPath :: Maybe String
cssPath = Maybe String
forall a. Maybe a
Nothing
, errorMsg :: Maybe String
errorMsg = Maybe String
forall a. Maybe a
Nothing
}
data Context = Context
{
Context -> MVar X11Context
x11ContextVar :: MV.MVar X11Context
, Context -> MVar SubscriptionList
listeners :: MV.MVar SubscriptionList
, Context -> MVar (Map TypeRep Value)
contextState :: MV.MVar (M.Map TypeRep Value)
, Context -> MVar [(BarConfig, Window)]
existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]
, Context -> Client
sessionDBusClient :: DBus.Client
, Context -> Client
systemDBusClient :: DBus.Client
, Context -> BarConfigGetter
getBarConfigs :: BarConfigGetter
, Context -> Maybe BarConfig
contextBarConfig :: Maybe BarConfig
}
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 (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 (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 :: MVar X11Context
-> MVar SubscriptionList
-> MVar (Map TypeRep Value)
-> MVar [(BarConfig, Window)]
-> Client
-> Client
-> BarConfigGetter
-> Maybe BarConfig
-> 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 SignalHandlerId
_ <- MaybeT IO SignalHandlerId -> IO (Maybe SignalHandlerId)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO SignalHandlerId -> IO (Maybe SignalHandlerId))
-> MaybeT IO SignalHandlerId -> IO (Maybe SignalHandlerId)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(IO Screen -> MaybeT IO Screen
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 SignalHandlerId)
-> MaybeT IO SignalHandlerId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(IO SignalHandlerId -> MaybeT IO SignalHandlerId
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO SignalHandlerId -> MaybeT IO SignalHandlerId)
-> (Screen -> IO SignalHandlerId)
-> Screen
-> MaybeT IO SignalHandlerId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen -> IO () -> IO SignalHandlerId)
-> IO () -> Screen -> IO SignalHandlerId
forall a b c. (a -> b -> c) -> b -> a -> c
flip Screen -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsScreen a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
GI.Gdk.afterScreenMonitorsChanged
(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 ()
Taffy IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return Context
context
buildEmptyContext :: IO Context
buildEmptyContext :: IO Context
buildEmptyContext = TaffybarConfig -> IO Context
buildContext TaffybarConfig
defaultTaffybarConfig
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 -> 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 :: (Widget -> IO ()) -> TaffyIO Widget -> IO ()
addWidgetWith Widget -> IO ()
widgetAdd 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Widget -> IO ()
widgetAdd
addToStart :: Widget -> IO ()
addToStart Widget
widget = 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 :: Widget -> IO ()
addToEnd Widget
widget = 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 :: Widget -> IO ()
addToCenter Widget
widget = 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"
(TaffyIO Widget -> IO ()) -> [TaffyIO Widget] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Widget -> IO ()) -> TaffyIO Widget -> IO ()
addWidgetWith Widget -> IO ()
addToStart) (BarConfig -> [TaffyIO Widget]
startWidgets BarConfig
barConfig)
Priority -> String -> IO ()
logIO Priority
DEBUG String
"Building center widgets"
(TaffyIO Widget -> IO ()) -> [TaffyIO Widget] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Widget -> IO ()) -> TaffyIO Widget -> IO ()
addWidgetWith Widget -> IO ()
addToCenter) (BarConfig -> [TaffyIO Widget]
centerWidgets BarConfig
barConfig)
Priority -> String -> IO ()
logIO Priority
DEBUG String
"Building end widgets"
(TaffyIO Widget -> IO ()) -> [TaffyIO Widget] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Widget -> IO ()) -> TaffyIO Widget -> IO ()
addWidgetWith Widget -> IO ()
addToEnd) (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
SignalHandlerId
xid <- X11Window -> MaybeT (ReaderT X11Context IO) SignalHandlerId
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsX11Window a) =>
a -> m SignalHandlerId
GdkX11.x11WindowGetXid (X11Window -> MaybeT (ReaderT X11Context IO) SignalHandlerId)
-> MaybeT (ReaderT X11Context IO) X11Window
-> MaybeT (ReaderT X11Context IO) SignalHandlerId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO X11Window -> MaybeT (ReaderT X11Context IO) X11Window
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
$ SignalHandlerId -> String
forall a. Show a => a -> String
show SignalHandlerId
xid
X11Property () -> MaybeT (ReaderT X11Context IO) ()
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
$ X11Window -> X11Property ()
doLowerWindow (SignalHandlerId -> X11Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral SignalHandlerId
xid)
Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
window
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 (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 (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
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)
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
. ((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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> TaffyIO ()
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 a (m :: * -> *) (t :: * -> *) a a.
(IsDescendantOf Widget a, Foldable t, MonadIO m, GObject a,
Sel2 a a) =>
t a -> m [a]
deleteWindows TaffyIO () -> TaffyIO () -> TaffyIO ()
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_ (a -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (a -> m ()) -> (a -> a) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a b. Sel2 a b => a -> b
sel2) t a
windows
[a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b
asksContextVar :: (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO b -> ReaderT r IO b
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
runX11 :: X11Property a -> TaffyIO a
runX11 :: 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 -> TaffyIO a) -> TaffyIO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> TaffyIO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> TaffyIO a)
-> (X11Context -> IO a) -> X11Context -> TaffyIO 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
runX11Def :: a -> X11Property a -> TaffyIO a
runX11Def :: a -> X11Property a -> TaffyIO a
runX11Def a
def 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
def
runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a
runX11Context :: Context -> a -> X11Property a -> m a
runX11Context Context
context a
def X11Property a
prop =
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
def X11Property a
prop) Context
context
getState :: forall t. Typeable t => Taffy IO (Maybe t)
getState :: ReaderT Context 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 (t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (t
forall a. HasCallStack => a
undefined :: t)) Map TypeRep Value
stateMap
Maybe t -> ReaderT Context IO (Maybe t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe t -> ReaderT Context IO (Maybe t))
-> Maybe t -> ReaderT Context IO (Maybe t)
forall a b. (a -> b) -> a -> b
$ Maybe Value
maybeValue Maybe Value -> (Value -> Maybe t) -> Maybe t
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe t
forall t. Typeable t => Value -> Maybe t
fromValue
getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t
getStateDefault :: Taffy IO t -> Taffy IO t
getStateDefault Taffy IO t
defaultGetter =
ReaderT Context IO (Maybe t)
forall t. Typeable t => Taffy IO (Maybe t)
getState ReaderT Context IO (Maybe t)
-> (Maybe t -> ReaderT Context IO t) -> ReaderT Context IO t
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Context IO t
-> (t -> ReaderT Context IO t) -> Maybe t -> ReaderT Context 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 -> ReaderT Context IO t
forall (m :: * -> *) a. Monad m => a -> m a
return
putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t
putState :: 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 -> ReaderT Context IO t
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO t -> ReaderT Context IO t) -> IO t -> ReaderT Context 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 = t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (t
forall a. HasCallStack => a
undefined :: 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))
-> ReaderT Context IO t
-> ReaderT Context IO (Map TypeRep Value, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context IO t
Taffy IO t
getValue)
((Map TypeRep Value, t) -> ReaderT Context IO (Map TypeRep Value, t)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe t
forall t. Typeable t => Value -> Maybe t
fromValue)
taffyFork :: ReaderT r IO () -> ReaderT r IO ()
taffyFork :: 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
IO () -> TaffyIO ()
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 -> Taffy IO ()
handleX11Event Event
e) Context
c)
unsubscribe :: Unique -> Taffy IO ()
unsubscribe :: Unique -> Taffy IO ()
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 (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 (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 -> Taffy IO ()) -> 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 -> Taffy IO ()) -> Unique)
-> (Unique, Event -> Taffy IO ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique, Event -> Taffy IO ()) -> Unique
forall a b. (a, b) -> a
fst)
subscribeToAll :: Listener -> Taffy IO Unique
subscribeToAll :: (Event -> Taffy IO ()) -> Taffy IO Unique
subscribeToAll Event -> Taffy IO ()
listener = do
Unique
identifier <- IO Unique -> ReaderT Context IO Unique
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
addListener :: SubscriptionList -> SubscriptionList
addListener :: SubscriptionList -> SubscriptionList
addListener = ((Unique
identifier, Event -> Taffy IO ()
listener)(Unique, Event -> Taffy IO ())
-> SubscriptionList -> SubscriptionList
forall a. a -> [a] -> [a]
:)
IO () -> TaffyIO ()
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 (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 -> ReaderT Context IO Unique
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
identifier
subscribeToPropertyEvents :: [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents :: [String] -> (Event -> Taffy IO ()) -> Taffy IO Unique
subscribeToPropertyEvents [String]
eventNames Event -> Taffy IO ()
listener = do
[X11Window]
eventAtoms <- (String -> ReaderT Context IO X11Window)
-> [String] -> ReaderT Context IO [X11Window]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (X11Property X11Window -> ReaderT Context IO X11Window
forall a. X11Property a -> TaffyIO a
runX11 (X11Property X11Window -> ReaderT Context IO X11Window)
-> (String -> X11Property X11Window)
-> String
-> ReaderT Context IO X11Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> X11Property X11Window
getAtom) [String]
eventNames
let filteredListener :: Event -> TaffyIO ()
filteredListener event :: Event
event@PropertyEvent { ev_atom :: Event -> X11Window
ev_atom = X11Window
atom } =
Bool -> TaffyIO () -> TaffyIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (X11Window
atom X11Window -> [X11Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [X11Window]
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 -> Taffy IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return ())
filteredListener Event
_ = () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Event -> Taffy IO ()) -> Taffy IO Unique
subscribeToAll Event -> TaffyIO ()
Event -> Taffy IO ()
filteredListener
handleX11Event :: Event -> Taffy IO ()
handleX11Event :: Event -> Taffy IO ()
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Unique, Event -> Taffy IO ()) -> TaffyIO ())
-> SubscriptionList -> TaffyIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Unique, Event -> Taffy IO ()) -> TaffyIO ()
(Unique, Event -> Taffy IO ()) -> Taffy IO ()
applyListener
where applyListener :: (Unique, Listener) -> Taffy IO ()
applyListener :: (Unique, Event -> Taffy IO ()) -> Taffy IO ()
applyListener (Unique
_, Event -> Taffy IO ()
listener) = TaffyIO () -> TaffyIO ()
forall r. ReaderT r IO () -> ReaderT r IO ()
taffyFork (TaffyIO () -> TaffyIO ()) -> TaffyIO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ Event -> Taffy IO ()
listener Event
event