{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.Workspaces
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
-----------------------------------------------------------------------------

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 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 a
def 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 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 a
widget t1 Text
toAdd 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 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 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 wc
cont WidgetUpdate
_ = 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 a
wc) = a -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget a
wc
  updateWidget :: WWC -> WidgetUpdate -> WorkspacesIO WWC
updateWidget (WWC a
wc) 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 a
wc) 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 = Int
0
  , underlineHeight :: Int
underlineHeight = Int
4
  , underlinePadding :: Int
underlinePadding = Int
1
  , maxIcons :: Maybe Int
maxIcons = Maybe Int
forall a. Maybe a
Nothing
  , minIcons :: Int
minIcons = Int
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 = Int
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 = Integer
100000
  , urgentWorkspaceState :: Bool
urgentWorkspaceState = Bool
False
  }

hideEmpty :: Workspace -> Bool
hideEmpty :: Workspace -> Bool
hideEmpty Workspace { workspaceState :: Workspace -> WorkspaceState
workspaceState = WorkspaceState
Empty } = Bool
False
hideEmpty Workspace
_ = Bool
True

wLog :: MonadIO m => Priority -> String -> m ()
wLog :: Priority -> String -> m ()
wLog Priority
l 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 String
"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 MVar a
var 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)) (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
    (\MultiMap WorkspaceId X11Window
theMap 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 Maybe X11Window
activeWindow [X11Window]
urgentWindows 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 Map WorkspaceId Workspace
_ = 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
>>= \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
  WorkspaceId
active:[WorkspaceId]
visible <- X11Property [WorkspaceId]
getVisibleWorkspaces
  let getWorkspaceState :: WorkspaceId -> [X11Window] -> WorkspaceState
getWorkspaceState WorkspaceId
idx [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
    (\Map WorkspaceId Workspace
theMap (WorkspaceId
idx, 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
  -- Elems returns elements in ascending order of their keys so this will always
  -- add the widgets in the correct order
  (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 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
     -- XXX: This hbox exists to (hopefully) prevent the issue where workspace
     -- widgets appear out of order, in the switcher, by acting as an empty
     -- place holder when the actual widget is hidden.
    Box
hbox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
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, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject 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 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
>>= \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
        }
  -- This will actually create all the widgets
  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 Event
_ = () -> ReaderT Context IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (Unique
workspaceSubscription, Unique
iconSubscription, 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 -> Taffy IO Unique) -> Listener -> Taffy 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 Text
"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 String
"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 String
"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 String
"Adding and removing widgets"
  WorkspacesIO ()
updateWorkspaceControllers

  let updateController' :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController' WorkspaceId
idx 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 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 String
"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 WorkspaceId
i 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 String
"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 String
"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
$ \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 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
$ \Map WorkspaceId WWC
controllers -> do
    Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG String
"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
      (\(WorkspaceId
idx, 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
$ \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 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 Map WorkspaceId WWC
theMap 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
    -- Clear the container and repopulate it
    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 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 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 = do
        case Event
event of
          PropertyEvent EventType
_ SignalHandlerId
_ Bool
_ Display
_ X11Window
_ X11Window
atom X11Window
_ CInt
_ ->
            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 String
"Event %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ X11Window -> String
forall a. Show a => a -> String
show X11Window
atom
          Event
_ -> () -> 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 p
_ 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 Event
_ = 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 Set X11Window -> IO ()
handler 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 String
"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
    Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())
onIconsChanged :: WorkspacesContext -> IO (Set X11Window -> IO ())
onIconsChanged 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 Set a
windows1 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' 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 String
"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
          (\WorkspaceId
idx WWC
c ->
             Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> ShowS
forall r. PrintfType r => String -> r
printf String
"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 [ControllerConstructor]
constructors 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 Int32
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 Text
"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 WorkspaceContentsController
cc WidgetUpdate
update = do
    WorkspacesContext {} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    case WidgetUpdate
update of
      WorkspaceUpdate 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
      WidgetUpdate
_ -> () -> 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 WorkspaceContentsController
cc 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 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 Text
"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 LabelController
lc (WorkspaceUpdate 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 LabelController
lc WidgetUpdate
_ = 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 Bool
transparentOnNone MVar (Maybe WindowData)
dataVar 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 -> EventType -> ReaderT Context IO Pixbuf
forall (m :: * -> *). MonadIO m => Int32 -> EventType -> m Pixbuf
pixBufFromColor Int32
size EventType
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 Bool
transparentOnNone 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 Text
"window-icon"
    EventBox
_ <- EventBox -> Text -> IO EventBox
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI EventBox
ebox Text
"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 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
          Maybe WindowData
_ -> 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 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 Int32
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 IconController
ic (WorkspaceUpdate 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 IconController
ic (IconUpdate [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 IconController
ic [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 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 WindowIconPixbufGetter
getter 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 Int32
constantSize 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 Int32
size 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 Int32
size 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 Int32
size WindowData
windowData =
  Int32 -> String -> ReaderT Context IO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClasses Int32
size (WindowData -> String
windowClass WindowData
windowData)

getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome Int32
_ 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 WindowData -> Maybe String
getCustomIconPath 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 WindowData -> Maybe String
getCustomIconPath Int32 -> ReaderT Context IO (Maybe Pixbuf)
fallback 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)
<|||> (\Int32
s WindowData
_ -> Int32 -> ReaderT Context IO (Maybe Pixbuf)
fallback Int32
s)
  where
    getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)
    getCustomIcon :: WindowIconPixbufGetter
getCustomIcon Int32
_ 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 [WindowData]
wins = do
  let getGeometryWorkspaces :: X11Window
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
getGeometryWorkspaces X11Window
w = X11Property Display
getDisplay X11Property Display
-> (Display
    -> ReaderT
         X11Context
         IO
         (X11Window, Int32, Int32, EventType, EventType, EventType, CInt))
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
 -> ReaderT
      X11Context
      IO
      (X11Window, Int32, Int32, EventType, EventType, EventType, CInt))
-> (Display
    -> IO
         (X11Window, Int32, Int32, EventType, EventType, EventType, CInt))
-> Display
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Display
-> X11Window
-> IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, 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, EventType, EventType, EventType, CInt)
-> Int32
forall a b. Sel2 a b => a -> b
sel2 ((X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
 -> Int32)
-> ((X11Window, Int32, Int32, EventType, EventType, EventType,
     CInt)
    -> Int32)
-> (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
-> (Int32, Int32)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
-> Int32
forall a b. Sel3 a b => a -> b
sel3) ((X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
 -> (Int32, Int32))
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
-> ReaderT X11Context IO (Int32, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ReaderT
   X11Context
   IO
   (X11Window, Int32, Int32, EventType, EventType, EventType, CInt)
 -> ReaderT X11Context IO (Int32, Int32))
-> (X11Window
    -> ReaderT
         X11Context
         IO
         (X11Window, Int32, Int32, EventType, EventType, EventType, CInt))
-> X11Window
-> ReaderT X11Context IO (Int32, Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) X11Window
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, EventType, EventType, EventType, 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 WindowData
wd =
        (Int32, Int32) -> Maybe (Int32, Int32) -> (Int32, Int32)
forall a. a -> Maybe a -> a
fromMaybe (Int32
999999999, Int32
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 WindowData
a 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 IconController
ic 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 String
"Updating images for %s" (Workspace -> String
forall a. Show a => a -> String
show Workspace
ws)
  let updateIconWidget' :: WorkspacesIO IconWidget
-> Maybe WindowData -> WorkspacesIO IconWidget
updateIconWidget' WorkspacesIO IconWidget
getImageAction 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 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
      -- XXX: Only one of the two things being zipped can be an infinite list,
      -- which is why this newImagesNeeded contortion is needed.
      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 = 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 } -> String
"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
    WindowData
_ -> String
"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, String
"minimized", String
"normal", String
"inactive"]

updateIconWidget
  :: IconController
  -> IconWidget
  -> Maybe WindowData
  -> WorkspacesIO ()
updateIconWidget :: IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget IconController
_ IconWidget
                   { iconContainer :: IconWidget -> EventBox
iconContainer = EventBox
iconButton
                   , iconWindow :: IconWidget -> MVar (Maybe WindowData)
iconWindow = MVar (Maybe WindowData)
windowRef
                   , iconForceUpdate :: IconWidget -> IO ()
iconForceUpdate = IO ()
updateIcon
                   } Maybe WindowData
windowData = do
  let statusString :: Text
statusString = Text -> (WindowData -> Text) -> Maybe WindowData -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"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 ControllerConstructor
contentsBuilder 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
$ \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 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
- Int
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
          ScrollDirection
Gdk.ScrollDirectionUp -> Bool -> IO Bool
switchOne Bool
True
          ScrollDirection
Gdk.ScrollDirectionLeft -> Bool -> IO Bool
switchOne Bool
True
          ScrollDirection
Gdk.ScrollDirectionDown -> Bool -> IO Bool
switchOne Bool
False
          ScrollDirection
Gdk.ScrollDirectionRight -> Bool -> IO Bool
switchOne Bool
False
          ScrollDirection
_ -> 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 WorkspacesContext
ctx 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 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 WorkspaceButtonController
wbc 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 }