{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings #-}
module System.Taffybar.Widget.Workspaces where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent
import qualified Control.Concurrent.MVar as MV
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.RateLimit
import qualified Data.Foldable as F
import Data.GI.Base.ManagedPtr (unsafeCastTo)
import Data.Int
import Data.List (intersect, sortBy, (\\))
import qualified Data.Map as M
import Data.Maybe
import qualified Data.MultiMap as MM
import Data.Ord
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time.Units
import Data.Tuple.Select
import Data.Tuple.Sequence
import qualified GI.Gdk.Enums as Gdk
import qualified GI.Gdk.Structs.EventScroll as Gdk
import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import Prelude
import StatusNotifier.Tray (scalePixbufToSize)
import System.Log.Logger
import System.Taffybar.Context
import System.Taffybar.Information.EWMHDesktopInfo
import System.Taffybar.Information.SafeX11
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar.Util
import System.Taffybar.Widget.Decorators
import System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage)
import System.Taffybar.Widget.Util
import System.Taffybar.WindowIcon
import Text.Printf
data WorkspaceState
= Active
| Visible
| Hidden
| Empty
| Urgent
deriving (Int -> WorkspaceState -> ShowS
[WorkspaceState] -> ShowS
WorkspaceState -> String
(Int -> WorkspaceState -> ShowS)
-> (WorkspaceState -> String)
-> ([WorkspaceState] -> ShowS)
-> Show WorkspaceState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceState] -> ShowS
$cshowList :: [WorkspaceState] -> ShowS
show :: WorkspaceState -> String
$cshow :: WorkspaceState -> String
showsPrec :: Int -> WorkspaceState -> ShowS
$cshowsPrec :: Int -> WorkspaceState -> ShowS
Show, WorkspaceState -> WorkspaceState -> Bool
(WorkspaceState -> WorkspaceState -> Bool)
-> (WorkspaceState -> WorkspaceState -> Bool) -> Eq WorkspaceState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorkspaceState -> WorkspaceState -> Bool
$c/= :: WorkspaceState -> WorkspaceState -> Bool
== :: WorkspaceState -> WorkspaceState -> Bool
$c== :: WorkspaceState -> WorkspaceState -> Bool
Eq)
getCSSClass :: (Show s) => s -> T.Text
getCSSClass :: s -> Text
getCSSClass = Text -> Text
T.toLower (Text -> Text) -> (s -> Text) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (s -> String) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Show a => a -> String
show
cssWorkspaceStates :: [T.Text]
cssWorkspaceStates :: [Text]
cssWorkspaceStates = (WorkspaceState -> Text) -> [WorkspaceState] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map WorkspaceState -> Text
forall s. Show s => s -> Text
getCSSClass [WorkspaceState
Active, WorkspaceState
Visible, WorkspaceState
Hidden, WorkspaceState
Empty, WorkspaceState
Urgent]
data WindowData = WindowData
{ WindowData -> X11Window
windowId :: X11Window
, WindowData -> String
windowTitle :: String
, WindowData -> String
windowClass :: String
, WindowData -> Bool
windowUrgent :: Bool
, WindowData -> Bool
windowActive :: Bool
, WindowData -> Bool
windowMinimized :: Bool
} deriving (Int -> WindowData -> ShowS
[WindowData] -> ShowS
WindowData -> String
(Int -> WindowData -> ShowS)
-> (WindowData -> String)
-> ([WindowData] -> ShowS)
-> Show WindowData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WindowData] -> ShowS
$cshowList :: [WindowData] -> ShowS
show :: WindowData -> String
$cshow :: WindowData -> String
showsPrec :: Int -> WindowData -> ShowS
$cshowsPrec :: Int -> WindowData -> ShowS
Show, WindowData -> WindowData -> Bool
(WindowData -> WindowData -> Bool)
-> (WindowData -> WindowData -> Bool) -> Eq WindowData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WindowData -> WindowData -> Bool
$c/= :: WindowData -> WindowData -> Bool
== :: WindowData -> WindowData -> Bool
$c== :: WindowData -> WindowData -> Bool
Eq)
data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]
data Workspace = Workspace
{ Workspace -> WorkspaceId
workspaceIdx :: WorkspaceId
, Workspace -> String
workspaceName :: String
, Workspace -> WorkspaceState
workspaceState :: WorkspaceState
, Workspace -> [WindowData]
windows :: [WindowData]
} deriving (Int -> Workspace -> ShowS
[Workspace] -> ShowS
Workspace -> String
(Int -> Workspace -> ShowS)
-> (Workspace -> String)
-> ([Workspace] -> ShowS)
-> Show Workspace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Workspace] -> ShowS
$cshowList :: [Workspace] -> ShowS
show :: Workspace -> String
$cshow :: Workspace -> String
showsPrec :: Int -> Workspace -> ShowS
$cshowsPrec :: Int -> Workspace -> ShowS
Show, Workspace -> Workspace -> Bool
(Workspace -> Workspace -> Bool)
-> (Workspace -> Workspace -> Bool) -> Eq Workspace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Workspace -> Workspace -> Bool
$c/= :: Workspace -> Workspace -> Bool
== :: Workspace -> Workspace -> Bool
$c== :: Workspace -> Workspace -> Bool
Eq)
data WorkspacesContext = WorkspacesContext
{ WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar :: MV.MVar (M.Map WorkspaceId WWC)
, WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar :: MV.MVar (M.Map WorkspaceId Workspace)
, WorkspacesContext -> Box
workspacesWidget :: Gtk.Box
, WorkspacesContext -> WorkspacesConfig
workspacesConfig :: WorkspacesConfig
, WorkspacesContext -> Context
taffyContext :: Context
}
type WorkspacesIO a = ReaderT WorkspacesContext IO a
liftContext :: TaffyIO a -> WorkspacesIO a
liftContext :: TaffyIO a -> WorkspacesIO a
liftContext action :: TaffyIO a
action = (WorkspacesContext -> Context)
-> ReaderT WorkspacesContext IO Context
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> Context
taffyContext ReaderT WorkspacesContext IO Context
-> (Context -> WorkspacesIO a) -> WorkspacesIO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> WorkspacesIO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> WorkspacesIO a)
-> (Context -> IO a) -> Context -> WorkspacesIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaffyIO a -> Context -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TaffyIO a
action
liftX11Def :: a -> X11Property a -> WorkspacesIO a
liftX11Def :: a -> X11Property a -> WorkspacesIO a
liftX11Def def :: a
def prop :: X11Property a
prop = TaffyIO a -> WorkspacesIO a
forall a. TaffyIO a -> WorkspacesIO a
liftContext (TaffyIO a -> WorkspacesIO a) -> TaffyIO a -> WorkspacesIO a
forall a b. (a -> b) -> a -> b
$ a -> X11Property a -> TaffyIO a
forall a. a -> X11Property a -> TaffyIO a
runX11Def a
def X11Property a
prop
setWorkspaceWidgetStatusClass ::
(MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m ()
setWorkspaceWidgetStatusClass :: Workspace -> a -> m ()
setWorkspaceWidgetStatusClass workspace :: Workspace
workspace widget :: a
widget =
a -> [Text] -> [Text] -> m ()
forall (t1 :: * -> *) (t :: * -> *) a (m :: * -> *).
(Foldable t1, Foldable t, IsWidget a, MonadIO m) =>
a -> t1 Text -> t Text -> m ()
updateWidgetClasses
a
widget
[WorkspaceState -> Text
forall s. Show s => s -> Text
getCSSClass (WorkspaceState -> Text) -> WorkspaceState -> Text
forall a b. (a -> b) -> a -> b
$ Workspace -> WorkspaceState
workspaceState Workspace
workspace]
[Text]
cssWorkspaceStates
updateWidgetClasses ::
(Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m)
=> a
-> t1 T.Text
-> t T.Text
-> m ()
updateWidgetClasses :: a -> t1 Text -> t Text -> m ()
updateWidgetClasses widget :: a
widget toAdd :: t1 Text
toAdd toRemove :: t Text
toRemove = do
StyleContext
context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
let hasClass :: Text -> m Bool
hasClass = StyleContext -> Text -> m Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m Bool
Gtk.styleContextHasClass StyleContext
context
addIfMissing :: Text -> m ()
addIfMissing klass :: Text
klass =
Text -> m Bool
hasClass Text
klass m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextAddClass StyleContext
context Text
klass) (Bool -> m ()) -> (Bool -> Bool) -> Bool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not
removeIfPresent :: Text -> m ()
removeIfPresent klass :: Text
klass = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
klass Text -> t1 Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t1 Text
toAdd) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
Text -> m Bool
hasClass Text
klass m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextRemoveClass StyleContext
context Text
klass)
(Text -> m ()) -> t Text -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
removeIfPresent t Text
toRemove
(Text -> m ()) -> t1 Text -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
addIfMissing t1 Text
toAdd
class WorkspaceWidgetController wc where
getWidget :: wc -> WorkspacesIO Gtk.Widget
updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc
updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc
updateWidgetX11 cont :: wc
cont _ = wc -> WorkspacesIO wc
forall (m :: * -> *) a. Monad m => a -> m a
return wc
cont
data WWC = forall a. WorkspaceWidgetController a => WWC a
instance WorkspaceWidgetController WWC where
getWidget :: WWC -> WorkspacesIO Widget
getWidget (WWC wc :: a
wc) = a -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget a
wc
updateWidget :: WWC -> WidgetUpdate -> WorkspacesIO WWC
updateWidget (WWC wc :: a
wc) update :: WidgetUpdate
update = a -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (a -> WWC) -> ReaderT WorkspacesContext IO a -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> WidgetUpdate -> ReaderT WorkspacesContext IO a
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget a
wc WidgetUpdate
update
updateWidgetX11 :: WWC -> WidgetUpdate -> WorkspacesIO WWC
updateWidgetX11 (WWC wc :: a
wc) update :: WidgetUpdate
update = a -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (a -> WWC) -> ReaderT WorkspacesContext IO a -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> WidgetUpdate -> ReaderT WorkspacesContext IO a
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidgetX11 a
wc WidgetUpdate
update
type ControllerConstructor = Workspace -> WorkspacesIO WWC
type ParentControllerConstructor =
ControllerConstructor -> ControllerConstructor
type WindowIconPixbufGetter =
Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)
data WorkspacesConfig =
WorkspacesConfig
{ WorkspacesConfig -> ControllerConstructor
widgetBuilder :: ControllerConstructor
, WorkspacesConfig -> Int
widgetGap :: Int
, WorkspacesConfig -> Int
underlineHeight :: Int
, WorkspacesConfig -> Int
underlinePadding :: Int
, WorkspacesConfig -> Maybe Int
maxIcons :: Maybe Int
, WorkspacesConfig -> Int
minIcons :: Int
, WorkspacesConfig -> WindowIconPixbufGetter
getWindowIconPixbuf :: WindowIconPixbufGetter
, WorkspacesConfig -> Workspace -> WorkspacesIO String
labelSetter :: Workspace -> WorkspacesIO String
, WorkspacesConfig -> Workspace -> Bool
showWorkspaceFn :: Workspace -> Bool
, WorkspacesConfig -> Int
borderWidth :: Int
, WorkspacesConfig -> [String]
updateEvents :: [String]
, WorkspacesConfig -> Integer
updateRateLimitMicroseconds :: Integer
, WorkspacesConfig -> [WindowData] -> WorkspacesIO [WindowData]
iconSort :: [WindowData] -> WorkspacesIO [WindowData]
, WorkspacesConfig -> Bool
urgentWorkspaceState :: Bool
}
defaultWorkspacesConfig :: WorkspacesConfig
defaultWorkspacesConfig :: WorkspacesConfig
defaultWorkspacesConfig =
WorkspacesConfig :: ControllerConstructor
-> Int
-> Int
-> Int
-> Maybe Int
-> Int
-> WindowIconPixbufGetter
-> (Workspace -> WorkspacesIO String)
-> (Workspace -> Bool)
-> Int
-> [String]
-> Integer
-> ([WindowData] -> WorkspacesIO [WindowData])
-> Bool
-> WorkspacesConfig
WorkspacesConfig
{ widgetBuilder :: ControllerConstructor
widgetBuilder = ParentControllerConstructor
buildButtonController ControllerConstructor
defaultBuildContentsController
, widgetGap :: Int
widgetGap = 0
, underlineHeight :: Int
underlineHeight = 4
, underlinePadding :: Int
underlinePadding = 1
, maxIcons :: Maybe Int
maxIcons = Maybe Int
forall a. Maybe a
Nothing
, minIcons :: Int
minIcons = 0
, getWindowIconPixbuf :: WindowIconPixbufGetter
getWindowIconPixbuf = WindowIconPixbufGetter
defaultGetWindowIconPixbuf
, labelSetter :: Workspace -> WorkspacesIO String
labelSetter = String -> WorkspacesIO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> WorkspacesIO String)
-> (Workspace -> String) -> Workspace -> WorkspacesIO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace -> String
workspaceName
, showWorkspaceFn :: Workspace -> Bool
showWorkspaceFn = Bool -> Workspace -> Bool
forall a b. a -> b -> a
const Bool
True
, borderWidth :: Int
borderWidth = 2
, iconSort :: [WindowData] -> WorkspacesIO [WindowData]
iconSort = [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition
, updateEvents :: [String]
updateEvents = [String]
allEWMHProperties [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String
ewmhWMIcon]
, updateRateLimitMicroseconds :: Integer
updateRateLimitMicroseconds = 100000
, urgentWorkspaceState :: Bool
urgentWorkspaceState = Bool
False
}
hideEmpty :: Workspace -> Bool
hideEmpty :: Workspace -> Bool
hideEmpty Workspace { workspaceState :: Workspace -> WorkspaceState
workspaceState = WorkspaceState
Empty } = Bool
False
hideEmpty _ = Bool
True
wLog :: MonadIO m => Priority -> String -> m ()
wLog :: Priority -> String -> m ()
wLog l :: Priority
l s :: String
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM "System.Taffybar.Widget.Workspaces" Priority
l String
s
updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar :: MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar var :: MVar a
var modify :: a -> WorkspacesIO a
modify = do
WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
IO a -> WorkspacesIO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> WorkspacesIO a) -> IO a -> WorkspacesIO a
forall a b. (a -> b) -> a -> b
$ MVar a -> (a -> IO (a, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar a
var ((a -> IO (a, a)) -> IO a) -> (a -> IO (a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ (a -> (a, a)) -> IO a -> IO (a, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a :: a
a -> (a
a, a
a)) (IO a -> IO (a, a)) -> (a -> IO a) -> a -> IO (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspacesIO a -> WorkspacesContext -> IO a)
-> WorkspacesContext -> WorkspacesIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO a -> WorkspacesContext -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO a -> IO a) -> (a -> WorkspacesIO a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> WorkspacesIO a
modify
updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace)
updateWorkspacesVar :: WorkspacesIO (Map WorkspaceId Workspace)
updateWorkspacesVar = do
MVar (Map WorkspaceId Workspace)
workspacesRef <- (WorkspacesContext -> MVar (Map WorkspaceId Workspace))
-> ReaderT WorkspacesContext IO (MVar (Map WorkspaceId Workspace))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar
MVar (Map WorkspaceId Workspace)
-> (Map WorkspaceId Workspace
-> WorkspacesIO (Map WorkspaceId Workspace))
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a. MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar MVar (Map WorkspaceId Workspace)
workspacesRef Map WorkspaceId Workspace
-> WorkspacesIO (Map WorkspaceId Workspace)
buildWorkspaceData
getWorkspaceToWindows ::
[X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window)
getWorkspaceToWindows :: [X11Window] -> X11Property (MultiMap WorkspaceId X11Window)
getWorkspaceToWindows =
(MultiMap WorkspaceId X11Window
-> X11Window -> X11Property (MultiMap WorkspaceId X11Window))
-> MultiMap WorkspaceId X11Window
-> [X11Window]
-> X11Property (MultiMap WorkspaceId X11Window)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\theMap :: MultiMap WorkspaceId X11Window
theMap window :: X11Window
window ->
WorkspaceId
-> X11Window
-> MultiMap WorkspaceId X11Window
-> MultiMap WorkspaceId X11Window
forall k a. Ord k => k -> a -> MultiMap k a -> MultiMap k a
MM.insert (WorkspaceId
-> X11Window
-> MultiMap WorkspaceId X11Window
-> MultiMap WorkspaceId X11Window)
-> ReaderT X11Context IO WorkspaceId
-> ReaderT
X11Context
IO
(X11Window
-> MultiMap WorkspaceId X11Window
-> MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X11Window -> ReaderT X11Context IO WorkspaceId
getWorkspace X11Window
window ReaderT
X11Context
IO
(X11Window
-> MultiMap WorkspaceId X11Window
-> MultiMap WorkspaceId X11Window)
-> ReaderT X11Context IO X11Window
-> ReaderT
X11Context
IO
(MultiMap WorkspaceId X11Window -> MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> X11Window -> ReaderT X11Context IO X11Window
forall (f :: * -> *) a. Applicative f => a -> f a
pure X11Window
window ReaderT
X11Context
IO
(MultiMap WorkspaceId X11Window -> MultiMap WorkspaceId X11Window)
-> X11Property (MultiMap WorkspaceId X11Window)
-> X11Property (MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MultiMap WorkspaceId X11Window
-> X11Property (MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiMap WorkspaceId X11Window
theMap)
MultiMap WorkspaceId X11Window
forall k a. MultiMap k a
MM.empty
getWindowData :: Maybe X11Window
-> [X11Window]
-> X11Window
-> X11Property WindowData
getWindowData :: Maybe X11Window
-> [X11Window] -> X11Window -> X11Property WindowData
getWindowData activeWindow :: Maybe X11Window
activeWindow urgentWindows :: [X11Window]
urgentWindows window :: X11Window
window = do
String
wTitle <- X11Window -> X11Property String
getWindowTitle X11Window
window
String
wClass <- X11Window -> X11Property String
getWindowClass X11Window
window
Bool
wMinimized <- X11Window -> X11Property Bool
getWindowMinimized X11Window
window
WindowData -> X11Property WindowData
forall (m :: * -> *) a. Monad m => a -> m a
return
WindowData :: X11Window -> String -> String -> Bool -> Bool -> Bool -> WindowData
WindowData
{ windowId :: X11Window
windowId = X11Window
window
, windowTitle :: String
windowTitle = String
wTitle
, windowClass :: String
windowClass = String
wClass
, windowUrgent :: Bool
windowUrgent = X11Window
window X11Window -> [X11Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [X11Window]
urgentWindows
, windowActive :: Bool
windowActive = X11Window -> Maybe X11Window
forall a. a -> Maybe a
Just X11Window
window Maybe X11Window -> Maybe X11Window -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe X11Window
activeWindow
, windowMinimized :: Bool
windowMinimized = Bool
wMinimized
}
buildWorkspaceData :: M.Map WorkspaceId Workspace
-> WorkspacesIO (M.Map WorkspaceId Workspace)
buildWorkspaceData :: Map WorkspaceId Workspace
-> WorkspacesIO (Map WorkspaceId Workspace)
buildWorkspaceData _ = ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT WorkspacesContext IO WorkspacesContext
-> (WorkspacesContext -> WorkspacesIO (Map WorkspaceId Workspace))
-> WorkspacesIO (Map WorkspaceId Workspace)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \context :: WorkspacesContext
context -> Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def Map WorkspaceId Workspace
forall k a. Map k a
M.empty (X11Property (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace))
-> X11Property (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$ do
[(WorkspaceId, String)]
names <- X11Property [(WorkspaceId, String)]
getWorkspaceNames
[X11Window]
wins <- X11Property [X11Window]
getWindows
MultiMap WorkspaceId X11Window
workspaceToWindows <- [X11Window] -> X11Property (MultiMap WorkspaceId X11Window)
getWorkspaceToWindows [X11Window]
wins
[X11Window]
urgentWindows <- (X11Window -> X11Property Bool)
-> [X11Window] -> X11Property [X11Window]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM X11Window -> X11Property Bool
isWindowUrgent [X11Window]
wins
Maybe X11Window
activeWindow <- X11Property (Maybe X11Window)
getActiveWindow
active :: WorkspaceId
active:visible :: [WorkspaceId]
visible <- X11Property [WorkspaceId]
getVisibleWorkspaces
let getWorkspaceState :: WorkspaceId -> [X11Window] -> WorkspaceState
getWorkspaceState idx :: WorkspaceId
idx ws :: [X11Window]
ws
| WorkspaceId
idx WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== WorkspaceId
active = WorkspaceState
Active
| WorkspaceId
idx WorkspaceId -> [WorkspaceId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
visible = WorkspaceState
Visible
| WorkspacesConfig -> Bool
urgentWorkspaceState (WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
context) Bool -> Bool -> Bool
&&
Bool -> Bool
not ([X11Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([X11Window]
ws [X11Window] -> [X11Window] -> [X11Window]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [X11Window]
urgentWindows)) =
WorkspaceState
Urgent
| [X11Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [X11Window]
ws = WorkspaceState
Empty
| Bool
otherwise = WorkspaceState
Hidden
(Map WorkspaceId Workspace
-> (WorkspaceId, String)
-> X11Property (Map WorkspaceId Workspace))
-> Map WorkspaceId Workspace
-> [(WorkspaceId, String)]
-> X11Property (Map WorkspaceId Workspace)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\theMap :: Map WorkspaceId Workspace
theMap (idx :: WorkspaceId
idx, name :: String
name) -> do
let ws :: [X11Window]
ws = WorkspaceId -> MultiMap WorkspaceId X11Window -> [X11Window]
forall k a. Ord k => k -> MultiMap k a -> [a]
MM.lookup WorkspaceId
idx MultiMap WorkspaceId X11Window
workspaceToWindows
[WindowData]
windowInfos <- (X11Window -> X11Property WindowData)
-> [X11Window] -> ReaderT X11Context IO [WindowData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe X11Window
-> [X11Window] -> X11Window -> X11Property WindowData
getWindowData Maybe X11Window
activeWindow [X11Window]
urgentWindows) [X11Window]
ws
Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace))
-> Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$
WorkspaceId
-> Workspace
-> Map WorkspaceId Workspace
-> Map WorkspaceId Workspace
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
WorkspaceId
idx
Workspace :: WorkspaceId
-> String -> WorkspaceState -> [WindowData] -> Workspace
Workspace
{ workspaceIdx :: WorkspaceId
workspaceIdx = WorkspaceId
idx
, workspaceName :: String
workspaceName = String
name
, workspaceState :: WorkspaceState
workspaceState = WorkspaceId -> [X11Window] -> WorkspaceState
getWorkspaceState WorkspaceId
idx [X11Window]
ws
, windows :: [WindowData]
windows = [WindowData]
windowInfos
}
Map WorkspaceId Workspace
theMap)
Map WorkspaceId Workspace
forall k a. Map k a
M.empty
[(WorkspaceId, String)]
names
addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel = do
WorkspacesContext
{ controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
, workspacesWidget :: WorkspacesContext -> Box
workspacesWidget = Box
cont
} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Map WorkspaceId WWC
controllersMap <- IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId WWC) -> IO (Map WorkspaceId WWC)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId WWC)
controllersRef
(WWC -> WorkspacesIO ()) -> [WWC] -> WorkspacesIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WWC -> WorkspacesIO ()
addWidget ([WWC] -> WorkspacesIO ()) -> [WWC] -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WWC -> [WWC]
forall k a. Map k a -> [a]
M.elems Map WorkspaceId WWC
controllersMap
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll Box
cont
addWidget :: WWC -> WorkspacesIO ()
addWidget :: WWC -> WorkspacesIO ()
addWidget controller :: WWC
controller = do
Box
cont <- (WorkspacesContext -> Box) -> ReaderT WorkspacesContext IO Box
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> Box
workspacesWidget
Widget
workspaceWidget <- WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget WWC
controller
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
Box
hbox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal 0
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Widget -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m (Maybe Widget)
Gtk.widgetGetParent Widget
workspaceWidget IO (Maybe Widget)
-> (Maybe Widget -> IO (Maybe Box)) -> IO (Maybe Box)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Widget -> IO Box) -> Maybe Widget -> IO (Maybe Box)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ManagedPtr Box -> Box) -> Widget -> IO Box
forall o o'.
(HasCallStack, GObject o, GObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo ManagedPtr Box -> Box
Gtk.Box) IO (Maybe Box) -> (Maybe Box -> IO (Maybe ())) -> IO (Maybe ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Box -> IO ()) -> Maybe Box -> IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Box -> Widget -> IO ()) -> Widget -> Box -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerRemove Widget
workspaceWidget)
Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
hbox Widget
workspaceWidget
Box -> Box -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
cont Box
hbox
workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget
workspacesNew :: WorkspacesConfig -> TaffyIO Widget
workspacesNew cfg :: WorkspacesConfig
cfg = ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Context IO Context
-> (Context -> TaffyIO Widget) -> TaffyIO Widget
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \tContext :: Context
tContext -> IO Widget -> TaffyIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> TaffyIO Widget) -> IO Widget -> TaffyIO Widget
forall a b. (a -> b) -> a -> b
$ do
Box
cont <- 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
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WorkspacesConfig -> Int
widgetGap WorkspacesConfig
cfg)
MVar (Map WorkspaceId WWC)
controllersRef <- Map WorkspaceId WWC -> IO (MVar (Map WorkspaceId WWC))
forall a. a -> IO (MVar a)
MV.newMVar Map WorkspaceId WWC
forall k a. Map k a
M.empty
MVar (Map WorkspaceId Workspace)
workspacesRef <- Map WorkspaceId Workspace -> IO (MVar (Map WorkspaceId Workspace))
forall a. a -> IO (MVar a)
MV.newMVar Map WorkspaceId Workspace
forall k a. Map k a
M.empty
let context :: WorkspacesContext
context =
WorkspacesContext :: MVar (Map WorkspaceId WWC)
-> MVar (Map WorkspaceId Workspace)
-> Box
-> WorkspacesConfig
-> Context
-> WorkspacesContext
WorkspacesContext
{ controllersVar :: MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
, workspacesVar :: MVar (Map WorkspaceId Workspace)
workspacesVar = MVar (Map WorkspaceId Workspace)
workspacesRef
, workspacesWidget :: Box
workspacesWidget = Box
cont
, workspacesConfig :: WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg
, taffyContext :: Context
taffyContext = Context
tContext
}
WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesIO ()
updateAllWorkspaceWidgets WorkspacesContext
context
Event -> IO ()
updateHandler <- WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate WorkspacesContext
context
Set X11Window -> IO ()
iconHandler <- WorkspacesContext -> IO (Set X11Window -> IO ())
onIconsChanged WorkspacesContext
context
let doUpdate :: Event -> ReaderT Context IO ()
doUpdate = IO () -> ReaderT Context IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Context IO ())
-> (Event -> IO ()) -> Event -> ReaderT Context IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> IO ()
updateHandler
handleConfigureEvents :: Event -> ReaderT Context IO ()
handleConfigureEvents e :: Event
e@(ConfigureEvent {}) = Event -> ReaderT Context IO ()
doUpdate Event
e
handleConfigureEvents _ = () -> ReaderT Context IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(workspaceSubscription :: Unique
workspaceSubscription, iconSubscription :: Unique
iconSubscription, geometrySubscription :: Unique
geometrySubscription) <-
(ReaderT Context IO (Unique, Unique, Unique)
-> Context -> IO (Unique, Unique, Unique))
-> Context
-> ReaderT Context IO (Unique, Unique, Unique)
-> IO (Unique, Unique, Unique)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO (Unique, Unique, Unique)
-> Context -> IO (Unique, Unique, Unique)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
tContext (ReaderT Context IO (Unique, Unique, Unique)
-> IO (Unique, Unique, Unique))
-> ReaderT Context IO (Unique, Unique, Unique)
-> IO (Unique, Unique, Unique)
forall a b. (a -> b) -> a -> b
$ (ReaderT Context IO Unique, ReaderT Context IO Unique,
ReaderT Context IO Unique)
-> ReaderT Context IO (Unique, Unique, Unique)
forall a b. SequenceT a b => a -> b
sequenceT
( [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents (WorkspacesConfig -> [String]
updateEvents WorkspacesConfig
cfg) (Listener -> ReaderT Context IO Unique)
-> Listener -> ReaderT Context IO Unique
forall a b. (a -> b) -> a -> b
$ Event -> ReaderT Context IO ()
Listener
doUpdate
, [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents [String
ewmhWMIcon] (IO () -> ReaderT Context IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Context IO ())
-> (Event -> IO ()) -> Event -> ReaderT Context IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged Set X11Window -> IO ()
iconHandler)
, Listener -> Taffy IO Unique
subscribeToAll Event -> ReaderT Context IO ()
Listener
handleConfigureEvents
)
let doUnsubscribe :: IO ()
doUnsubscribe = (ReaderT Context IO () -> Context -> IO ())
-> Context -> ReaderT Context IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
tContext (ReaderT Context IO () -> IO ()) -> ReaderT Context IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(Unique -> ReaderT Context IO ())
-> [Unique] -> ReaderT Context IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Unique -> ReaderT Context IO ()
Unique -> Taffy IO ()
unsubscribe
[ Unique
iconSubscription
, Unique
workspaceSubscription
, Unique
geometrySubscription
]
SignalHandlerId
_ <- Box -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
Gtk.onWidgetUnrealize Box
cont IO ()
doUnsubscribe
Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
cont "workspaces"
Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
cont
updateAllWorkspaceWidgets :: WorkspacesIO ()
updateAllWorkspaceWidgets :: WorkspacesIO ()
updateAllWorkspaceWidgets = do
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Updating workspace widgets"
Map WorkspaceId Workspace
workspacesMap <- WorkspacesIO (Map WorkspaceId Workspace)
updateWorkspacesVar
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> WorkspacesIO ()) -> String -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Workspaces: %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId Workspace -> String
forall a. Show a => a -> String
show Map WorkspaceId Workspace
workspacesMap
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Adding and removing widgets"
WorkspacesIO ()
updateWorkspaceControllers
let updateController' :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController' idx :: WorkspaceId
idx controller :: WWC
controller =
WorkspacesIO WWC
-> ControllerConstructor -> Maybe Workspace -> WorkspacesIO WWC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (WWC -> WorkspacesIO WWC
forall (m :: * -> *) a. Monad m => a -> m a
return WWC
controller)
(WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget WWC
controller (WidgetUpdate -> WorkspacesIO WWC)
-> (Workspace -> WidgetUpdate) -> ControllerConstructor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace -> WidgetUpdate
WorkspaceUpdate) (Maybe Workspace -> WorkspacesIO WWC)
-> Maybe Workspace -> WorkspacesIO WWC
forall a b. (a -> b) -> a -> b
$
WorkspaceId -> Map WorkspaceId Workspace -> Maybe Workspace
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
idx Map WorkspaceId Workspace
workspacesMap
logUpdateController :: a -> m ()
logUpdateController i :: a
i =
Priority -> String -> m ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Updating %s workspace widget" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
i
updateController :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController i :: WorkspaceId
i cont :: WWC
cont = WorkspaceId -> WorkspacesIO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
logUpdateController WorkspaceId
i WorkspacesIO () -> WorkspacesIO WWC -> WorkspacesIO WWC
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
WorkspaceId -> WWC -> WorkspacesIO WWC
updateController' WorkspaceId
i WWC
cont
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Done updating individual widget"
(WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate WorkspaceId -> WWC -> WorkspacesIO WWC
updateController
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Showing and hiding controllers"
WorkspacesIO ()
setControllerWidgetVisibility
setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility = do
ctx :: WorkspacesContext
ctx@WorkspacesContext
{ workspacesVar :: WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar = MVar (Map WorkspaceId Workspace)
workspacesRef
, controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
, workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg
} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
Map WorkspaceId Workspace
workspacesMap <- MVar (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId Workspace)
workspacesRef
Map WorkspaceId WWC
controllersMap <- MVar (Map WorkspaceId WWC) -> IO (Map WorkspaceId WWC)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId WWC)
controllersRef
[Workspace] -> (Workspace -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map WorkspaceId Workspace -> [Workspace]
forall k a. Map k a -> [a]
M.elems Map WorkspaceId Workspace
workspacesMap) ((Workspace -> IO ()) -> IO ()) -> (Workspace -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ws :: Workspace
ws ->
let action :: Widget -> IO ()
action = if WorkspacesConfig -> Workspace -> Bool
showWorkspaceFn WorkspacesConfig
cfg Workspace
ws
then Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow
else Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetHide
in
(WWC -> IO Widget) -> Maybe WWC -> IO (Maybe Widget)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((WorkspacesIO Widget -> WorkspacesContext -> IO Widget)
-> WorkspacesContext -> WorkspacesIO Widget -> IO Widget
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO Widget -> WorkspacesContext -> IO Widget
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO Widget -> IO Widget)
-> (WWC -> WorkspacesIO Widget) -> WWC -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget)
(WorkspaceId -> Map WorkspaceId WWC -> Maybe WWC
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Workspace -> WorkspaceId
workspaceIdx Workspace
ws) Map WorkspaceId WWC
controllersMap) IO (Maybe Widget) -> (Maybe Widget -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
IO () -> (Widget -> IO ()) -> Maybe Widget -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Widget -> IO ()
action
doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate updateController :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController = do
c :: WorkspacesContext
c@WorkspacesContext { controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId WWC)
-> (Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar (Map WorkspaceId WWC)
controllersRef ((Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)) -> IO ())
-> (Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \controllers :: Map WorkspaceId WWC
controllers -> do
Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Updating controllers ref"
[(WorkspaceId, WWC)]
controllersList <-
((WorkspaceId, WWC) -> IO (WorkspaceId, WWC))
-> [(WorkspaceId, WWC)] -> IO [(WorkspaceId, WWC)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(\(idx :: WorkspaceId
idx, controller :: WWC
controller) -> do
WWC
newController <- WorkspacesIO WWC -> WorkspacesContext -> IO WWC
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (WorkspaceId -> WWC -> WorkspacesIO WWC
updateController WorkspaceId
idx WWC
controller) WorkspacesContext
c
(WorkspaceId, WWC) -> IO (WorkspaceId, WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId
idx, WWC
newController)) ([(WorkspaceId, WWC)] -> IO [(WorkspaceId, WWC)])
-> [(WorkspaceId, WWC)] -> IO [(WorkspaceId, WWC)]
forall a b. (a -> b) -> a -> b
$
Map WorkspaceId WWC -> [(WorkspaceId, WWC)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorkspaceId WWC
controllers
Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WorkspaceId WWC -> IO (Map WorkspaceId WWC))
-> Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ [(WorkspaceId, WWC)] -> Map WorkspaceId WWC
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(WorkspaceId, WWC)]
controllersList
updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers = do
WorkspacesContext
{ controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
, workspacesVar :: WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar = MVar (Map WorkspaceId Workspace)
workspacesRef
, workspacesWidget :: WorkspacesContext -> Box
workspacesWidget = Box
cont
, workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg
} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Map WorkspaceId Workspace
workspacesMap <- IO (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace))
-> IO (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId Workspace)
workspacesRef
Map WorkspaceId WWC
controllersMap <- IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId WWC) -> IO (Map WorkspaceId WWC)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId WWC)
controllersRef
let newWorkspacesSet :: Set WorkspaceId
newWorkspacesSet = Map WorkspaceId Workspace -> Set WorkspaceId
forall k a. Map k a -> Set k
M.keysSet Map WorkspaceId Workspace
workspacesMap
existingWorkspacesSet :: Set WorkspaceId
existingWorkspacesSet = Map WorkspaceId WWC -> Set WorkspaceId
forall k a. Map k a -> Set k
M.keysSet Map WorkspaceId WWC
controllersMap
Bool -> WorkspacesIO () -> WorkspacesIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set WorkspaceId
existingWorkspacesSet Set WorkspaceId -> Set WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
/= Set WorkspaceId
newWorkspacesSet) (WorkspacesIO () -> WorkspacesIO ())
-> WorkspacesIO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
let addWorkspaces :: Set WorkspaceId
addWorkspaces = Set WorkspaceId -> Set WorkspaceId -> Set WorkspaceId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set WorkspaceId
newWorkspacesSet Set WorkspaceId
existingWorkspacesSet
removeWorkspaces :: Set WorkspaceId
removeWorkspaces = Set WorkspaceId -> Set WorkspaceId -> Set WorkspaceId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set WorkspaceId
existingWorkspacesSet Set WorkspaceId
newWorkspacesSet
builder :: ControllerConstructor
builder = WorkspacesConfig -> ControllerConstructor
widgetBuilder WorkspacesConfig
cfg
Map WorkspaceId WWC
_ <- MVar (Map WorkspaceId WWC)
-> (Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a. MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar MVar (Map WorkspaceId WWC)
controllersRef ((Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> (Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ \controllers :: Map WorkspaceId WWC
controllers -> do
let oldRemoved :: Map WorkspaceId WWC
oldRemoved = (Map WorkspaceId WWC -> WorkspaceId -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> Set WorkspaceId -> Map WorkspaceId WWC
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl ((WorkspaceId -> Map WorkspaceId WWC -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> WorkspaceId -> Map WorkspaceId WWC
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspaceId -> Map WorkspaceId WWC -> Map WorkspaceId WWC
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map WorkspaceId WWC
controllers Set WorkspaceId
removeWorkspaces
buildController :: WorkspaceId -> Maybe (WorkspacesIO WWC)
buildController idx :: WorkspaceId
idx = ControllerConstructor
builder ControllerConstructor
-> Maybe Workspace -> Maybe (WorkspacesIO WWC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceId -> Map WorkspaceId Workspace -> Maybe Workspace
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
idx Map WorkspaceId Workspace
workspacesMap
buildAndAddController :: Map WorkspaceId WWC
-> WorkspaceId
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
buildAndAddController theMap :: Map WorkspaceId WWC
theMap idx :: WorkspaceId
idx =
ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
-> (WorkspacesIO WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> Maybe (WorkspacesIO WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return Map WorkspaceId WWC
theMap) (WorkspacesIO WWC
-> (WWC -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> (WWC -> Map WorkspaceId WWC)
-> WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WWC -> Map WorkspaceId WWC -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> WWC -> Map WorkspaceId WWC
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WorkspaceId -> WWC -> Map WorkspaceId WWC -> Map WorkspaceId WWC
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert WorkspaceId
idx) Map WorkspaceId WWC
theMap)
(WorkspaceId -> Maybe (WorkspacesIO WWC)
buildController WorkspaceId
idx)
(Map WorkspaceId WWC
-> WorkspaceId
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> Map WorkspaceId WWC
-> [WorkspaceId]
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map WorkspaceId WWC
-> WorkspaceId
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
buildAndAddController Map WorkspaceId WWC
oldRemoved ([WorkspaceId]
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> [WorkspaceId]
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ Set WorkspaceId -> [WorkspaceId]
forall a. Set a -> [a]
Set.toList Set WorkspaceId
addWorkspaces
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Box -> (Widget -> IO ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsContainer a) =>
a -> (Widget -> IO ()) -> m ()
Gtk.containerForeach Box
cont (Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerRemove Box
cont)
WorkspacesIO ()
addWidgetsToTopLevel
rateLimitFn
:: forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn :: WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn context :: WorkspacesContext
context =
let limit :: Integer
limit = (WorkspacesConfig -> Integer
updateRateLimitMicroseconds (WorkspacesConfig -> Integer) -> WorkspacesConfig -> Integer
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
context)
rate :: Microsecond
rate = Integer -> Microsecond
forall a. TimeUnit a => Integer -> a
fromMicroseconds Integer
limit :: Microsecond in
RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
forall req resp t.
TimeUnit t =>
RateLimit t
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
generateRateLimitedFunction (RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp))
-> RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
forall a b. (a -> b) -> a -> b
$ Microsecond -> RateLimit Microsecond
forall a. a -> RateLimit a
PerInvocation Microsecond
rate
onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate context :: WorkspacesContext
context = do
Event -> IO ()
rateLimited <- WorkspacesContext
-> (Event -> IO ())
-> ResultsCombiner Event ()
-> IO (Event -> IO ())
forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn WorkspacesContext
context Event -> IO ()
doUpdate ResultsCombiner Event ()
forall p a b. p -> a -> Maybe (a, b -> ((), ()))
combineRequests
let withLog :: Event -> IO ()
withLog event :: Event
event = do
case Event
event of
PropertyEvent _ _ _ _ _ atom :: X11Window
atom _ _ ->
Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Event %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ X11Window -> String
forall a. Show a => a -> String
show X11Window
atom
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
rateLimited Event
event
(Event -> IO ()) -> IO (Event -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return Event -> IO ()
withLog
where
combineRequests :: p -> a -> Maybe (a, b -> ((), ()))
combineRequests _ b :: a
b = (a, b -> ((), ())) -> Maybe (a, b -> ((), ()))
forall a. a -> Maybe a
Just (a
b, ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()))
doUpdate :: Event -> IO ()
doUpdate _ = IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesIO ()
updateAllWorkspaceWidgets WorkspacesContext
context
onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged :: (Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged handler :: Set X11Window -> IO ()
handler event :: Event
event =
case Event
event of
PropertyEvent { ev_window :: Event -> X11Window
ev_window = X11Window
wid } -> do
Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Icon changed event %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ X11Window -> String
forall a. Show a => a -> String
show X11Window
wid
Set X11Window -> IO ()
handler (Set X11Window -> IO ()) -> Set X11Window -> IO ()
forall a b. (a -> b) -> a -> b
$ X11Window -> Set X11Window
forall a. a -> Set a
Set.singleton X11Window
wid
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())
onIconsChanged :: WorkspacesContext -> IO (Set X11Window -> IO ())
onIconsChanged context :: WorkspacesContext
context = WorkspacesContext
-> (Set X11Window -> IO ())
-> ResultsCombiner (Set X11Window) ()
-> IO (Set X11Window -> IO ())
forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn WorkspacesContext
context Set X11Window -> IO ()
onIconsChanged' ResultsCombiner (Set X11Window) ()
forall a b. Ord a => Set a -> Set a -> Maybe (Set a, b -> ((), ()))
combineRequests
where
combineRequests :: Set a -> Set a -> Maybe (Set a, b -> ((), ()))
combineRequests windows1 :: Set a
windows1 windows2 :: Set a
windows2 =
(Set a, b -> ((), ())) -> Maybe (Set a, b -> ((), ()))
forall a. a -> Maybe a
Just (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
windows1 Set a
windows2, ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()))
onIconsChanged' :: Set X11Window -> IO ()
onIconsChanged' wids :: Set X11Window
wids = do
Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Icon update execute %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Set X11Window -> String
forall a. Show a => a -> String
show Set X11Window
wids
IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
context (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate
(\idx :: WorkspaceId
idx c :: WWC
c ->
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> ShowS
forall r. PrintfType r => String -> r
printf "Updating %s icons." ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> String
forall a. Show a => a -> String
show WorkspaceId
idx) WorkspacesIO () -> WorkspacesIO WWC -> WorkspacesIO WWC
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget WWC
c ([X11Window] -> WidgetUpdate
IconUpdate ([X11Window] -> WidgetUpdate) -> [X11Window] -> WidgetUpdate
forall a b. (a -> b) -> a -> b
$ Set X11Window -> [X11Window]
forall a. Set a -> [a]
Set.toList Set X11Window
wids))
data WorkspaceContentsController = WorkspaceContentsController
{ WorkspaceContentsController -> Widget
containerWidget :: Gtk.Widget
, WorkspaceContentsController -> [WWC]
contentsControllers :: [WWC]
}
buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController constructors :: [ControllerConstructor]
constructors ws :: Workspace
ws = do
[WWC]
controllers <- (ControllerConstructor -> WorkspacesIO WWC)
-> [ControllerConstructor] -> ReaderT WorkspacesContext IO [WWC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ParentControllerConstructor
forall a b. (a -> b) -> a -> b
$ Workspace
ws) [ControllerConstructor]
constructors
WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
WorkspaceContentsController
tempController <- IO WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController)
-> IO WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall a b. (a -> b) -> a -> b
$ do
Box
cons <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal 0
(WWC -> IO ()) -> [WWC] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((WorkspacesIO Widget -> WorkspacesContext -> IO Widget)
-> WorkspacesContext -> WorkspacesIO Widget -> IO Widget
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO Widget -> WorkspacesContext -> IO Widget
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO Widget -> IO Widget)
-> (WWC -> WorkspacesIO Widget) -> WWC -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget (WWC -> IO Widget) -> (Widget -> IO ()) -> WWC -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
cons) [WWC]
controllers
Widget
outerBox <- Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
cons IO Widget -> (Widget -> IO Widget) -> IO Widget
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Widget -> IO Widget
forall (m :: * -> *). MonadIO m => Widget -> m Widget
buildPadBox
Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
cons "contents"
Widget
widget <- Widget -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Widget
outerBox
WorkspaceContentsController -> IO WorkspaceContentsController
forall (m :: * -> *) a. Monad m => a -> m a
return
WorkspaceContentsController :: Widget -> [WWC] -> WorkspaceContentsController
WorkspaceContentsController
{ containerWidget :: Widget
containerWidget = Widget
widget
, contentsControllers :: [WWC]
contentsControllers = [WWC]
controllers
}
WorkspaceContentsController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (WorkspaceContentsController -> WWC)
-> ReaderT WorkspacesContext IO WorkspaceContentsController
-> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceContentsController
-> WidgetUpdate
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget WorkspaceContentsController
tempController (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)
defaultBuildContentsController :: ControllerConstructor
defaultBuildContentsController :: ControllerConstructor
defaultBuildContentsController =
[ControllerConstructor] -> ControllerConstructor
buildContentsController [ControllerConstructor
buildLabelController, ControllerConstructor
buildIconController]
instance WorkspaceWidgetController WorkspaceContentsController where
getWidget :: WorkspaceContentsController -> WorkspacesIO Widget
getWidget = Widget -> WorkspacesIO Widget
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget -> WorkspacesIO Widget)
-> (WorkspaceContentsController -> Widget)
-> WorkspaceContentsController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceContentsController -> Widget
containerWidget
updateWidget :: WorkspaceContentsController
-> WidgetUpdate
-> ReaderT WorkspacesContext IO WorkspaceContentsController
updateWidget cc :: WorkspaceContentsController
cc update :: WidgetUpdate
update = do
WorkspacesContext {} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
case WidgetUpdate
update of
WorkspaceUpdate newWorkspace :: Workspace
newWorkspace ->
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Workspace -> Widget -> IO ()
forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
Workspace -> a -> m ()
setWorkspaceWidgetStatusClass Workspace
newWorkspace (Widget -> IO ()) -> Widget -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspaceContentsController -> Widget
containerWidget WorkspaceContentsController
cc
_ -> () -> WorkspacesIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[WWC]
newControllers <- (WWC -> WorkspacesIO WWC)
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
`updateWidget` WidgetUpdate
update) ([WWC] -> ReaderT WorkspacesContext IO [WWC])
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall a b. (a -> b) -> a -> b
$ WorkspaceContentsController -> [WWC]
contentsControllers WorkspaceContentsController
cc
WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceContentsController
cc {contentsControllers :: [WWC]
contentsControllers = [WWC]
newControllers}
updateWidgetX11 :: WorkspaceContentsController
-> WidgetUpdate
-> ReaderT WorkspacesContext IO WorkspaceContentsController
updateWidgetX11 cc :: WorkspaceContentsController
cc update :: WidgetUpdate
update = do
[WWC]
newControllers <- (WWC -> WorkspacesIO WWC)
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
`updateWidgetX11` WidgetUpdate
update) ([WWC] -> ReaderT WorkspacesContext IO [WWC])
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall a b. (a -> b) -> a -> b
$ WorkspaceContentsController -> [WWC]
contentsControllers WorkspaceContentsController
cc
WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceContentsController
cc {contentsControllers :: [WWC]
contentsControllers = [WWC]
newControllers}
newtype LabelController = LabelController { LabelController -> Label
label :: Gtk.Label }
buildLabelController :: ControllerConstructor
buildLabelController :: ControllerConstructor
buildLabelController ws :: Workspace
ws = do
LabelController
tempController <- IO LabelController -> ReaderT WorkspacesContext IO LabelController
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO LabelController
-> ReaderT WorkspacesContext IO LabelController)
-> IO LabelController
-> ReaderT WorkspacesContext IO LabelController
forall a b. (a -> b) -> a -> b
$ do
Label
lbl <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew Maybe Text
forall a. Maybe a
Nothing
Label
_ <- Label -> Text -> IO Label
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Label
lbl "workspace-label"
LabelController -> IO LabelController
forall (m :: * -> *) a. Monad m => a -> m a
return LabelController :: Label -> LabelController
LabelController { label :: Label
label = Label
lbl }
LabelController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (LabelController -> WWC)
-> ReaderT WorkspacesContext IO LabelController -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LabelController
-> WidgetUpdate -> ReaderT WorkspacesContext IO LabelController
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget LabelController
tempController (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)
instance WorkspaceWidgetController LabelController where
getWidget :: LabelController -> WorkspacesIO Widget
getWidget = IO Widget -> WorkspacesIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> (LabelController -> IO Widget)
-> LabelController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (Label -> IO Widget)
-> (LabelController -> Label) -> LabelController -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelController -> Label
label
updateWidget :: LabelController
-> WidgetUpdate -> ReaderT WorkspacesContext IO LabelController
updateWidget lc :: LabelController
lc (WorkspaceUpdate newWorkspace :: Workspace
newWorkspace) = do
WorkspacesContext { workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
String
labelText <- WorkspacesConfig -> Workspace -> WorkspacesIO String
labelSetter WorkspacesConfig
cfg Workspace
newWorkspace
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
Gtk.labelSetMarkup (LabelController -> Label
label LabelController
lc) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
labelText
Workspace -> Label -> IO ()
forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
Workspace -> a -> m ()
setWorkspaceWidgetStatusClass Workspace
newWorkspace (Label -> IO ()) -> Label -> IO ()
forall a b. (a -> b) -> a -> b
$ LabelController -> Label
label LabelController
lc
LabelController -> ReaderT WorkspacesContext IO LabelController
forall (m :: * -> *) a. Monad m => a -> m a
return LabelController
lc
updateWidget lc :: LabelController
lc _ = LabelController -> ReaderT WorkspacesContext IO LabelController
forall (m :: * -> *) a. Monad m => a -> m a
return LabelController
lc
data IconWidget = IconWidget
{ IconWidget -> EventBox
iconContainer :: Gtk.EventBox
, IconWidget -> Image
iconImage :: Gtk.Image
, IconWidget -> MVar (Maybe WindowData)
iconWindow :: MV.MVar (Maybe WindowData)
, IconWidget -> IO ()
iconForceUpdate :: IO ()
}
getPixbufForIconWidget :: Bool
-> MV.MVar (Maybe WindowData)
-> Int32
-> WorkspacesIO (Maybe Gdk.Pixbuf)
getPixbufForIconWidget :: Bool
-> MVar (Maybe WindowData) -> Int32 -> WorkspacesIO (Maybe Pixbuf)
getPixbufForIconWidget transparentOnNone :: Bool
transparentOnNone dataVar :: MVar (Maybe WindowData)
dataVar size :: Int32
size = do
WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let tContext :: Context
tContext = WorkspacesContext -> Context
taffyContext WorkspacesContext
ctx
getPBFromData :: WindowIconPixbufGetter
getPBFromData = WorkspacesConfig -> WindowIconPixbufGetter
getWindowIconPixbuf (WorkspacesConfig -> WindowIconPixbufGetter)
-> WorkspacesConfig -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
ctx
getPB' :: ReaderT Context IO (Maybe Pixbuf)
getPB' = MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf))
-> MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$
ReaderT Context IO (Maybe WindowData)
-> MaybeT (ReaderT Context IO) WindowData
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe WindowData) -> ReaderT Context IO (Maybe WindowData)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe WindowData) -> ReaderT Context IO (Maybe WindowData))
-> IO (Maybe WindowData) -> ReaderT Context IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a. MVar a -> IO a
MV.readMVar MVar (Maybe WindowData)
dataVar) MaybeT (ReaderT Context IO) WindowData
-> (WindowData -> MaybeT (ReaderT Context IO) Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Context IO (Maybe Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ReaderT Context IO (Maybe Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf)
-> (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowData
-> MaybeT (ReaderT Context IO) Pixbuf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowIconPixbufGetter
getPBFromData Int32
size
getPB :: ReaderT Context IO (Maybe Pixbuf)
getPB = if Bool
transparentOnNone
then ReaderT Context IO (Maybe Pixbuf)
-> ReaderT Context IO (Maybe Pixbuf)
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
maybeTCombine ReaderT Context IO (Maybe Pixbuf)
getPB' (Pixbuf -> Maybe Pixbuf
forall a. a -> Maybe a
Just (Pixbuf -> Maybe Pixbuf)
-> ReaderT Context IO Pixbuf -> ReaderT Context IO (Maybe Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> Word32 -> ReaderT Context IO Pixbuf
forall (m :: * -> *). MonadIO m => Int32 -> Word32 -> m Pixbuf
pixBufFromColor Int32
size 0)
else ReaderT Context IO (Maybe Pixbuf)
getPB'
IO (Maybe Pixbuf) -> WorkspacesIO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> WorkspacesIO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> WorkspacesIO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ ReaderT Context IO (Maybe Pixbuf) -> Context -> IO (Maybe Pixbuf)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Context IO (Maybe Pixbuf)
getPB Context
tContext
buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget transparentOnNone :: Bool
transparentOnNone ws :: Workspace
ws = do
WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
IO IconWidget -> WorkspacesIO IconWidget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO IconWidget -> WorkspacesIO IconWidget)
-> IO IconWidget -> WorkspacesIO IconWidget
forall a b. (a -> b) -> a -> b
$ do
MVar (Maybe WindowData)
windowVar <- Maybe WindowData -> IO (MVar (Maybe WindowData))
forall a. a -> IO (MVar a)
MV.newMVar Maybe WindowData
forall a. Maybe a
Nothing
Image
img <- IO Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew
IO ()
refreshImage <-
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> IO (IO ())
forall (m :: * -> *).
MonadIO m =>
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
autoSizeImage Image
img
((WorkspacesIO (Maybe Pixbuf)
-> WorkspacesContext -> IO (Maybe Pixbuf))
-> WorkspacesContext
-> WorkspacesIO (Maybe Pixbuf)
-> IO (Maybe Pixbuf)
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO (Maybe Pixbuf)
-> WorkspacesContext -> IO (Maybe Pixbuf)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO (Maybe Pixbuf) -> IO (Maybe Pixbuf))
-> (Int32 -> WorkspacesIO (Maybe Pixbuf))
-> Int32
-> IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> MVar (Maybe WindowData) -> Int32 -> WorkspacesIO (Maybe Pixbuf)
getPixbufForIconWidget Bool
transparentOnNone MVar (Maybe WindowData)
windowVar)
Orientation
Gtk.OrientationHorizontal
EventBox
ebox <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
Image
_ <- Image -> Text -> IO Image
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Image
img "window-icon"
EventBox
_ <- EventBox -> Text -> IO EventBox
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI EventBox
ebox "window-icon-container"
EventBox -> Image -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
ebox Image
img
SignalHandlerId
_ <-
EventBox -> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
ebox (WidgetButtonPressEventCallback -> IO SignalHandlerId)
-> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const (IO Bool -> WidgetButtonPressEventCallback)
-> IO Bool -> WidgetButtonPressEventCallback
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
Maybe WindowData
info <- MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a. MVar a -> IO a
MV.readMVar MVar (Maybe WindowData)
windowVar
case Maybe WindowData
info of
Just updatedInfo :: WindowData
updatedInfo ->
(WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
() -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def () (X11Property () -> WorkspacesIO ())
-> X11Property () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ X11Window -> X11Property ()
focusWindow (X11Window -> X11Property ()) -> X11Window -> X11Property ()
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
updatedInfo
_ -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspaceId -> IO Bool
forall (m :: * -> *).
MonadIO m =>
WorkspacesContext -> WorkspaceId -> m Bool
switch WorkspacesContext
ctx (Workspace -> WorkspaceId
workspaceIdx Workspace
ws)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
IconWidget -> IO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return
IconWidget :: EventBox -> Image -> MVar (Maybe WindowData) -> IO () -> IconWidget
IconWidget
{ iconContainer :: EventBox
iconContainer = EventBox
ebox
, iconImage :: Image
iconImage = Image
img
, iconWindow :: MVar (Maybe WindowData)
iconWindow = MVar (Maybe WindowData)
windowVar
, iconForceUpdate :: IO ()
iconForceUpdate = IO ()
refreshImage
}
data IconController = IconController
{ IconController -> Box
iconsContainer :: Gtk.Box
, IconController -> [IconWidget]
iconImages :: [IconWidget]
, IconController -> Workspace
iconWorkspace :: Workspace
}
buildIconController :: ControllerConstructor
buildIconController :: ControllerConstructor
buildIconController ws :: Workspace
ws = do
IconController
tempController <-
IO IconController -> ReaderT WorkspacesContext IO IconController
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO IconController -> ReaderT WorkspacesContext IO IconController)
-> IO IconController -> ReaderT WorkspacesContext IO IconController
forall a b. (a -> b) -> a -> b
$ do
Box
hbox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal 0
IconController -> IO IconController
forall (m :: * -> *) a. Monad m => a -> m a
return
IconController :: Box -> [IconWidget] -> Workspace -> IconController
IconController
{iconsContainer :: Box
iconsContainer = Box
hbox, iconImages :: [IconWidget]
iconImages = [], iconWorkspace :: Workspace
iconWorkspace = Workspace
ws}
IconController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (IconController -> WWC)
-> ReaderT WorkspacesContext IO IconController -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IconController
-> WidgetUpdate -> ReaderT WorkspacesContext IO IconController
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget IconController
tempController (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)
instance WorkspaceWidgetController IconController where
getWidget :: IconController -> WorkspacesIO Widget
getWidget = IO Widget -> WorkspacesIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> (IconController -> IO Widget)
-> IconController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (Box -> IO Widget)
-> (IconController -> Box) -> IconController -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IconController -> Box
iconsContainer
updateWidget :: IconController
-> WidgetUpdate -> ReaderT WorkspacesContext IO IconController
updateWidget ic :: IconController
ic (WorkspaceUpdate newWorkspace :: Workspace
newWorkspace) = do
[IconWidget]
newImages <- IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages IconController
ic Workspace
newWorkspace
IconController -> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a. Monad m => a -> m a
return IconController
ic { iconImages :: [IconWidget]
iconImages = [IconWidget]
newImages, iconWorkspace :: Workspace
iconWorkspace = Workspace
newWorkspace }
updateWidget ic :: IconController
ic (IconUpdate updatedIcons :: [X11Window]
updatedIcons) =
IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById IconController
ic [X11Window]
updatedIcons WorkspacesIO ()
-> ReaderT WorkspacesContext IO IconController
-> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IconController -> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a. Monad m => a -> m a
return IconController
ic
updateWindowIconsById ::
IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById :: IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById ic :: IconController
ic windowIds :: [X11Window]
windowIds =
(IconWidget -> WorkspacesIO ()) -> [IconWidget] -> WorkspacesIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ IconWidget -> WorkspacesIO ()
maybeUpdateWindowIcon ([IconWidget] -> WorkspacesIO ())
-> [IconWidget] -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ IconController -> [IconWidget]
iconImages IconController
ic
where
maybeUpdateWindowIcon :: IconWidget -> WorkspacesIO ()
maybeUpdateWindowIcon widget :: IconWidget
widget =
do
Maybe WindowData
info <- IO (Maybe WindowData)
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe WindowData)
-> ReaderT WorkspacesContext IO (Maybe WindowData))
-> IO (Maybe WindowData)
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a. MVar a -> IO a
MV.readMVar (MVar (Maybe WindowData) -> IO (Maybe WindowData))
-> MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ IconWidget -> MVar (Maybe WindowData)
iconWindow IconWidget
widget
Bool -> WorkspacesIO () -> WorkspacesIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> (WindowData -> Bool) -> Maybe WindowData -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((X11Window -> [X11Window] -> Bool)
-> [X11Window] -> X11Window -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip X11Window -> [X11Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [X11Window]
windowIds (X11Window -> Bool)
-> (WindowData -> X11Window) -> WindowData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowData -> X11Window
windowId) Maybe WindowData
info) (WorkspacesIO () -> WorkspacesIO ())
-> WorkspacesIO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$
IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget IconController
ic IconWidget
widget Maybe WindowData
info
scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter getter :: WindowIconPixbufGetter
getter size :: Int32
size =
WindowIconPixbufGetter
getter Int32
size (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> (Maybe Pixbuf -> ReaderT Context IO (Maybe Pixbuf))
-> WindowData
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> (Maybe Pixbuf -> IO (Maybe Pixbuf))
-> Maybe Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
Gtk.OrientationHorizontal)
constantScaleWindowIconPixbufGetter ::
Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter
constantScaleWindowIconPixbufGetter :: Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter
constantScaleWindowIconPixbufGetter constantSize :: Int32
constantSize getter :: WindowIconPixbufGetter
getter =
(WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
forall a b. a -> b -> a
const ((WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter)
-> (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter WindowIconPixbufGetter
getter Int32
constantSize
getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter
getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter
getWindowIconPixbufFromEWMH size :: Int32
size windowData :: WindowData
windowData =
Maybe Pixbuf
-> X11Property (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a. a -> X11Property a -> TaffyIO a
runX11Def Maybe Pixbuf
forall a. Maybe a
Nothing (Int32 -> X11Window -> X11Property (Maybe Pixbuf)
getIconPixBufFromEWMH Int32
size (X11Window -> X11Property (Maybe Pixbuf))
-> X11Window -> X11Property (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
windowData)
getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass size :: Int32
size windowData :: WindowData
windowData =
IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ Int32 -> String -> IO (Maybe Pixbuf)
getWindowIconFromClasses Int32
size (WindowData -> String
windowClass WindowData
windowData)
getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry size :: Int32
size windowData :: WindowData
windowData =
Int32 -> String -> ReaderT Context IO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClasses Int32
size (WindowData -> String
windowClass WindowData
windowData)
getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome _ windowData :: WindowData
windowData =
X11Window -> ReaderT Context IO (Maybe Pixbuf)
getPixBufFromChromeData (X11Window -> ReaderT Context IO (Maybe Pixbuf))
-> X11Window -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
windowData
defaultGetWindowIconPixbuf :: WindowIconPixbufGetter
defaultGetWindowIconPixbuf :: WindowIconPixbufGetter
defaultGetWindowIconPixbuf =
WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf
unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf =
WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||>
WindowIconPixbufGetter
getWindowIconPixbufFromClass WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||>
WindowIconPixbufGetter
getWindowIconPixbufFromEWMH
addCustomIconsToDefaultWithFallbackByPath
:: (WindowData -> Maybe FilePath)
-> FilePath
-> WindowIconPixbufGetter
addCustomIconsToDefaultWithFallbackByPath :: (WindowData -> Maybe String) -> String -> WindowIconPixbufGetter
addCustomIconsToDefaultWithFallbackByPath getCustomIconPath :: WindowData -> Maybe String
getCustomIconPath fallbackPath :: String
fallbackPath =
(WindowData -> Maybe String)
-> (Int32 -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
-> WindowIconPixbufGetter
addCustomIconsAndFallback
WindowData -> Maybe String
getCustomIconPath
(ReaderT Context IO (Maybe Pixbuf)
-> Int32 -> ReaderT Context IO (Maybe Pixbuf)
forall a b. a -> b -> a
const (ReaderT Context IO (Maybe Pixbuf)
-> Int32 -> ReaderT Context IO (Maybe Pixbuf))
-> ReaderT Context IO (Maybe Pixbuf)
-> Int32
-> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Pixbuf)
getPixbufFromFilePath String
fallbackPath)
WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf
addCustomIconsAndFallback
:: (WindowData -> Maybe FilePath)
-> (Int32 -> TaffyIO (Maybe Gdk.Pixbuf))
-> WindowIconPixbufGetter
-> WindowIconPixbufGetter
addCustomIconsAndFallback :: (WindowData -> Maybe String)
-> (Int32 -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
-> WindowIconPixbufGetter
addCustomIconsAndFallback getCustomIconPath :: WindowData -> Maybe String
getCustomIconPath fallback :: Int32 -> ReaderT Context IO (Maybe Pixbuf)
fallback defaultGetter :: WindowIconPixbufGetter
defaultGetter =
WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter (WindowIconPixbufGetter -> WindowIconPixbufGetter)
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$
WindowIconPixbufGetter
getCustomIcon WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||> WindowIconPixbufGetter
defaultGetter WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||> (\s :: Int32
s _ -> Int32 -> ReaderT Context IO (Maybe Pixbuf)
fallback Int32
s)
where
getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)
getCustomIcon :: WindowIconPixbufGetter
getCustomIcon _ wdata :: WindowData
wdata =
IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$
IO (Maybe Pixbuf)
-> (String -> IO (Maybe Pixbuf))
-> Maybe String
-> IO (Maybe Pixbuf)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pixbuf
forall a. Maybe a
Nothing) String -> IO (Maybe Pixbuf)
getPixbufFromFilePath (Maybe String -> IO (Maybe Pixbuf))
-> Maybe String -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ WindowData -> Maybe String
getCustomIconPath WindowData
wdata
sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition wins :: [WindowData]
wins = do
let getGeometryWorkspaces :: X11Window
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
getGeometryWorkspaces w :: X11Window
w = X11Property Display
getDisplay X11Property Display
-> (Display
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> (Display
-> IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> Display
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Display
-> X11Window
-> IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
`safeGetGeometry` X11Window
w)
getGeometries :: ReaderT X11Context IO [(X11Window, (Int32, Int32))]
getGeometries = (WindowData -> ReaderT X11Context IO (X11Window, (Int32, Int32)))
-> [WindowData]
-> ReaderT X11Context IO [(X11Window, (Int32, Int32))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
((X11Window -> ReaderT X11Context IO X11Window)
-> (X11Window -> ReaderT X11Context IO (Int32, Int32))
-> X11Window
-> ReaderT X11Context IO (X11Window, (Int32, Int32))
forall (m :: * -> *) c a b.
Monad m =>
(c -> m a) -> (c -> m b) -> c -> m (a, b)
forkM X11Window -> ReaderT X11Context IO X11Window
forall (m :: * -> *) a. Monad m => a -> m a
return
(((((X11Window, Int32, Int32, Word32, Word32, Word32, CInt) -> Int32
forall a b. Sel2 a b => a -> b
sel2 ((X11Window, Int32, Int32, Word32, Word32, Word32, CInt) -> Int32)
-> ((X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> Int32)
-> (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> (Int32, Int32)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (X11Window, Int32, Int32, Word32, Word32, Word32, CInt) -> Int32
forall a b. Sel3 a b => a -> b
sel3) ((X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> (Int32, Int32))
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> ReaderT X11Context IO (Int32, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> ReaderT X11Context IO (Int32, Int32))
-> (X11Window
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> X11Window
-> ReaderT X11Context IO (Int32, Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) X11Window
-> ReaderT
X11Context
IO
(X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
getGeometryWorkspaces) (X11Window -> ReaderT X11Context IO (X11Window, (Int32, Int32)))
-> (WindowData -> X11Window)
-> WindowData
-> ReaderT X11Context IO (X11Window, (Int32, Int32))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
WindowData -> X11Window
windowId)
[WindowData]
wins
[(X11Window, (Int32, Int32))]
windowGeometries <- [(X11Window, (Int32, Int32))]
-> ReaderT X11Context IO [(X11Window, (Int32, Int32))]
-> WorkspacesIO [(X11Window, (Int32, Int32))]
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def [] ReaderT X11Context IO [(X11Window, (Int32, Int32))]
getGeometries
let getLeftPos :: WindowData -> (Int32, Int32)
getLeftPos wd :: WindowData
wd =
(Int32, Int32) -> Maybe (Int32, Int32) -> (Int32, Int32)
forall a. a -> Maybe a -> a
fromMaybe (999999999, 99999999) (Maybe (Int32, Int32) -> (Int32, Int32))
-> Maybe (Int32, Int32) -> (Int32, Int32)
forall a b. (a -> b) -> a -> b
$ X11Window -> [(X11Window, (Int32, Int32))] -> Maybe (Int32, Int32)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (WindowData -> X11Window
windowId WindowData
wd) [(X11Window, (Int32, Int32))]
windowGeometries
compareWindowData :: WindowData -> WindowData -> Ordering
compareWindowData a :: WindowData
a b :: WindowData
b =
(Bool, (Int32, Int32)) -> (Bool, (Int32, Int32)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
(WindowData -> Bool
windowMinimized WindowData
a, WindowData -> (Int32, Int32)
getLeftPos WindowData
a)
(WindowData -> Bool
windowMinimized WindowData
b, WindowData -> (Int32, Int32)
getLeftPos WindowData
b)
[WindowData] -> WorkspacesIO [WindowData]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WindowData] -> WorkspacesIO [WindowData])
-> [WindowData] -> WorkspacesIO [WindowData]
forall a b. (a -> b) -> a -> b
$ (WindowData -> WindowData -> Ordering)
-> [WindowData] -> [WindowData]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy WindowData -> WindowData -> Ordering
compareWindowData [WindowData]
wins
updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages ic :: IconController
ic ws :: Workspace
ws = do
WorkspacesContext {workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
[WindowData]
sortedWindows <- WorkspacesConfig -> [WindowData] -> WorkspacesIO [WindowData]
iconSort WorkspacesConfig
cfg ([WindowData] -> WorkspacesIO [WindowData])
-> [WindowData] -> WorkspacesIO [WindowData]
forall a b. (a -> b) -> a -> b
$ Workspace -> [WindowData]
windows Workspace
ws
Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> WorkspacesIO ()) -> String -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Updating images for %s" (Workspace -> String
forall a. Show a => a -> String
show Workspace
ws)
let updateIconWidget' :: WorkspacesIO IconWidget
-> Maybe WindowData -> WorkspacesIO IconWidget
updateIconWidget' getImageAction :: WorkspacesIO IconWidget
getImageAction wdata :: Maybe WindowData
wdata = do
IconWidget
iconWidget <- WorkspacesIO IconWidget
getImageAction
()
_ <- IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget IconController
ic IconWidget
iconWidget Maybe WindowData
wdata
IconWidget -> WorkspacesIO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return IconWidget
iconWidget
existingImages :: [WorkspacesIO IconWidget]
existingImages = (IconWidget -> WorkspacesIO IconWidget)
-> [IconWidget] -> [WorkspacesIO IconWidget]
forall a b. (a -> b) -> [a] -> [b]
map IconWidget -> WorkspacesIO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return ([IconWidget] -> [WorkspacesIO IconWidget])
-> [IconWidget] -> [WorkspacesIO IconWidget]
forall a b. (a -> b) -> a -> b
$ IconController -> [IconWidget]
iconImages IconController
ic
buildAndAddIconWidget :: Bool -> WorkspacesIO IconWidget
buildAndAddIconWidget transparentOnNone :: Bool
transparentOnNone = do
IconWidget
iw <- Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget Bool
transparentOnNone Workspace
ws
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Box -> EventBox -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd (IconController -> Box
iconsContainer IconController
ic) (EventBox -> IO ()) -> EventBox -> IO ()
forall a b. (a -> b) -> a -> b
$ IconWidget -> EventBox
iconContainer IconWidget
iw
IconWidget -> WorkspacesIO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return IconWidget
iw
infiniteImages :: [WorkspacesIO IconWidget]
infiniteImages =
[WorkspacesIO IconWidget]
existingImages [WorkspacesIO IconWidget]
-> [WorkspacesIO IconWidget] -> [WorkspacesIO IconWidget]
forall a. [a] -> [a] -> [a]
++
Int -> WorkspacesIO IconWidget -> [WorkspacesIO IconWidget]
forall a. Int -> a -> [a]
replicate (WorkspacesConfig -> Int
minIcons WorkspacesConfig
cfg Int -> Int -> Int
forall a. Num a => a -> a -> a
- [WorkspacesIO IconWidget] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WorkspacesIO IconWidget]
existingImages)
(Bool -> WorkspacesIO IconWidget
buildAndAddIconWidget Bool
True) [WorkspacesIO IconWidget]
-> [WorkspacesIO IconWidget] -> [WorkspacesIO IconWidget]
forall a. [a] -> [a] -> [a]
++
WorkspacesIO IconWidget -> [WorkspacesIO IconWidget]
forall a. a -> [a]
repeat (Bool -> WorkspacesIO IconWidget
buildAndAddIconWidget Bool
False)
windowCount :: Int
windowCount = [WindowData] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([WindowData] -> Int) -> [WindowData] -> Int
forall a b. (a -> b) -> a -> b
$ Workspace -> [WindowData]
windows Workspace
ws
maxNeeded :: Int
maxNeeded = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
windowCount (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
windowCount) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ WorkspacesConfig -> Maybe Int
maxIcons WorkspacesConfig
cfg
newImagesNeeded :: Bool
newImagesNeeded = [WorkspacesIO IconWidget] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WorkspacesIO IconWidget]
existingImages Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (WorkspacesConfig -> Int
minIcons WorkspacesConfig
cfg) Int
maxNeeded
imgSrcs :: [WorkspacesIO IconWidget]
imgSrcs =
if Bool
newImagesNeeded
then [WorkspacesIO IconWidget]
infiniteImages
else [WorkspacesIO IconWidget]
existingImages
getImgs :: [WorkspacesIO IconWidget]
getImgs = [WorkspacesIO IconWidget]
-> (Int -> [WorkspacesIO IconWidget])
-> Maybe Int
-> [WorkspacesIO IconWidget]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [WorkspacesIO IconWidget]
imgSrcs (Int -> [WorkspacesIO IconWidget] -> [WorkspacesIO IconWidget]
forall a. Int -> [a] -> [a]
`take` [WorkspacesIO IconWidget]
imgSrcs) (Maybe Int -> [WorkspacesIO IconWidget])
-> Maybe Int -> [WorkspacesIO IconWidget]
forall a b. (a -> b) -> a -> b
$ WorkspacesConfig -> Maybe Int
maxIcons WorkspacesConfig
cfg
justWindows :: [Maybe WindowData]
justWindows = (WindowData -> Maybe WindowData)
-> [WindowData] -> [Maybe WindowData]
forall a b. (a -> b) -> [a] -> [b]
map WindowData -> Maybe WindowData
forall a. a -> Maybe a
Just [WindowData]
sortedWindows
windowDatas :: [Maybe WindowData]
windowDatas =
if Bool
newImagesNeeded
then [Maybe WindowData]
justWindows [Maybe WindowData] -> [Maybe WindowData] -> [Maybe WindowData]
forall a. [a] -> [a] -> [a]
++
Int -> Maybe WindowData -> [Maybe WindowData]
forall a. Int -> a -> [a]
replicate (WorkspacesConfig -> Int
minIcons WorkspacesConfig
cfg Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Maybe WindowData] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe WindowData]
justWindows) Maybe WindowData
forall a. Maybe a
Nothing
else [Maybe WindowData]
justWindows [Maybe WindowData] -> [Maybe WindowData] -> [Maybe WindowData]
forall a. [a] -> [a] -> [a]
++ Maybe WindowData -> [Maybe WindowData]
forall a. a -> [a]
repeat Maybe WindowData
forall a. Maybe a
Nothing
[IconWidget]
newImgs <-
(WorkspacesIO IconWidget
-> Maybe WindowData -> WorkspacesIO IconWidget)
-> [WorkspacesIO IconWidget]
-> [Maybe WindowData]
-> WorkspacesIO [IconWidget]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM WorkspacesIO IconWidget
-> Maybe WindowData -> WorkspacesIO IconWidget
updateIconWidget' [WorkspacesIO IconWidget]
getImgs [Maybe WindowData]
windowDatas
Bool -> WorkspacesIO () -> WorkspacesIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
newImagesNeeded (WorkspacesIO () -> WorkspacesIO ())
-> WorkspacesIO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll (Box -> IO ()) -> Box -> IO ()
forall a b. (a -> b) -> a -> b
$ IconController -> Box
iconsContainer IconController
ic
[IconWidget] -> WorkspacesIO [IconWidget]
forall (m :: * -> *) a. Monad m => a -> m a
return [IconWidget]
newImgs
getWindowStatusString :: WindowData -> T.Text
getWindowStatusString :: WindowData -> Text
getWindowStatusString windowData :: WindowData
windowData = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
case WindowData
windowData of
WindowData { windowMinimized :: WindowData -> Bool
windowMinimized = Bool
True } -> "minimized"
WindowData { windowActive :: WindowData -> Bool
windowActive = Bool
True } -> WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Active
WindowData { windowUrgent :: WindowData -> Bool
windowUrgent = Bool
True } -> WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Urgent
_ -> "normal"
possibleStatusStrings :: [T.Text]
possibleStatusStrings :: [Text]
possibleStatusStrings =
(String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
(Text -> Text
T.toLower (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
[WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Active, WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Urgent, "minimized", "normal", "inactive"]
updateIconWidget
:: IconController
-> IconWidget
-> Maybe WindowData
-> WorkspacesIO ()
updateIconWidget :: IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget _ IconWidget
{ iconContainer :: IconWidget -> EventBox
iconContainer = EventBox
iconButton
, iconWindow :: IconWidget -> MVar (Maybe WindowData)
iconWindow = MVar (Maybe WindowData)
windowRef
, iconForceUpdate :: IconWidget -> IO ()
iconForceUpdate = IO ()
updateIcon
} windowData :: Maybe WindowData
windowData = do
let statusString :: Text
statusString = Text -> (WindowData -> Text) -> Maybe WindowData -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "inactive" WindowData -> Text
getWindowStatusString Maybe WindowData
windowData :: T.Text
setIconWidgetProperties :: IO ()
setIconWidgetProperties =
EventBox -> [Text] -> [Text] -> IO ()
forall (t1 :: * -> *) (t :: * -> *) a (m :: * -> *).
(Foldable t1, Foldable t, IsWidget a, MonadIO m) =>
a -> t1 Text -> t Text -> m ()
updateWidgetClasses EventBox
iconButton [Text
statusString] [Text]
possibleStatusStrings
ReaderT WorkspacesContext IO (Maybe WindowData) -> WorkspacesIO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT WorkspacesContext IO (Maybe WindowData)
-> WorkspacesIO ())
-> ReaderT WorkspacesContext IO (Maybe WindowData)
-> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe WindowData)
-> (Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a. MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar MVar (Maybe WindowData)
windowRef ((Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData))
-> (Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ ReaderT WorkspacesContext IO (Maybe WindowData)
-> Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. a -> b -> a
const (ReaderT WorkspacesContext IO (Maybe WindowData)
-> Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData)
-> Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ Maybe WindowData -> ReaderT WorkspacesContext IO (Maybe WindowData)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WindowData
windowData
IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ IO ()
updateIcon IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
setIconWidgetProperties
data WorkspaceButtonController = WorkspaceButtonController
{ WorkspaceButtonController -> EventBox
button :: Gtk.EventBox
, WorkspaceButtonController -> Workspace
buttonWorkspace :: Workspace
, WorkspaceButtonController -> WWC
contentsController :: WWC
}
buildButtonController :: ParentControllerConstructor
buildButtonController :: ParentControllerConstructor
buildButtonController contentsBuilder :: ControllerConstructor
contentsBuilder workspace :: Workspace
workspace = do
WWC
cc <- ControllerConstructor
contentsBuilder Workspace
workspace
MVar (Map WorkspaceId Workspace)
workspacesRef <- (WorkspacesContext -> MVar (Map WorkspaceId Workspace))
-> ReaderT WorkspacesContext IO (MVar (Map WorkspaceId Workspace))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar
WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Widget
widget <- WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget WWC
cc
IO WWC -> WorkspacesIO WWC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO WWC -> WorkspacesIO WWC) -> IO WWC -> WorkspacesIO WWC
forall a b. (a -> b) -> a -> b
$ do
EventBox
ebox <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
EventBox -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
ebox Widget
widget
EventBox -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsEventBox a) =>
a -> Bool -> m ()
Gtk.eventBoxSetVisibleWindow EventBox
ebox Bool
False
SignalHandlerId
_ <-
EventBox -> WidgetScrollEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetScrollEventCallback -> m SignalHandlerId
Gtk.onWidgetScrollEvent EventBox
ebox (WidgetScrollEventCallback -> IO SignalHandlerId)
-> WidgetScrollEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \scrollEvent :: EventScroll
scrollEvent -> do
ScrollDirection
dir <- EventScroll -> IO ScrollDirection
forall (m :: * -> *). MonadIO m => EventScroll -> m ScrollDirection
Gdk.getEventScrollDirection EventScroll
scrollEvent
Map WorkspaceId Workspace
workspaces <- IO (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace))
-> IO (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId Workspace)
workspacesRef
let switchOne :: Bool -> IO Bool
switchOne a :: Bool
a =
IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
(ReaderT WorkspacesContext IO Bool -> WorkspacesContext -> IO Bool)
-> WorkspacesContext
-> ReaderT WorkspacesContext IO Bool
-> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT WorkspacesContext IO Bool -> WorkspacesContext -> IO Bool
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (ReaderT WorkspacesContext IO Bool -> IO Bool)
-> ReaderT WorkspacesContext IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
() -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def
()
(Bool -> Int -> X11Property ()
switchOneWorkspace Bool
a ([(WorkspaceId, Workspace)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map WorkspaceId Workspace -> [(WorkspaceId, Workspace)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorkspaceId Workspace
workspaces) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) WorkspacesIO ()
-> ReaderT WorkspacesContext IO Bool
-> ReaderT WorkspacesContext IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Bool -> ReaderT WorkspacesContext IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
case ScrollDirection
dir of
Gdk.ScrollDirectionUp -> Bool -> IO Bool
switchOne Bool
True
Gdk.ScrollDirectionLeft -> Bool -> IO Bool
switchOne Bool
True
Gdk.ScrollDirectionDown -> Bool -> IO Bool
switchOne Bool
False
Gdk.ScrollDirectionRight -> Bool -> IO Bool
switchOne Bool
False
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
SignalHandlerId
_ <- EventBox -> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
ebox (WidgetButtonPressEventCallback -> IO SignalHandlerId)
-> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const (IO Bool -> WidgetButtonPressEventCallback)
-> IO Bool -> WidgetButtonPressEventCallback
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspaceId -> IO Bool
forall (m :: * -> *).
MonadIO m =>
WorkspacesContext -> WorkspaceId -> m Bool
switch WorkspacesContext
ctx (WorkspaceId -> IO Bool) -> WorkspaceId -> IO Bool
forall a b. (a -> b) -> a -> b
$ Workspace -> WorkspaceId
workspaceIdx Workspace
workspace
WWC -> IO WWC
forall (m :: * -> *) a. Monad m => a -> m a
return (WWC -> IO WWC) -> WWC -> IO WWC
forall a b. (a -> b) -> a -> b
$
WorkspaceButtonController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC
WorkspaceButtonController :: EventBox -> Workspace -> WWC -> WorkspaceButtonController
WorkspaceButtonController
{button :: EventBox
button = EventBox
ebox, buttonWorkspace :: Workspace
buttonWorkspace = Workspace
workspace, contentsController :: WWC
contentsController = WWC
cc}
switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool
switch :: WorkspacesContext -> WorkspaceId -> m Bool
switch ctx :: WorkspacesContext
ctx idx :: WorkspaceId
idx = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def () (X11Property () -> WorkspacesIO ())
-> X11Property () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> X11Property ()
switchToWorkspace WorkspaceId
idx
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
instance WorkspaceWidgetController WorkspaceButtonController
where
getWidget :: WorkspaceButtonController -> WorkspacesIO Widget
getWidget wbc :: WorkspaceButtonController
wbc = IO Widget -> WorkspacesIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> IO Widget -> WorkspacesIO Widget
forall a b. (a -> b) -> a -> b
$ EventBox -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (EventBox -> IO Widget) -> EventBox -> IO Widget
forall a b. (a -> b) -> a -> b
$ WorkspaceButtonController -> EventBox
button WorkspaceButtonController
wbc
updateWidget :: WorkspaceButtonController
-> WidgetUpdate -> WorkspacesIO WorkspaceButtonController
updateWidget wbc :: WorkspaceButtonController
wbc update :: WidgetUpdate
update = do
WWC
newContents <- WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget (WorkspaceButtonController -> WWC
contentsController WorkspaceButtonController
wbc) WidgetUpdate
update
WorkspaceButtonController -> WorkspacesIO WorkspaceButtonController
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceButtonController
wbc { contentsController :: WWC
contentsController = WWC
newContents }