{-# 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 action :: TaffyIO a
action = (WorkspacesContext -> Context)
-> ReaderT WorkspacesContext IO Context
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> Context
taffyContext ReaderT WorkspacesContext IO Context
-> (Context -> WorkspacesIO a) -> WorkspacesIO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> WorkspacesIO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> WorkspacesIO a)
-> (Context -> IO a) -> Context -> WorkspacesIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaffyIO a -> Context -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TaffyIO a
action

liftX11Def :: a -> X11Property a -> WorkspacesIO a
liftX11Def :: a -> X11Property a -> WorkspacesIO a
liftX11Def def :: a
def prop :: X11Property a
prop = TaffyIO a -> WorkspacesIO a
forall a. TaffyIO a -> WorkspacesIO a
liftContext (TaffyIO a -> WorkspacesIO a) -> TaffyIO a -> WorkspacesIO a
forall a b. (a -> b) -> a -> b
$ a -> X11Property a -> TaffyIO a
forall a. a -> X11Property a -> TaffyIO a
runX11Def a
def X11Property a
prop

setWorkspaceWidgetStatusClass ::
     (MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m ()
setWorkspaceWidgetStatusClass :: Workspace -> a -> m ()
setWorkspaceWidgetStatusClass workspace :: Workspace
workspace widget :: a
widget =
  a -> [Text] -> [Text] -> m ()
forall (t1 :: * -> *) (t :: * -> *) a (m :: * -> *).
(Foldable t1, Foldable t, IsWidget a, MonadIO m) =>
a -> t1 Text -> t Text -> m ()
updateWidgetClasses
    a
widget
    [WorkspaceState -> Text
forall s. Show s => s -> Text
getCSSClass (WorkspaceState -> Text) -> WorkspaceState -> Text
forall a b. (a -> b) -> a -> b
$ Workspace -> WorkspaceState
workspaceState Workspace
workspace]
    [Text]
cssWorkspaceStates

updateWidgetClasses ::
  (Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m)
  => a
  -> t1 T.Text
  -> t T.Text
  -> m ()
updateWidgetClasses :: a -> t1 Text -> t Text -> m ()
updateWidgetClasses widget :: a
widget toAdd :: t1 Text
toAdd toRemove :: t Text
toRemove = do
  StyleContext
context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
  let hasClass :: Text -> m Bool
hasClass = StyleContext -> Text -> m Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m Bool
Gtk.styleContextHasClass StyleContext
context
      addIfMissing :: Text -> m ()
addIfMissing klass :: Text
klass =
        Text -> m Bool
hasClass Text
klass m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextAddClass StyleContext
context Text
klass) (Bool -> m ()) -> (Bool -> Bool) -> Bool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not
      removeIfPresent :: Text -> m ()
removeIfPresent klass :: Text
klass = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
klass Text -> t1 Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t1 Text
toAdd) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m Bool
hasClass Text
klass m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextRemoveClass StyleContext
context Text
klass)
  (Text -> m ()) -> t Text -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
removeIfPresent t Text
toRemove
  (Text -> m ()) -> t1 Text -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
addIfMissing t1 Text
toAdd

class WorkspaceWidgetController wc where
  getWidget :: wc -> WorkspacesIO Gtk.Widget
  updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc
  updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc
  updateWidgetX11 cont :: wc
cont _ = wc -> WorkspacesIO wc
forall (m :: * -> *) a. Monad m => a -> m a
return wc
cont

data WWC = forall a. WorkspaceWidgetController a => WWC a

instance WorkspaceWidgetController WWC where
  getWidget :: WWC -> WorkspacesIO Widget
getWidget (WWC wc :: a
wc) = a -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget a
wc
  updateWidget :: WWC -> WidgetUpdate -> WorkspacesIO WWC
updateWidget (WWC wc :: a
wc) update :: WidgetUpdate
update = a -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (a -> WWC) -> ReaderT WorkspacesContext IO a -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> WidgetUpdate -> ReaderT WorkspacesContext IO a
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget a
wc WidgetUpdate
update
  updateWidgetX11 :: WWC -> WidgetUpdate -> WorkspacesIO WWC
updateWidgetX11 (WWC wc :: a
wc) update :: WidgetUpdate
update = a -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (a -> WWC) -> ReaderT WorkspacesContext IO a -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> WidgetUpdate -> ReaderT WorkspacesContext IO a
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidgetX11 a
wc WidgetUpdate
update

type ControllerConstructor = Workspace -> WorkspacesIO WWC
type ParentControllerConstructor =
  ControllerConstructor -> ControllerConstructor

type WindowIconPixbufGetter =
  Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)

data WorkspacesConfig =
  WorkspacesConfig
  { WorkspacesConfig -> ControllerConstructor
widgetBuilder :: ControllerConstructor
  , WorkspacesConfig -> Int
widgetGap :: Int
  , WorkspacesConfig -> Int
underlineHeight :: Int
  , WorkspacesConfig -> Int
underlinePadding :: Int
  , WorkspacesConfig -> Maybe Int
maxIcons :: Maybe Int
  , WorkspacesConfig -> Int
minIcons :: Int
  , WorkspacesConfig -> WindowIconPixbufGetter
getWindowIconPixbuf :: WindowIconPixbufGetter
  , WorkspacesConfig -> Workspace -> WorkspacesIO String
labelSetter :: Workspace -> WorkspacesIO String
  , WorkspacesConfig -> Workspace -> Bool
showWorkspaceFn :: Workspace -> Bool
  , WorkspacesConfig -> Int
borderWidth :: Int
  , WorkspacesConfig -> [String]
updateEvents :: [String]
  , WorkspacesConfig -> Integer
updateRateLimitMicroseconds :: Integer
  , WorkspacesConfig -> [WindowData] -> WorkspacesIO [WindowData]
iconSort :: [WindowData] -> WorkspacesIO [WindowData]
  , WorkspacesConfig -> Bool
urgentWorkspaceState :: Bool
  }

defaultWorkspacesConfig :: WorkspacesConfig
defaultWorkspacesConfig :: WorkspacesConfig
defaultWorkspacesConfig =
  WorkspacesConfig :: ControllerConstructor
-> Int
-> Int
-> Int
-> Maybe Int
-> Int
-> WindowIconPixbufGetter
-> (Workspace -> WorkspacesIO String)
-> (Workspace -> Bool)
-> Int
-> [String]
-> Integer
-> ([WindowData] -> WorkspacesIO [WindowData])
-> Bool
-> WorkspacesConfig
WorkspacesConfig
  { widgetBuilder :: ControllerConstructor
widgetBuilder = ParentControllerConstructor
buildButtonController ControllerConstructor
defaultBuildContentsController
  , widgetGap :: Int
widgetGap = 0
  , underlineHeight :: Int
underlineHeight = 4
  , underlinePadding :: Int
underlinePadding = 1
  , maxIcons :: Maybe Int
maxIcons = Maybe Int
forall a. Maybe a
Nothing
  , minIcons :: Int
minIcons = 0
  , getWindowIconPixbuf :: WindowIconPixbufGetter
getWindowIconPixbuf = WindowIconPixbufGetter
defaultGetWindowIconPixbuf
  , labelSetter :: Workspace -> WorkspacesIO String
labelSetter = String -> WorkspacesIO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> WorkspacesIO String)
-> (Workspace -> String) -> Workspace -> WorkspacesIO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace -> String
workspaceName
  , showWorkspaceFn :: Workspace -> Bool
showWorkspaceFn = Bool -> Workspace -> Bool
forall a b. a -> b -> a
const Bool
True
  , borderWidth :: Int
borderWidth = 2
  , iconSort :: [WindowData] -> WorkspacesIO [WindowData]
iconSort = [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition
  , updateEvents :: [String]
updateEvents = [String]
allEWMHProperties [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String
ewmhWMIcon]
  , updateRateLimitMicroseconds :: Integer
updateRateLimitMicroseconds = 100000
  , urgentWorkspaceState :: Bool
urgentWorkspaceState = Bool
False
  }

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

wLog :: MonadIO m => Priority -> String -> m ()
wLog :: Priority -> String -> m ()
wLog l :: Priority
l s :: String
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Priority -> String -> IO ()
logM "System.Taffybar.Widget.Workspaces" Priority
l String
s

updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar :: MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar var :: MVar a
var modify :: a -> WorkspacesIO a
modify = do
  WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO a -> WorkspacesIO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> WorkspacesIO a) -> IO a -> WorkspacesIO a
forall a b. (a -> b) -> a -> b
$ MVar a -> (a -> IO (a, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar a
var ((a -> IO (a, a)) -> IO a) -> (a -> IO (a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ (a -> (a, a)) -> IO a -> IO (a, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a :: a
a -> (a
a, a
a)) (IO a -> IO (a, a)) -> (a -> IO a) -> a -> IO (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspacesIO a -> WorkspacesContext -> IO a)
-> WorkspacesContext -> WorkspacesIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO a -> WorkspacesContext -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO a -> IO a) -> (a -> WorkspacesIO a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> WorkspacesIO a
modify

updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace)
updateWorkspacesVar :: WorkspacesIO (Map WorkspaceId Workspace)
updateWorkspacesVar = do
  MVar (Map WorkspaceId Workspace)
workspacesRef <- (WorkspacesContext -> MVar (Map WorkspaceId Workspace))
-> ReaderT WorkspacesContext IO (MVar (Map WorkspaceId Workspace))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar
  MVar (Map WorkspaceId Workspace)
-> (Map WorkspaceId Workspace
    -> WorkspacesIO (Map WorkspaceId Workspace))
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a. MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar MVar (Map WorkspaceId Workspace)
workspacesRef Map WorkspaceId Workspace
-> WorkspacesIO (Map WorkspaceId Workspace)
buildWorkspaceData

getWorkspaceToWindows ::
  [X11Window] -> X11Property (MM.MultiMap WorkspaceId X11Window)
getWorkspaceToWindows :: [X11Window] -> X11Property (MultiMap WorkspaceId X11Window)
getWorkspaceToWindows =
  (MultiMap WorkspaceId X11Window
 -> X11Window -> X11Property (MultiMap WorkspaceId X11Window))
-> MultiMap WorkspaceId X11Window
-> [X11Window]
-> X11Property (MultiMap WorkspaceId X11Window)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    (\theMap :: MultiMap WorkspaceId X11Window
theMap window :: X11Window
window ->
       WorkspaceId
-> X11Window
-> MultiMap WorkspaceId X11Window
-> MultiMap WorkspaceId X11Window
forall k a. Ord k => k -> a -> MultiMap k a -> MultiMap k a
MM.insert (WorkspaceId
 -> X11Window
 -> MultiMap WorkspaceId X11Window
 -> MultiMap WorkspaceId X11Window)
-> ReaderT X11Context IO WorkspaceId
-> ReaderT
     X11Context
     IO
     (X11Window
      -> MultiMap WorkspaceId X11Window
      -> MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X11Window -> ReaderT X11Context IO WorkspaceId
getWorkspace X11Window
window ReaderT
  X11Context
  IO
  (X11Window
   -> MultiMap WorkspaceId X11Window
   -> MultiMap WorkspaceId X11Window)
-> ReaderT X11Context IO X11Window
-> ReaderT
     X11Context
     IO
     (MultiMap WorkspaceId X11Window -> MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> X11Window -> ReaderT X11Context IO X11Window
forall (f :: * -> *) a. Applicative f => a -> f a
pure X11Window
window ReaderT
  X11Context
  IO
  (MultiMap WorkspaceId X11Window -> MultiMap WorkspaceId X11Window)
-> X11Property (MultiMap WorkspaceId X11Window)
-> X11Property (MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MultiMap WorkspaceId X11Window
-> X11Property (MultiMap WorkspaceId X11Window)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiMap WorkspaceId X11Window
theMap)
    MultiMap WorkspaceId X11Window
forall k a. MultiMap k a
MM.empty

getWindowData :: Maybe X11Window
              -> [X11Window]
              -> X11Window
              -> X11Property WindowData
getWindowData :: Maybe X11Window
-> [X11Window] -> X11Window -> X11Property WindowData
getWindowData activeWindow :: Maybe X11Window
activeWindow urgentWindows :: [X11Window]
urgentWindows window :: X11Window
window = do
  String
wTitle <- X11Window -> X11Property String
getWindowTitle X11Window
window
  String
wClass <- X11Window -> X11Property String
getWindowClass X11Window
window
  Bool
wMinimized <- X11Window -> X11Property Bool
getWindowMinimized X11Window
window
  WindowData -> X11Property WindowData
forall (m :: * -> *) a. Monad m => a -> m a
return
    WindowData :: X11Window -> String -> String -> Bool -> Bool -> Bool -> WindowData
WindowData
    { windowId :: X11Window
windowId = X11Window
window
    , windowTitle :: String
windowTitle = String
wTitle
    , windowClass :: String
windowClass = String
wClass
    , windowUrgent :: Bool
windowUrgent = X11Window
window X11Window -> [X11Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [X11Window]
urgentWindows
    , windowActive :: Bool
windowActive = X11Window -> Maybe X11Window
forall a. a -> Maybe a
Just X11Window
window Maybe X11Window -> Maybe X11Window -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe X11Window
activeWindow
    , windowMinimized :: Bool
windowMinimized = Bool
wMinimized
    }

buildWorkspaceData :: M.Map WorkspaceId Workspace
                -> WorkspacesIO (M.Map WorkspaceId Workspace)
buildWorkspaceData :: Map WorkspaceId Workspace
-> WorkspacesIO (Map WorkspaceId Workspace)
buildWorkspaceData _ = ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT WorkspacesContext IO WorkspacesContext
-> (WorkspacesContext -> WorkspacesIO (Map WorkspaceId Workspace))
-> WorkspacesIO (Map WorkspaceId Workspace)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \context :: WorkspacesContext
context -> Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def Map WorkspaceId Workspace
forall k a. Map k a
M.empty (X11Property (Map WorkspaceId Workspace)
 -> WorkspacesIO (Map WorkspaceId Workspace))
-> X11Property (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$ do
  [(WorkspaceId, String)]
names <- X11Property [(WorkspaceId, String)]
getWorkspaceNames
  [X11Window]
wins <- X11Property [X11Window]
getWindows
  MultiMap WorkspaceId X11Window
workspaceToWindows <- [X11Window] -> X11Property (MultiMap WorkspaceId X11Window)
getWorkspaceToWindows [X11Window]
wins
  [X11Window]
urgentWindows <- (X11Window -> X11Property Bool)
-> [X11Window] -> X11Property [X11Window]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM X11Window -> X11Property Bool
isWindowUrgent [X11Window]
wins
  Maybe X11Window
activeWindow <- X11Property (Maybe X11Window)
getActiveWindow
  active :: WorkspaceId
active:visible :: [WorkspaceId]
visible <- X11Property [WorkspaceId]
getVisibleWorkspaces
  let getWorkspaceState :: WorkspaceId -> [X11Window] -> WorkspaceState
getWorkspaceState idx :: WorkspaceId
idx ws :: [X11Window]
ws
        | WorkspaceId
idx WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== WorkspaceId
active = WorkspaceState
Active
        | WorkspaceId
idx WorkspaceId -> [WorkspaceId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
visible = WorkspaceState
Visible
        | WorkspacesConfig -> Bool
urgentWorkspaceState (WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
context) Bool -> Bool -> Bool
&&
          Bool -> Bool
not ([X11Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([X11Window]
ws [X11Window] -> [X11Window] -> [X11Window]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [X11Window]
urgentWindows)) =
          WorkspaceState
Urgent
        | [X11Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [X11Window]
ws = WorkspaceState
Empty
        | Bool
otherwise = WorkspaceState
Hidden
  (Map WorkspaceId Workspace
 -> (WorkspaceId, String)
 -> X11Property (Map WorkspaceId Workspace))
-> Map WorkspaceId Workspace
-> [(WorkspaceId, String)]
-> X11Property (Map WorkspaceId Workspace)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    (\theMap :: Map WorkspaceId Workspace
theMap (idx :: WorkspaceId
idx, name :: String
name) -> do
       let ws :: [X11Window]
ws = WorkspaceId -> MultiMap WorkspaceId X11Window -> [X11Window]
forall k a. Ord k => k -> MultiMap k a -> [a]
MM.lookup WorkspaceId
idx MultiMap WorkspaceId X11Window
workspaceToWindows
       [WindowData]
windowInfos <- (X11Window -> X11Property WindowData)
-> [X11Window] -> ReaderT X11Context IO [WindowData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe X11Window
-> [X11Window] -> X11Window -> X11Property WindowData
getWindowData Maybe X11Window
activeWindow [X11Window]
urgentWindows) [X11Window]
ws
       Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WorkspaceId Workspace
 -> X11Property (Map WorkspaceId Workspace))
-> Map WorkspaceId Workspace
-> X11Property (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$
         WorkspaceId
-> Workspace
-> Map WorkspaceId Workspace
-> Map WorkspaceId Workspace
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
           WorkspaceId
idx
           Workspace :: WorkspaceId
-> String -> WorkspaceState -> [WindowData] -> Workspace
Workspace
           { workspaceIdx :: WorkspaceId
workspaceIdx = WorkspaceId
idx
           , workspaceName :: String
workspaceName = String
name
           , workspaceState :: WorkspaceState
workspaceState = WorkspaceId -> [X11Window] -> WorkspaceState
getWorkspaceState WorkspaceId
idx [X11Window]
ws
           , windows :: [WindowData]
windows = [WindowData]
windowInfos
           }
           Map WorkspaceId Workspace
theMap)
    Map WorkspaceId Workspace
forall k a. Map k a
M.empty
    [(WorkspaceId, String)]
names

addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel = do
  WorkspacesContext
    { controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
    , workspacesWidget :: WorkspacesContext -> Box
workspacesWidget = Box
cont
    } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Map WorkspaceId WWC
controllersMap <- IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map WorkspaceId WWC)
 -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId WWC) -> IO (Map WorkspaceId WWC)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId WWC)
controllersRef
  -- 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 controller :: WWC
controller = do
  Box
cont <- (WorkspacesContext -> Box) -> ReaderT WorkspacesContext IO Box
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> Box
workspacesWidget
  Widget
workspaceWidget <- WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget WWC
controller
  IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
     -- 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 0
    IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Widget -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m (Maybe Widget)
Gtk.widgetGetParent Widget
workspaceWidget IO (Maybe Widget)
-> (Maybe Widget -> IO (Maybe Box)) -> IO (Maybe Box)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
         (Widget -> IO Box) -> Maybe Widget -> IO (Maybe Box)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ManagedPtr Box -> Box) -> Widget -> IO Box
forall o o'.
(HasCallStack, GObject o, GObject o') =>
(ManagedPtr o' -> o') -> o -> IO o'
unsafeCastTo ManagedPtr Box -> Box
Gtk.Box) IO (Maybe Box) -> (Maybe Box -> IO (Maybe ())) -> IO (Maybe ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
         (Box -> IO ()) -> Maybe Box -> IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Box -> Widget -> IO ()) -> Widget -> Box -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerRemove Widget
workspaceWidget)
    Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
hbox Widget
workspaceWidget
    Box -> Box -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
cont Box
hbox

workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget
workspacesNew :: WorkspacesConfig -> TaffyIO Widget
workspacesNew cfg :: WorkspacesConfig
cfg = ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Context IO Context
-> (Context -> TaffyIO Widget) -> TaffyIO Widget
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \tContext :: Context
tContext -> IO Widget -> TaffyIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> TaffyIO Widget) -> IO Widget -> TaffyIO Widget
forall a b. (a -> b) -> a -> b
$ do
  Box
cont <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal (Int32 -> IO Box) -> Int32 -> IO Box
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WorkspacesConfig -> Int
widgetGap WorkspacesConfig
cfg)
  MVar (Map WorkspaceId WWC)
controllersRef <- Map WorkspaceId WWC -> IO (MVar (Map WorkspaceId WWC))
forall a. a -> IO (MVar a)
MV.newMVar Map WorkspaceId WWC
forall k a. Map k a
M.empty
  MVar (Map WorkspaceId Workspace)
workspacesRef <- Map WorkspaceId Workspace -> IO (MVar (Map WorkspaceId Workspace))
forall a. a -> IO (MVar a)
MV.newMVar Map WorkspaceId Workspace
forall k a. Map k a
M.empty
  let context :: WorkspacesContext
context =
        WorkspacesContext :: MVar (Map WorkspaceId WWC)
-> MVar (Map WorkspaceId Workspace)
-> Box
-> WorkspacesConfig
-> Context
-> WorkspacesContext
WorkspacesContext
        { controllersVar :: MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
        , workspacesVar :: MVar (Map WorkspaceId Workspace)
workspacesVar = MVar (Map WorkspaceId Workspace)
workspacesRef
        , workspacesWidget :: Box
workspacesWidget = Box
cont
        , workspacesConfig :: WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg
        , taffyContext :: Context
taffyContext = Context
tContext
        }
  -- 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 _ = () -> ReaderT Context IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (workspaceSubscription :: Unique
workspaceSubscription, iconSubscription :: Unique
iconSubscription, geometrySubscription :: Unique
geometrySubscription) <-
    (ReaderT Context IO (Unique, Unique, Unique)
 -> Context -> IO (Unique, Unique, Unique))
-> Context
-> ReaderT Context IO (Unique, Unique, Unique)
-> IO (Unique, Unique, Unique)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO (Unique, Unique, Unique)
-> Context -> IO (Unique, Unique, Unique)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
tContext (ReaderT Context IO (Unique, Unique, Unique)
 -> IO (Unique, Unique, Unique))
-> ReaderT Context IO (Unique, Unique, Unique)
-> IO (Unique, Unique, Unique)
forall a b. (a -> b) -> a -> b
$ (ReaderT Context IO Unique, ReaderT Context IO Unique,
 ReaderT Context IO Unique)
-> ReaderT Context IO (Unique, Unique, Unique)
forall a b. SequenceT a b => a -> b
sequenceT
         ( [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents (WorkspacesConfig -> [String]
updateEvents WorkspacesConfig
cfg) (Listener -> ReaderT Context IO Unique)
-> Listener -> ReaderT Context IO Unique
forall a b. (a -> b) -> a -> b
$ Event -> ReaderT Context IO ()
Listener
doUpdate
         , [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents [String
ewmhWMIcon] (IO () -> ReaderT Context IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Context IO ())
-> (Event -> IO ()) -> Event -> ReaderT Context IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged Set X11Window -> IO ()
iconHandler)
         , Listener -> Taffy IO Unique
subscribeToAll Event -> ReaderT Context IO ()
Listener
handleConfigureEvents
         )
  let doUnsubscribe :: IO ()
doUnsubscribe = (ReaderT Context IO () -> Context -> IO ())
-> Context -> ReaderT Context IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
tContext (ReaderT Context IO () -> IO ()) -> ReaderT Context IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Unique -> ReaderT Context IO ())
-> [Unique] -> ReaderT Context IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Unique -> ReaderT Context IO ()
Unique -> Taffy IO ()
unsubscribe
              [ Unique
iconSubscription
              , Unique
workspaceSubscription
              , Unique
geometrySubscription
              ]
  SignalHandlerId
_ <- Box -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
Gtk.onWidgetUnrealize Box
cont IO ()
doUnsubscribe
  Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
cont "workspaces"
  Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
cont

updateAllWorkspaceWidgets :: WorkspacesIO ()
updateAllWorkspaceWidgets :: WorkspacesIO ()
updateAllWorkspaceWidgets = do
  Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Updating workspace widgets"

  Map WorkspaceId Workspace
workspacesMap <- WorkspacesIO (Map WorkspaceId Workspace)
updateWorkspacesVar
  Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> WorkspacesIO ()) -> String -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Workspaces: %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId Workspace -> String
forall a. Show a => a -> String
show Map WorkspaceId Workspace
workspacesMap

  Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Adding and removing widgets"
  WorkspacesIO ()
updateWorkspaceControllers

  let updateController' :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController' idx :: WorkspaceId
idx controller :: WWC
controller =
        WorkspacesIO WWC
-> ControllerConstructor -> Maybe Workspace -> WorkspacesIO WWC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (WWC -> WorkspacesIO WWC
forall (m :: * -> *) a. Monad m => a -> m a
return WWC
controller)
              (WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget WWC
controller (WidgetUpdate -> WorkspacesIO WWC)
-> (Workspace -> WidgetUpdate) -> ControllerConstructor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace -> WidgetUpdate
WorkspaceUpdate) (Maybe Workspace -> WorkspacesIO WWC)
-> Maybe Workspace -> WorkspacesIO WWC
forall a b. (a -> b) -> a -> b
$
              WorkspaceId -> Map WorkspaceId Workspace -> Maybe Workspace
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
idx Map WorkspaceId Workspace
workspacesMap
      logUpdateController :: a -> m ()
logUpdateController i :: a
i =
        Priority -> String -> m ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Updating %s workspace widget" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
i
      updateController :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController i :: WorkspaceId
i cont :: WWC
cont = WorkspaceId -> WorkspacesIO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
logUpdateController WorkspaceId
i WorkspacesIO () -> WorkspacesIO WWC -> WorkspacesIO WWC
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                WorkspaceId -> WWC -> WorkspacesIO WWC
updateController' WorkspaceId
i WWC
cont

  Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Done updating individual widget"

  (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate WorkspaceId -> WWC -> WorkspacesIO WWC
updateController

  Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Showing and hiding controllers"
  WorkspacesIO ()
setControllerWidgetVisibility

setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility = do
  ctx :: WorkspacesContext
ctx@WorkspacesContext
    { workspacesVar :: WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar = MVar (Map WorkspaceId Workspace)
workspacesRef
    , controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
    , workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg
    } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
    Map WorkspaceId Workspace
workspacesMap <- MVar (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId Workspace)
workspacesRef
    Map WorkspaceId WWC
controllersMap <- MVar (Map WorkspaceId WWC) -> IO (Map WorkspaceId WWC)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId WWC)
controllersRef
    [Workspace] -> (Workspace -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map WorkspaceId Workspace -> [Workspace]
forall k a. Map k a -> [a]
M.elems Map WorkspaceId Workspace
workspacesMap) ((Workspace -> IO ()) -> IO ()) -> (Workspace -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ws :: Workspace
ws ->
      let action :: Widget -> IO ()
action = if WorkspacesConfig -> Workspace -> Bool
showWorkspaceFn WorkspacesConfig
cfg Workspace
ws
                   then Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow
                   else Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetHide
      in
        (WWC -> IO Widget) -> Maybe WWC -> IO (Maybe Widget)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((WorkspacesIO Widget -> WorkspacesContext -> IO Widget)
-> WorkspacesContext -> WorkspacesIO Widget -> IO Widget
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO Widget -> WorkspacesContext -> IO Widget
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO Widget -> IO Widget)
-> (WWC -> WorkspacesIO Widget) -> WWC -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget)
                    (WorkspaceId -> Map WorkspaceId WWC -> Maybe WWC
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Workspace -> WorkspaceId
workspaceIdx Workspace
ws) Map WorkspaceId WWC
controllersMap) IO (Maybe Widget) -> (Maybe Widget -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        IO () -> (Widget -> IO ()) -> Maybe Widget -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Widget -> IO ()
action

doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate :: (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate updateController :: WorkspaceId -> WWC -> WorkspacesIO WWC
updateController = do
  c :: WorkspacesContext
c@WorkspacesContext { controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId WWC)
-> (Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar (Map WorkspaceId WWC)
controllersRef ((Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)) -> IO ())
-> (Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \controllers :: Map WorkspaceId WWC
controllers -> do
    Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG "Updating controllers ref"
    [(WorkspaceId, WWC)]
controllersList <-
      ((WorkspaceId, WWC) -> IO (WorkspaceId, WWC))
-> [(WorkspaceId, WWC)] -> IO [(WorkspaceId, WWC)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      (\(idx :: WorkspaceId
idx, controller :: WWC
controller) -> do
         WWC
newController <- WorkspacesIO WWC -> WorkspacesContext -> IO WWC
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (WorkspaceId -> WWC -> WorkspacesIO WWC
updateController WorkspaceId
idx WWC
controller) WorkspacesContext
c
         (WorkspaceId, WWC) -> IO (WorkspaceId, WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId
idx, WWC
newController)) ([(WorkspaceId, WWC)] -> IO [(WorkspaceId, WWC)])
-> [(WorkspaceId, WWC)] -> IO [(WorkspaceId, WWC)]
forall a b. (a -> b) -> a -> b
$
      Map WorkspaceId WWC -> [(WorkspaceId, WWC)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorkspaceId WWC
controllers
    Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WorkspaceId WWC -> IO (Map WorkspaceId WWC))
-> Map WorkspaceId WWC -> IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ [(WorkspaceId, WWC)] -> Map WorkspaceId WWC
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(WorkspaceId, WWC)]
controllersList

updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers = do
  WorkspacesContext
    { controllersVar :: WorkspacesContext -> MVar (Map WorkspaceId WWC)
controllersVar = MVar (Map WorkspaceId WWC)
controllersRef
    , workspacesVar :: WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar = MVar (Map WorkspaceId Workspace)
workspacesRef
    , workspacesWidget :: WorkspacesContext -> Box
workspacesWidget = Box
cont
    , workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg
    } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Map WorkspaceId Workspace
workspacesMap <- IO (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map WorkspaceId Workspace)
 -> WorkspacesIO (Map WorkspaceId Workspace))
-> IO (Map WorkspaceId Workspace)
-> WorkspacesIO (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId Workspace)
workspacesRef
  Map WorkspaceId WWC
controllersMap <- IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map WorkspaceId WWC)
 -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> IO (Map WorkspaceId WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId WWC) -> IO (Map WorkspaceId WWC)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId WWC)
controllersRef

  let newWorkspacesSet :: Set WorkspaceId
newWorkspacesSet = Map WorkspaceId Workspace -> Set WorkspaceId
forall k a. Map k a -> Set k
M.keysSet Map WorkspaceId Workspace
workspacesMap
      existingWorkspacesSet :: Set WorkspaceId
existingWorkspacesSet = Map WorkspaceId WWC -> Set WorkspaceId
forall k a. Map k a -> Set k
M.keysSet Map WorkspaceId WWC
controllersMap

  Bool -> WorkspacesIO () -> WorkspacesIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set WorkspaceId
existingWorkspacesSet Set WorkspaceId -> Set WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
/= Set WorkspaceId
newWorkspacesSet) (WorkspacesIO () -> WorkspacesIO ())
-> WorkspacesIO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
    let addWorkspaces :: Set WorkspaceId
addWorkspaces = Set WorkspaceId -> Set WorkspaceId -> Set WorkspaceId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set WorkspaceId
newWorkspacesSet Set WorkspaceId
existingWorkspacesSet
        removeWorkspaces :: Set WorkspaceId
removeWorkspaces = Set WorkspaceId -> Set WorkspaceId -> Set WorkspaceId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set WorkspaceId
existingWorkspacesSet Set WorkspaceId
newWorkspacesSet
        builder :: ControllerConstructor
builder = WorkspacesConfig -> ControllerConstructor
widgetBuilder WorkspacesConfig
cfg

    Map WorkspaceId WWC
_ <- MVar (Map WorkspaceId WWC)
-> (Map WorkspaceId WWC
    -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a. MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar MVar (Map WorkspaceId WWC)
controllersRef ((Map WorkspaceId WWC
  -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
 -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> (Map WorkspaceId WWC
    -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ \controllers :: Map WorkspaceId WWC
controllers -> do
      let oldRemoved :: Map WorkspaceId WWC
oldRemoved = (Map WorkspaceId WWC -> WorkspaceId -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> Set WorkspaceId -> Map WorkspaceId WWC
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl ((WorkspaceId -> Map WorkspaceId WWC -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> WorkspaceId -> Map WorkspaceId WWC
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspaceId -> Map WorkspaceId WWC -> Map WorkspaceId WWC
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map WorkspaceId WWC
controllers Set WorkspaceId
removeWorkspaces
          buildController :: WorkspaceId -> Maybe (WorkspacesIO WWC)
buildController idx :: WorkspaceId
idx = ControllerConstructor
builder ControllerConstructor
-> Maybe Workspace -> Maybe (WorkspacesIO WWC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceId -> Map WorkspaceId Workspace -> Maybe Workspace
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
idx Map WorkspaceId Workspace
workspacesMap
          buildAndAddController :: Map WorkspaceId WWC
-> WorkspaceId
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
buildAndAddController theMap :: Map WorkspaceId WWC
theMap idx :: WorkspaceId
idx =
            ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
-> (WorkspacesIO WWC
    -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> Maybe (WorkspacesIO WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return Map WorkspaceId WWC
theMap) (WorkspacesIO WWC
-> (WWC -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map WorkspaceId WWC
 -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> (WWC -> Map WorkspaceId WWC)
-> WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WWC -> Map WorkspaceId WWC -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> WWC -> Map WorkspaceId WWC
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WorkspaceId -> WWC -> Map WorkspaceId WWC -> Map WorkspaceId WWC
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert WorkspaceId
idx) Map WorkspaceId WWC
theMap)
                    (WorkspaceId -> Maybe (WorkspacesIO WWC)
buildController WorkspaceId
idx)
      (Map WorkspaceId WWC
 -> WorkspaceId
 -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> Map WorkspaceId WWC
-> [WorkspaceId]
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map WorkspaceId WWC
-> WorkspaceId
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
buildAndAddController Map WorkspaceId WWC
oldRemoved ([WorkspaceId]
 -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> [WorkspaceId]
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a b. (a -> b) -> a -> b
$ Set WorkspaceId -> [WorkspaceId]
forall a. Set a -> [a]
Set.toList Set WorkspaceId
addWorkspaces
    -- 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 context :: WorkspacesContext
context =
  let limit :: Integer
limit = (WorkspacesConfig -> Integer
updateRateLimitMicroseconds (WorkspacesConfig -> Integer) -> WorkspacesConfig -> Integer
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
context)
      rate :: Microsecond
rate = Integer -> Microsecond
forall a. TimeUnit a => Integer -> a
fromMicroseconds Integer
limit :: Microsecond in
  RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
forall req resp t.
TimeUnit t =>
RateLimit t
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
generateRateLimitedFunction (RateLimit Microsecond
 -> (req -> IO resp)
 -> ResultsCombiner req resp
 -> IO (req -> IO resp))
-> RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
forall a b. (a -> b) -> a -> b
$ Microsecond -> RateLimit Microsecond
forall a. a -> RateLimit a
PerInvocation Microsecond
rate

onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate context :: WorkspacesContext
context = do
  Event -> IO ()
rateLimited <- WorkspacesContext
-> (Event -> IO ())
-> ResultsCombiner Event ()
-> IO (Event -> IO ())
forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn WorkspacesContext
context Event -> IO ()
doUpdate ResultsCombiner Event ()
forall p a b. p -> a -> Maybe (a, b -> ((), ()))
combineRequests
  let withLog :: Event -> IO ()
withLog event :: Event
event = do
        case Event
event of
          PropertyEvent _ _ _ _ _ atom :: X11Window
atom _ _ ->
            Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Event %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ X11Window -> String
forall a. Show a => a -> String
show X11Window
atom
          _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
rateLimited Event
event
  (Event -> IO ()) -> IO (Event -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return Event -> IO ()
withLog
  where
    combineRequests :: p -> a -> Maybe (a, b -> ((), ()))
combineRequests _ b :: a
b = (a, b -> ((), ())) -> Maybe (a, b -> ((), ()))
forall a. a -> Maybe a
Just (a
b, ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()))
    doUpdate :: Event -> IO ()
doUpdate _ = IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesIO ()
updateAllWorkspaceWidgets WorkspacesContext
context

onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged :: (Set X11Window -> IO ()) -> Event -> IO ()
onIconChanged handler :: Set X11Window -> IO ()
handler event :: Event
event =
  case Event
event of
    PropertyEvent { ev_window :: Event -> X11Window
ev_window = X11Window
wid } -> do
      Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Icon changed event %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ X11Window -> String
forall a. Show a => a -> String
show X11Window
wid
      Set X11Window -> IO ()
handler (Set X11Window -> IO ()) -> Set X11Window -> IO ()
forall a b. (a -> b) -> a -> b
$ X11Window -> Set X11Window
forall a. a -> Set a
Set.singleton X11Window
wid
    _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())
onIconsChanged :: WorkspacesContext -> IO (Set X11Window -> IO ())
onIconsChanged context :: WorkspacesContext
context = WorkspacesContext
-> (Set X11Window -> IO ())
-> ResultsCombiner (Set X11Window) ()
-> IO (Set X11Window -> IO ())
forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn WorkspacesContext
context Set X11Window -> IO ()
onIconsChanged' ResultsCombiner (Set X11Window) ()
forall a b. Ord a => Set a -> Set a -> Maybe (Set a, b -> ((), ()))
combineRequests
  where
    combineRequests :: Set a -> Set a -> Maybe (Set a, b -> ((), ()))
combineRequests windows1 :: Set a
windows1 windows2 :: Set a
windows2 =
      (Set a, b -> ((), ())) -> Maybe (Set a, b -> ((), ()))
forall a. a -> Maybe a
Just (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
windows1 Set a
windows2, ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()))
    onIconsChanged' :: Set X11Window -> IO ()
onIconsChanged' wids :: Set X11Window
wids = do
      Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Icon update execute %s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Set X11Window -> String
forall a. Show a => a -> String
show Set X11Window
wids
      IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
context (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate
          (\idx :: WorkspaceId
idx c :: WWC
c ->
             Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> ShowS
forall r. PrintfType r => String -> r
printf "Updating %s icons." ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> String
forall a. Show a => a -> String
show WorkspaceId
idx) WorkspacesIO () -> WorkspacesIO WWC -> WorkspacesIO WWC
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
             WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget WWC
c ([X11Window] -> WidgetUpdate
IconUpdate ([X11Window] -> WidgetUpdate) -> [X11Window] -> WidgetUpdate
forall a b. (a -> b) -> a -> b
$ Set X11Window -> [X11Window]
forall a. Set a -> [a]
Set.toList Set X11Window
wids))

data WorkspaceContentsController = WorkspaceContentsController
  { WorkspaceContentsController -> Widget
containerWidget :: Gtk.Widget
  , WorkspaceContentsController -> [WWC]
contentsControllers :: [WWC]
  }

buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController constructors :: [ControllerConstructor]
constructors ws :: Workspace
ws = do
  [WWC]
controllers <- (ControllerConstructor -> WorkspacesIO WWC)
-> [ControllerConstructor] -> ReaderT WorkspacesContext IO [WWC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ParentControllerConstructor
forall a b. (a -> b) -> a -> b
$ Workspace
ws) [ControllerConstructor]
constructors
  WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  WorkspaceContentsController
tempController <- IO WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO WorkspaceContentsController
 -> ReaderT WorkspacesContext IO WorkspaceContentsController)
-> IO WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall a b. (a -> b) -> a -> b
$ do
    Box
cons <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal 0
    (WWC -> IO ()) -> [WWC] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((WorkspacesIO Widget -> WorkspacesContext -> IO Widget)
-> WorkspacesContext -> WorkspacesIO Widget -> IO Widget
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO Widget -> WorkspacesContext -> IO Widget
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO Widget -> IO Widget)
-> (WWC -> WorkspacesIO Widget) -> WWC -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget (WWC -> IO Widget) -> (Widget -> IO ()) -> WWC -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
cons) [WWC]
controllers
    Widget
outerBox <- Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
cons IO Widget -> (Widget -> IO Widget) -> IO Widget
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Widget -> IO Widget
forall (m :: * -> *). MonadIO m => Widget -> m Widget
buildPadBox
    Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
cons "contents"
    Widget
widget <- Widget -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Widget
outerBox
    WorkspaceContentsController -> IO WorkspaceContentsController
forall (m :: * -> *) a. Monad m => a -> m a
return
      WorkspaceContentsController :: Widget -> [WWC] -> WorkspaceContentsController
WorkspaceContentsController
      { containerWidget :: Widget
containerWidget = Widget
widget
      , contentsControllers :: [WWC]
contentsControllers = [WWC]
controllers
      }
  WorkspaceContentsController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (WorkspaceContentsController -> WWC)
-> ReaderT WorkspacesContext IO WorkspaceContentsController
-> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceContentsController
-> WidgetUpdate
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget WorkspaceContentsController
tempController (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)

defaultBuildContentsController :: ControllerConstructor
defaultBuildContentsController :: ControllerConstructor
defaultBuildContentsController =
  [ControllerConstructor] -> ControllerConstructor
buildContentsController [ControllerConstructor
buildLabelController, ControllerConstructor
buildIconController]

instance WorkspaceWidgetController WorkspaceContentsController where
  getWidget :: WorkspaceContentsController -> WorkspacesIO Widget
getWidget = Widget -> WorkspacesIO Widget
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget -> WorkspacesIO Widget)
-> (WorkspaceContentsController -> Widget)
-> WorkspaceContentsController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceContentsController -> Widget
containerWidget
  updateWidget :: WorkspaceContentsController
-> WidgetUpdate
-> ReaderT WorkspacesContext IO WorkspaceContentsController
updateWidget cc :: WorkspaceContentsController
cc update :: WidgetUpdate
update = do
    WorkspacesContext {} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    case WidgetUpdate
update of
      WorkspaceUpdate newWorkspace :: Workspace
newWorkspace ->
        IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Workspace -> Widget -> IO ()
forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
Workspace -> a -> m ()
setWorkspaceWidgetStatusClass Workspace
newWorkspace (Widget -> IO ()) -> Widget -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspaceContentsController -> Widget
containerWidget WorkspaceContentsController
cc
      _ -> () -> WorkspacesIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [WWC]
newControllers <- (WWC -> WorkspacesIO WWC)
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
`updateWidget` WidgetUpdate
update) ([WWC] -> ReaderT WorkspacesContext IO [WWC])
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall a b. (a -> b) -> a -> b
$ WorkspaceContentsController -> [WWC]
contentsControllers WorkspaceContentsController
cc
    WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceContentsController
cc {contentsControllers :: [WWC]
contentsControllers = [WWC]
newControllers}
  updateWidgetX11 :: WorkspaceContentsController
-> WidgetUpdate
-> ReaderT WorkspacesContext IO WorkspaceContentsController
updateWidgetX11 cc :: WorkspaceContentsController
cc update :: WidgetUpdate
update = do
    [WWC]
newControllers <- (WWC -> WorkspacesIO WWC)
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
`updateWidgetX11` WidgetUpdate
update) ([WWC] -> ReaderT WorkspacesContext IO [WWC])
-> [WWC] -> ReaderT WorkspacesContext IO [WWC]
forall a b. (a -> b) -> a -> b
$ WorkspaceContentsController -> [WWC]
contentsControllers WorkspaceContentsController
cc
    WorkspaceContentsController
-> ReaderT WorkspacesContext IO WorkspaceContentsController
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceContentsController
cc {contentsControllers :: [WWC]
contentsControllers = [WWC]
newControllers}

newtype LabelController = LabelController { LabelController -> Label
label :: Gtk.Label }

buildLabelController :: ControllerConstructor
buildLabelController :: ControllerConstructor
buildLabelController ws :: Workspace
ws = do
  LabelController
tempController <- IO LabelController -> ReaderT WorkspacesContext IO LabelController
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO LabelController
 -> ReaderT WorkspacesContext IO LabelController)
-> IO LabelController
-> ReaderT WorkspacesContext IO LabelController
forall a b. (a -> b) -> a -> b
$ do
    Label
lbl <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew Maybe Text
forall a. Maybe a
Nothing
    Label
_ <- Label -> Text -> IO Label
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Label
lbl "workspace-label"
    LabelController -> IO LabelController
forall (m :: * -> *) a. Monad m => a -> m a
return LabelController :: Label -> LabelController
LabelController { label :: Label
label = Label
lbl }
  LabelController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (LabelController -> WWC)
-> ReaderT WorkspacesContext IO LabelController -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LabelController
-> WidgetUpdate -> ReaderT WorkspacesContext IO LabelController
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget LabelController
tempController (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)

instance WorkspaceWidgetController LabelController where
  getWidget :: LabelController -> WorkspacesIO Widget
getWidget = IO Widget -> WorkspacesIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> (LabelController -> IO Widget)
-> LabelController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (Label -> IO Widget)
-> (LabelController -> Label) -> LabelController -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelController -> Label
label
  updateWidget :: LabelController
-> WidgetUpdate -> ReaderT WorkspacesContext IO LabelController
updateWidget lc :: LabelController
lc (WorkspaceUpdate newWorkspace :: Workspace
newWorkspace) = do
    WorkspacesContext { workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    String
labelText <- WorkspacesConfig -> Workspace -> WorkspacesIO String
labelSetter WorkspacesConfig
cfg Workspace
newWorkspace
    IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ do
      Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
Gtk.labelSetMarkup (LabelController -> Label
label LabelController
lc) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
labelText
      Workspace -> Label -> IO ()
forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
Workspace -> a -> m ()
setWorkspaceWidgetStatusClass Workspace
newWorkspace (Label -> IO ()) -> Label -> IO ()
forall a b. (a -> b) -> a -> b
$ LabelController -> Label
label LabelController
lc
    LabelController -> ReaderT WorkspacesContext IO LabelController
forall (m :: * -> *) a. Monad m => a -> m a
return LabelController
lc
  updateWidget lc :: LabelController
lc _ = LabelController -> ReaderT WorkspacesContext IO LabelController
forall (m :: * -> *) a. Monad m => a -> m a
return LabelController
lc

data IconWidget = IconWidget
  { IconWidget -> EventBox
iconContainer :: Gtk.EventBox
  , IconWidget -> Image
iconImage :: Gtk.Image
  , IconWidget -> MVar (Maybe WindowData)
iconWindow :: MV.MVar (Maybe WindowData)
  , IconWidget -> IO ()
iconForceUpdate :: IO ()
  }

getPixbufForIconWidget :: Bool
                       -> MV.MVar (Maybe WindowData)
                       -> Int32
                       -> WorkspacesIO (Maybe Gdk.Pixbuf)
getPixbufForIconWidget :: Bool
-> MVar (Maybe WindowData) -> Int32 -> WorkspacesIO (Maybe Pixbuf)
getPixbufForIconWidget transparentOnNone :: Bool
transparentOnNone dataVar :: MVar (Maybe WindowData)
dataVar size :: Int32
size = do
  WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let tContext :: Context
tContext = WorkspacesContext -> Context
taffyContext WorkspacesContext
ctx
      getPBFromData :: WindowIconPixbufGetter
getPBFromData = WorkspacesConfig -> WindowIconPixbufGetter
getWindowIconPixbuf (WorkspacesConfig -> WindowIconPixbufGetter)
-> WorkspacesConfig -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
ctx
      getPB' :: ReaderT Context IO (Maybe Pixbuf)
getPB' = MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT Context IO) Pixbuf
 -> ReaderT Context IO (Maybe Pixbuf))
-> MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$
               ReaderT Context IO (Maybe WindowData)
-> MaybeT (ReaderT Context IO) WindowData
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe WindowData) -> ReaderT Context IO (Maybe WindowData)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe WindowData) -> ReaderT Context IO (Maybe WindowData))
-> IO (Maybe WindowData) -> ReaderT Context IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a. MVar a -> IO a
MV.readMVar MVar (Maybe WindowData)
dataVar) MaybeT (ReaderT Context IO) WindowData
-> (WindowData -> MaybeT (ReaderT Context IO) Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Context IO (Maybe Pixbuf)
-> MaybeT (ReaderT Context IO) Pixbuf
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ReaderT Context IO (Maybe Pixbuf)
 -> MaybeT (ReaderT Context IO) Pixbuf)
-> (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowData
-> MaybeT (ReaderT Context IO) Pixbuf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowIconPixbufGetter
getPBFromData Int32
size
      getPB :: ReaderT Context IO (Maybe Pixbuf)
getPB = if Bool
transparentOnNone
              then ReaderT Context IO (Maybe Pixbuf)
-> ReaderT Context IO (Maybe Pixbuf)
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
maybeTCombine ReaderT Context IO (Maybe Pixbuf)
getPB' (Pixbuf -> Maybe Pixbuf
forall a. a -> Maybe a
Just (Pixbuf -> Maybe Pixbuf)
-> ReaderT Context IO Pixbuf -> ReaderT Context IO (Maybe Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> Word32 -> ReaderT Context IO Pixbuf
forall (m :: * -> *). MonadIO m => Int32 -> Word32 -> m Pixbuf
pixBufFromColor Int32
size 0)
              else ReaderT Context IO (Maybe Pixbuf)
getPB'
  IO (Maybe Pixbuf) -> WorkspacesIO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> WorkspacesIO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> WorkspacesIO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ ReaderT Context IO (Maybe Pixbuf) -> Context -> IO (Maybe Pixbuf)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Context IO (Maybe Pixbuf)
getPB Context
tContext

buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget transparentOnNone :: Bool
transparentOnNone ws :: Workspace
ws = do
  WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO IconWidget -> WorkspacesIO IconWidget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO IconWidget -> WorkspacesIO IconWidget)
-> IO IconWidget -> WorkspacesIO IconWidget
forall a b. (a -> b) -> a -> b
$ do
    MVar (Maybe WindowData)
windowVar <- Maybe WindowData -> IO (MVar (Maybe WindowData))
forall a. a -> IO (MVar a)
MV.newMVar Maybe WindowData
forall a. Maybe a
Nothing
    Image
img <- IO Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew
    IO ()
refreshImage <-
      Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> IO (IO ())
forall (m :: * -> *).
MonadIO m =>
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
autoSizeImage Image
img
        ((WorkspacesIO (Maybe Pixbuf)
 -> WorkspacesContext -> IO (Maybe Pixbuf))
-> WorkspacesContext
-> WorkspacesIO (Maybe Pixbuf)
-> IO (Maybe Pixbuf)
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO (Maybe Pixbuf)
-> WorkspacesContext -> IO (Maybe Pixbuf)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO (Maybe Pixbuf) -> IO (Maybe Pixbuf))
-> (Int32 -> WorkspacesIO (Maybe Pixbuf))
-> Int32
-> IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> MVar (Maybe WindowData) -> Int32 -> WorkspacesIO (Maybe Pixbuf)
getPixbufForIconWidget Bool
transparentOnNone MVar (Maybe WindowData)
windowVar)
        Orientation
Gtk.OrientationHorizontal
    EventBox
ebox <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
    Image
_ <- Image -> Text -> IO Image
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Image
img "window-icon"
    EventBox
_ <- EventBox -> Text -> IO EventBox
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI EventBox
ebox "window-icon-container"
    EventBox -> Image -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
ebox Image
img
    SignalHandlerId
_ <-
      EventBox -> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
ebox (WidgetButtonPressEventCallback -> IO SignalHandlerId)
-> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
      IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const (IO Bool -> WidgetButtonPressEventCallback)
-> IO Bool -> WidgetButtonPressEventCallback
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        Maybe WindowData
info <- MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a. MVar a -> IO a
MV.readMVar MVar (Maybe WindowData)
windowVar
        case Maybe WindowData
info of
          Just updatedInfo :: WindowData
updatedInfo ->
            (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            () -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def () (X11Property () -> WorkspacesIO ())
-> X11Property () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ X11Window -> X11Property ()
focusWindow (X11Window -> X11Property ()) -> X11Window -> X11Property ()
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
updatedInfo
          _ -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspaceId -> IO Bool
forall (m :: * -> *).
MonadIO m =>
WorkspacesContext -> WorkspaceId -> m Bool
switch WorkspacesContext
ctx (Workspace -> WorkspaceId
workspaceIdx Workspace
ws)
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    IconWidget -> IO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return
      IconWidget :: EventBox -> Image -> MVar (Maybe WindowData) -> IO () -> IconWidget
IconWidget
      { iconContainer :: EventBox
iconContainer = EventBox
ebox
      , iconImage :: Image
iconImage = Image
img
      , iconWindow :: MVar (Maybe WindowData)
iconWindow = MVar (Maybe WindowData)
windowVar
      , iconForceUpdate :: IO ()
iconForceUpdate = IO ()
refreshImage
      }

data IconController = IconController
  { IconController -> Box
iconsContainer :: Gtk.Box
  , IconController -> [IconWidget]
iconImages :: [IconWidget]
  , IconController -> Workspace
iconWorkspace :: Workspace
  }

buildIconController :: ControllerConstructor
buildIconController :: ControllerConstructor
buildIconController ws :: Workspace
ws = do
  IconController
tempController <-
    IO IconController -> ReaderT WorkspacesContext IO IconController
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO IconController -> ReaderT WorkspacesContext IO IconController)
-> IO IconController -> ReaderT WorkspacesContext IO IconController
forall a b. (a -> b) -> a -> b
$ do
      Box
hbox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal 0
      IconController -> IO IconController
forall (m :: * -> *) a. Monad m => a -> m a
return
        IconController :: Box -> [IconWidget] -> Workspace -> IconController
IconController
        {iconsContainer :: Box
iconsContainer = Box
hbox, iconImages :: [IconWidget]
iconImages = [], iconWorkspace :: Workspace
iconWorkspace = Workspace
ws}
  IconController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC (IconController -> WWC)
-> ReaderT WorkspacesContext IO IconController -> WorkspacesIO WWC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IconController
-> WidgetUpdate -> ReaderT WorkspacesContext IO IconController
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget IconController
tempController (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)

instance WorkspaceWidgetController IconController where
  getWidget :: IconController -> WorkspacesIO Widget
getWidget = IO Widget -> WorkspacesIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> (IconController -> IO Widget)
-> IconController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (Box -> IO Widget)
-> (IconController -> Box) -> IconController -> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IconController -> Box
iconsContainer
  updateWidget :: IconController
-> WidgetUpdate -> ReaderT WorkspacesContext IO IconController
updateWidget ic :: IconController
ic (WorkspaceUpdate newWorkspace :: Workspace
newWorkspace) = do
    [IconWidget]
newImages <- IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages IconController
ic Workspace
newWorkspace
    IconController -> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a. Monad m => a -> m a
return IconController
ic { iconImages :: [IconWidget]
iconImages = [IconWidget]
newImages, iconWorkspace :: Workspace
iconWorkspace = Workspace
newWorkspace }
  updateWidget ic :: IconController
ic (IconUpdate updatedIcons :: [X11Window]
updatedIcons) =
    IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById IconController
ic [X11Window]
updatedIcons WorkspacesIO ()
-> ReaderT WorkspacesContext IO IconController
-> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IconController -> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a. Monad m => a -> m a
return IconController
ic

updateWindowIconsById ::
  IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById :: IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById ic :: IconController
ic windowIds :: [X11Window]
windowIds =
  (IconWidget -> WorkspacesIO ()) -> [IconWidget] -> WorkspacesIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ IconWidget -> WorkspacesIO ()
maybeUpdateWindowIcon ([IconWidget] -> WorkspacesIO ())
-> [IconWidget] -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ IconController -> [IconWidget]
iconImages IconController
ic
  where
    maybeUpdateWindowIcon :: IconWidget -> WorkspacesIO ()
maybeUpdateWindowIcon widget :: IconWidget
widget =
      do
        Maybe WindowData
info <- IO (Maybe WindowData)
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe WindowData)
 -> ReaderT WorkspacesContext IO (Maybe WindowData))
-> IO (Maybe WindowData)
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a. MVar a -> IO a
MV.readMVar (MVar (Maybe WindowData) -> IO (Maybe WindowData))
-> MVar (Maybe WindowData) -> IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ IconWidget -> MVar (Maybe WindowData)
iconWindow IconWidget
widget
        Bool -> WorkspacesIO () -> WorkspacesIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> (WindowData -> Bool) -> Maybe WindowData -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((X11Window -> [X11Window] -> Bool)
-> [X11Window] -> X11Window -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip X11Window -> [X11Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [X11Window]
windowIds (X11Window -> Bool)
-> (WindowData -> X11Window) -> WindowData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowData -> X11Window
windowId) Maybe WindowData
info) (WorkspacesIO () -> WorkspacesIO ())
-> WorkspacesIO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$
         IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget IconController
ic IconWidget
widget Maybe WindowData
info

scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter getter :: WindowIconPixbufGetter
getter size :: Int32
size =
  WindowIconPixbufGetter
getter Int32
size (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> (Maybe Pixbuf -> ReaderT Context IO (Maybe Pixbuf))
-> WindowData
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
  IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> (Maybe Pixbuf -> IO (Maybe Pixbuf))
-> Maybe Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
Gtk.OrientationHorizontal)

constantScaleWindowIconPixbufGetter ::
  Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter
constantScaleWindowIconPixbufGetter :: Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter
constantScaleWindowIconPixbufGetter constantSize :: Int32
constantSize getter :: WindowIconPixbufGetter
getter =
  (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
forall a b. a -> b -> a
const ((WindowData -> ReaderT Context IO (Maybe Pixbuf))
 -> WindowIconPixbufGetter)
-> (WindowData -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter WindowIconPixbufGetter
getter Int32
constantSize

getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter
getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter
getWindowIconPixbufFromEWMH size :: Int32
size windowData :: WindowData
windowData =
  Maybe Pixbuf
-> X11Property (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a. a -> X11Property a -> TaffyIO a
runX11Def Maybe Pixbuf
forall a. Maybe a
Nothing (Int32 -> X11Window -> X11Property (Maybe Pixbuf)
getIconPixBufFromEWMH Int32
size (X11Window -> X11Property (Maybe Pixbuf))
-> X11Window -> X11Property (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
windowData)

getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass size :: Int32
size windowData :: WindowData
windowData =
  IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ Int32 -> String -> IO (Maybe Pixbuf)
getWindowIconFromClasses Int32
size (WindowData -> String
windowClass WindowData
windowData)

getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry size :: Int32
size windowData :: WindowData
windowData =
  Int32 -> String -> ReaderT Context IO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClasses Int32
size (WindowData -> String
windowClass WindowData
windowData)

getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome :: WindowIconPixbufGetter
getWindowIconPixbufFromChrome _ windowData :: WindowData
windowData =
  X11Window -> ReaderT Context IO (Maybe Pixbuf)
getPixBufFromChromeData (X11Window -> ReaderT Context IO (Maybe Pixbuf))
-> X11Window -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
windowData

defaultGetWindowIconPixbuf :: WindowIconPixbufGetter
defaultGetWindowIconPixbuf :: WindowIconPixbufGetter
defaultGetWindowIconPixbuf =
  WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf

unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf =
  WindowIconPixbufGetter
getWindowIconPixbufFromDesktopEntry WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||>
  WindowIconPixbufGetter
getWindowIconPixbufFromClass WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||>
  WindowIconPixbufGetter
getWindowIconPixbufFromEWMH

addCustomIconsToDefaultWithFallbackByPath
  :: (WindowData -> Maybe FilePath)
  -> FilePath
  -> WindowIconPixbufGetter
addCustomIconsToDefaultWithFallbackByPath :: (WindowData -> Maybe String) -> String -> WindowIconPixbufGetter
addCustomIconsToDefaultWithFallbackByPath getCustomIconPath :: WindowData -> Maybe String
getCustomIconPath fallbackPath :: String
fallbackPath =
  (WindowData -> Maybe String)
-> (Int32 -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
-> WindowIconPixbufGetter
addCustomIconsAndFallback
    WindowData -> Maybe String
getCustomIconPath
    (ReaderT Context IO (Maybe Pixbuf)
-> Int32 -> ReaderT Context IO (Maybe Pixbuf)
forall a b. a -> b -> a
const (ReaderT Context IO (Maybe Pixbuf)
 -> Int32 -> ReaderT Context IO (Maybe Pixbuf))
-> ReaderT Context IO (Maybe Pixbuf)
-> Int32
-> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Pixbuf)
getPixbufFromFilePath String
fallbackPath)
    WindowIconPixbufGetter
unscaledDefaultGetWindowIconPixbuf

addCustomIconsAndFallback
  :: (WindowData -> Maybe FilePath)
  -> (Int32 -> TaffyIO (Maybe Gdk.Pixbuf))
  -> WindowIconPixbufGetter
  -> WindowIconPixbufGetter
addCustomIconsAndFallback :: (WindowData -> Maybe String)
-> (Int32 -> ReaderT Context IO (Maybe Pixbuf))
-> WindowIconPixbufGetter
-> WindowIconPixbufGetter
addCustomIconsAndFallback getCustomIconPath :: WindowData -> Maybe String
getCustomIconPath fallback :: Int32 -> ReaderT Context IO (Maybe Pixbuf)
fallback defaultGetter :: WindowIconPixbufGetter
defaultGetter =
  WindowIconPixbufGetter -> WindowIconPixbufGetter
scaledWindowIconPixbufGetter (WindowIconPixbufGetter -> WindowIconPixbufGetter)
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$
  WindowIconPixbufGetter
getCustomIcon WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||> WindowIconPixbufGetter
defaultGetter WindowIconPixbufGetter
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall (m :: * -> *) t t1 a.
Monad m =>
(t -> t1 -> m (Maybe a))
-> (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe a)
<|||> (\s :: Int32
s _ -> Int32 -> ReaderT Context IO (Maybe Pixbuf)
fallback Int32
s)
  where
    getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf)
    getCustomIcon :: WindowIconPixbufGetter
getCustomIcon _ wdata :: WindowData
wdata =
      IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$
      IO (Maybe Pixbuf)
-> (String -> IO (Maybe Pixbuf))
-> Maybe String
-> IO (Maybe Pixbuf)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pixbuf
forall a. Maybe a
Nothing) String -> IO (Maybe Pixbuf)
getPixbufFromFilePath (Maybe String -> IO (Maybe Pixbuf))
-> Maybe String -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ WindowData -> Maybe String
getCustomIconPath WindowData
wdata

sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition wins :: [WindowData]
wins = do
  let getGeometryWorkspaces :: X11Window
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
getGeometryWorkspaces w :: X11Window
w = X11Property Display
getDisplay X11Property Display
-> (Display
    -> ReaderT
         X11Context
         IO
         (X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
 -> ReaderT
      X11Context
      IO
      (X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> (Display
    -> IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> Display
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Display
-> X11Window
-> IO (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
`safeGetGeometry` X11Window
w)
      getGeometries :: ReaderT X11Context IO [(X11Window, (Int32, Int32))]
getGeometries = (WindowData -> ReaderT X11Context IO (X11Window, (Int32, Int32)))
-> [WindowData]
-> ReaderT X11Context IO [(X11Window, (Int32, Int32))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
                      ((X11Window -> ReaderT X11Context IO X11Window)
-> (X11Window -> ReaderT X11Context IO (Int32, Int32))
-> X11Window
-> ReaderT X11Context IO (X11Window, (Int32, Int32))
forall (m :: * -> *) c a b.
Monad m =>
(c -> m a) -> (c -> m b) -> c -> m (a, b)
forkM X11Window -> ReaderT X11Context IO X11Window
forall (m :: * -> *) a. Monad m => a -> m a
return
                               (((((X11Window, Int32, Int32, Word32, Word32, Word32, CInt) -> Int32
forall a b. Sel2 a b => a -> b
sel2 ((X11Window, Int32, Int32, Word32, Word32, Word32, CInt) -> Int32)
-> ((X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
    -> Int32)
-> (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> (Int32, Int32)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (X11Window, Int32, Int32, Word32, Word32, Word32, CInt) -> Int32
forall a b. Sel3 a b => a -> b
sel3) ((X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
 -> (Int32, Int32))
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
-> ReaderT X11Context IO (Int32, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ReaderT
   X11Context
   IO
   (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
 -> ReaderT X11Context IO (Int32, Int32))
-> (X11Window
    -> ReaderT
         X11Context
         IO
         (X11Window, Int32, Int32, Word32, Word32, Word32, CInt))
-> X11Window
-> ReaderT X11Context IO (Int32, Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) X11Window
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
getGeometryWorkspaces) (X11Window -> ReaderT X11Context IO (X11Window, (Int32, Int32)))
-> (WindowData -> X11Window)
-> WindowData
-> ReaderT X11Context IO (X11Window, (Int32, Int32))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               WindowData -> X11Window
windowId)
                      [WindowData]
wins
  [(X11Window, (Int32, Int32))]
windowGeometries <- [(X11Window, (Int32, Int32))]
-> ReaderT X11Context IO [(X11Window, (Int32, Int32))]
-> WorkspacesIO [(X11Window, (Int32, Int32))]
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def [] ReaderT X11Context IO [(X11Window, (Int32, Int32))]
getGeometries
  let getLeftPos :: WindowData -> (Int32, Int32)
getLeftPos wd :: WindowData
wd =
        (Int32, Int32) -> Maybe (Int32, Int32) -> (Int32, Int32)
forall a. a -> Maybe a -> a
fromMaybe (999999999, 99999999) (Maybe (Int32, Int32) -> (Int32, Int32))
-> Maybe (Int32, Int32) -> (Int32, Int32)
forall a b. (a -> b) -> a -> b
$ X11Window -> [(X11Window, (Int32, Int32))] -> Maybe (Int32, Int32)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (WindowData -> X11Window
windowId WindowData
wd) [(X11Window, (Int32, Int32))]
windowGeometries
      compareWindowData :: WindowData -> WindowData -> Ordering
compareWindowData a :: WindowData
a b :: WindowData
b =
        (Bool, (Int32, Int32)) -> (Bool, (Int32, Int32)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
          (WindowData -> Bool
windowMinimized WindowData
a, WindowData -> (Int32, Int32)
getLeftPos WindowData
a)
          (WindowData -> Bool
windowMinimized WindowData
b, WindowData -> (Int32, Int32)
getLeftPos WindowData
b)
  [WindowData] -> WorkspacesIO [WindowData]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WindowData] -> WorkspacesIO [WindowData])
-> [WindowData] -> WorkspacesIO [WindowData]
forall a b. (a -> b) -> a -> b
$ (WindowData -> WindowData -> Ordering)
-> [WindowData] -> [WindowData]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy WindowData -> WindowData -> Ordering
compareWindowData [WindowData]
wins

updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages ic :: IconController
ic ws :: Workspace
ws = do
  WorkspacesContext {workspacesConfig :: WorkspacesContext -> WorkspacesConfig
workspacesConfig = WorkspacesConfig
cfg} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  [WindowData]
sortedWindows <- WorkspacesConfig -> [WindowData] -> WorkspacesIO [WindowData]
iconSort WorkspacesConfig
cfg ([WindowData] -> WorkspacesIO [WindowData])
-> [WindowData] -> WorkspacesIO [WindowData]
forall a b. (a -> b) -> a -> b
$ Workspace -> [WindowData]
windows Workspace
ws
  Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> WorkspacesIO ()) -> String -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf "Updating images for %s" (Workspace -> String
forall a. Show a => a -> String
show Workspace
ws)
  let updateIconWidget' :: WorkspacesIO IconWidget
-> Maybe WindowData -> WorkspacesIO IconWidget
updateIconWidget' getImageAction :: WorkspacesIO IconWidget
getImageAction wdata :: Maybe WindowData
wdata = do
        IconWidget
iconWidget <- WorkspacesIO IconWidget
getImageAction
        ()
_ <- IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget IconController
ic IconWidget
iconWidget Maybe WindowData
wdata
        IconWidget -> WorkspacesIO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return IconWidget
iconWidget
      existingImages :: [WorkspacesIO IconWidget]
existingImages = (IconWidget -> WorkspacesIO IconWidget)
-> [IconWidget] -> [WorkspacesIO IconWidget]
forall a b. (a -> b) -> [a] -> [b]
map IconWidget -> WorkspacesIO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return ([IconWidget] -> [WorkspacesIO IconWidget])
-> [IconWidget] -> [WorkspacesIO IconWidget]
forall a b. (a -> b) -> a -> b
$ IconController -> [IconWidget]
iconImages IconController
ic
      buildAndAddIconWidget :: Bool -> WorkspacesIO IconWidget
buildAndAddIconWidget transparentOnNone :: Bool
transparentOnNone = do
        IconWidget
iw <- Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget Bool
transparentOnNone Workspace
ws
        IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ Box -> EventBox -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd (IconController -> Box
iconsContainer IconController
ic) (EventBox -> IO ()) -> EventBox -> IO ()
forall a b. (a -> b) -> a -> b
$ IconWidget -> EventBox
iconContainer IconWidget
iw
        IconWidget -> WorkspacesIO IconWidget
forall (m :: * -> *) a. Monad m => a -> m a
return IconWidget
iw
      infiniteImages :: [WorkspacesIO IconWidget]
infiniteImages =
        [WorkspacesIO IconWidget]
existingImages [WorkspacesIO IconWidget]
-> [WorkspacesIO IconWidget] -> [WorkspacesIO IconWidget]
forall a. [a] -> [a] -> [a]
++
        Int -> WorkspacesIO IconWidget -> [WorkspacesIO IconWidget]
forall a. Int -> a -> [a]
replicate (WorkspacesConfig -> Int
minIcons WorkspacesConfig
cfg Int -> Int -> Int
forall a. Num a => a -> a -> a
- [WorkspacesIO IconWidget] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WorkspacesIO IconWidget]
existingImages)
                  (Bool -> WorkspacesIO IconWidget
buildAndAddIconWidget Bool
True) [WorkspacesIO IconWidget]
-> [WorkspacesIO IconWidget] -> [WorkspacesIO IconWidget]
forall a. [a] -> [a] -> [a]
++
        WorkspacesIO IconWidget -> [WorkspacesIO IconWidget]
forall a. a -> [a]
repeat (Bool -> WorkspacesIO IconWidget
buildAndAddIconWidget Bool
False)
      windowCount :: Int
windowCount = [WindowData] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([WindowData] -> Int) -> [WindowData] -> Int
forall a b. (a -> b) -> a -> b
$ Workspace -> [WindowData]
windows Workspace
ws
      maxNeeded :: Int
maxNeeded = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
windowCount (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
windowCount) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ WorkspacesConfig -> Maybe Int
maxIcons WorkspacesConfig
cfg
      newImagesNeeded :: Bool
newImagesNeeded = [WorkspacesIO IconWidget] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WorkspacesIO IconWidget]
existingImages Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (WorkspacesConfig -> Int
minIcons WorkspacesConfig
cfg) Int
maxNeeded
      -- 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
windowData = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
  case WindowData
windowData of
    WindowData { windowMinimized :: WindowData -> Bool
windowMinimized = Bool
True } -> "minimized"
    WindowData { windowActive :: WindowData -> Bool
windowActive = Bool
True } -> WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Active
    WindowData { windowUrgent :: WindowData -> Bool
windowUrgent = Bool
True } -> WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Urgent
    _ -> "normal"

possibleStatusStrings :: [T.Text]
possibleStatusStrings :: [Text]
possibleStatusStrings =
  (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
    (Text -> Text
T.toLower (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
    [WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Active, WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Urgent, "minimized", "normal", "inactive"]

updateIconWidget
  :: IconController
  -> IconWidget
  -> Maybe WindowData
  -> WorkspacesIO ()
updateIconWidget :: IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget _ IconWidget
                   { iconContainer :: IconWidget -> EventBox
iconContainer = EventBox
iconButton
                   , iconWindow :: IconWidget -> MVar (Maybe WindowData)
iconWindow = MVar (Maybe WindowData)
windowRef
                   , iconForceUpdate :: IconWidget -> IO ()
iconForceUpdate = IO ()
updateIcon
                   } windowData :: Maybe WindowData
windowData = do
  let statusString :: Text
statusString = Text -> (WindowData -> Text) -> Maybe WindowData -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "inactive" WindowData -> Text
getWindowStatusString Maybe WindowData
windowData :: T.Text
      setIconWidgetProperties :: IO ()
setIconWidgetProperties =
        EventBox -> [Text] -> [Text] -> IO ()
forall (t1 :: * -> *) (t :: * -> *) a (m :: * -> *).
(Foldable t1, Foldable t, IsWidget a, MonadIO m) =>
a -> t1 Text -> t Text -> m ()
updateWidgetClasses EventBox
iconButton [Text
statusString] [Text]
possibleStatusStrings
  ReaderT WorkspacesContext IO (Maybe WindowData) -> WorkspacesIO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT WorkspacesContext IO (Maybe WindowData)
 -> WorkspacesIO ())
-> ReaderT WorkspacesContext IO (Maybe WindowData)
-> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe WindowData)
-> (Maybe WindowData
    -> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a. MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a
updateVar MVar (Maybe WindowData)
windowRef ((Maybe WindowData
  -> ReaderT WorkspacesContext IO (Maybe WindowData))
 -> ReaderT WorkspacesContext IO (Maybe WindowData))
-> (Maybe WindowData
    -> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ ReaderT WorkspacesContext IO (Maybe WindowData)
-> Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. a -> b -> a
const (ReaderT WorkspacesContext IO (Maybe WindowData)
 -> Maybe WindowData
 -> ReaderT WorkspacesContext IO (Maybe WindowData))
-> ReaderT WorkspacesContext IO (Maybe WindowData)
-> Maybe WindowData
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$ Maybe WindowData -> ReaderT WorkspacesContext IO (Maybe WindowData)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WindowData
windowData
  IO () -> WorkspacesIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> WorkspacesIO ()) -> IO () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ IO ()
updateIcon IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
setIconWidgetProperties

data WorkspaceButtonController = WorkspaceButtonController
  { WorkspaceButtonController -> EventBox
button :: Gtk.EventBox
  , WorkspaceButtonController -> Workspace
buttonWorkspace :: Workspace
  , WorkspaceButtonController -> WWC
contentsController :: WWC
  }

buildButtonController :: ParentControllerConstructor
buildButtonController :: ParentControllerConstructor
buildButtonController contentsBuilder :: ControllerConstructor
contentsBuilder workspace :: Workspace
workspace = do
  WWC
cc <- ControllerConstructor
contentsBuilder Workspace
workspace
  MVar (Map WorkspaceId Workspace)
workspacesRef <- (WorkspacesContext -> MVar (Map WorkspaceId Workspace))
-> ReaderT WorkspacesContext IO (MVar (Map WorkspaceId Workspace))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> MVar (Map WorkspaceId Workspace)
workspacesVar
  WorkspacesContext
ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Widget
widget <- WWC -> WorkspacesIO Widget
forall wc.
WorkspaceWidgetController wc =>
wc -> WorkspacesIO Widget
getWidget WWC
cc
  IO WWC -> WorkspacesIO WWC
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO WWC -> WorkspacesIO WWC) -> IO WWC -> WorkspacesIO WWC
forall a b. (a -> b) -> a -> b
$ do
    EventBox
ebox <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
    EventBox -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
ebox Widget
widget
    EventBox -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsEventBox a) =>
a -> Bool -> m ()
Gtk.eventBoxSetVisibleWindow EventBox
ebox Bool
False
    SignalHandlerId
_ <-
      EventBox -> WidgetScrollEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetScrollEventCallback -> m SignalHandlerId
Gtk.onWidgetScrollEvent EventBox
ebox (WidgetScrollEventCallback -> IO SignalHandlerId)
-> WidgetScrollEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \scrollEvent :: EventScroll
scrollEvent -> do
        ScrollDirection
dir <- EventScroll -> IO ScrollDirection
forall (m :: * -> *). MonadIO m => EventScroll -> m ScrollDirection
Gdk.getEventScrollDirection EventScroll
scrollEvent
        Map WorkspaceId Workspace
workspaces <- IO (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace))
-> IO (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a b. (a -> b) -> a -> b
$ MVar (Map WorkspaceId Workspace) -> IO (Map WorkspaceId Workspace)
forall a. MVar a -> IO a
MV.readMVar MVar (Map WorkspaceId Workspace)
workspacesRef
        let switchOne :: Bool -> IO Bool
switchOne a :: Bool
a =
              IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
              (ReaderT WorkspacesContext IO Bool -> WorkspacesContext -> IO Bool)
-> WorkspacesContext
-> ReaderT WorkspacesContext IO Bool
-> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT WorkspacesContext IO Bool -> WorkspacesContext -> IO Bool
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (ReaderT WorkspacesContext IO Bool -> IO Bool)
-> ReaderT WorkspacesContext IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
              () -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def
                ()
                (Bool -> Int -> X11Property ()
switchOneWorkspace Bool
a ([(WorkspaceId, Workspace)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map WorkspaceId Workspace -> [(WorkspaceId, Workspace)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorkspaceId Workspace
workspaces) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) WorkspacesIO ()
-> ReaderT WorkspacesContext IO Bool
-> ReaderT WorkspacesContext IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              Bool -> ReaderT WorkspacesContext IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        case ScrollDirection
dir of
          Gdk.ScrollDirectionUp -> Bool -> IO Bool
switchOne Bool
True
          Gdk.ScrollDirectionLeft -> Bool -> IO Bool
switchOne Bool
True
          Gdk.ScrollDirectionDown -> Bool -> IO Bool
switchOne Bool
False
          Gdk.ScrollDirectionRight -> Bool -> IO Bool
switchOne Bool
False
          _ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    SignalHandlerId
_ <- EventBox -> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
ebox (WidgetButtonPressEventCallback -> IO SignalHandlerId)
-> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const (IO Bool -> WidgetButtonPressEventCallback)
-> IO Bool -> WidgetButtonPressEventCallback
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspaceId -> IO Bool
forall (m :: * -> *).
MonadIO m =>
WorkspacesContext -> WorkspaceId -> m Bool
switch WorkspacesContext
ctx (WorkspaceId -> IO Bool) -> WorkspaceId -> IO Bool
forall a b. (a -> b) -> a -> b
$ Workspace -> WorkspaceId
workspaceIdx Workspace
workspace
    WWC -> IO WWC
forall (m :: * -> *) a. Monad m => a -> m a
return (WWC -> IO WWC) -> WWC -> IO WWC
forall a b. (a -> b) -> a -> b
$
      WorkspaceButtonController -> WWC
forall a. WorkspaceWidgetController a => a -> WWC
WWC
        WorkspaceButtonController :: EventBox -> Workspace -> WWC -> WorkspaceButtonController
WorkspaceButtonController
        {button :: EventBox
button = EventBox
ebox, buttonWorkspace :: Workspace
buttonWorkspace = Workspace
workspace, contentsController :: WWC
contentsController = WWC
cc}

switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool
switch :: WorkspacesContext -> WorkspaceId -> m Bool
switch ctx :: WorkspacesContext
ctx idx :: WorkspaceId
idx = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def () (X11Property () -> WorkspacesIO ())
-> X11Property () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> X11Property ()
switchToWorkspace WorkspaceId
idx
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

instance WorkspaceWidgetController WorkspaceButtonController
  where
    getWidget :: WorkspaceButtonController -> WorkspacesIO Widget
getWidget wbc :: WorkspaceButtonController
wbc = IO Widget -> WorkspacesIO Widget
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> IO Widget -> WorkspacesIO Widget
forall a b. (a -> b) -> a -> b
$ EventBox -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (EventBox -> IO Widget) -> EventBox -> IO Widget
forall a b. (a -> b) -> a -> b
$ WorkspaceButtonController -> EventBox
button WorkspaceButtonController
wbc
    updateWidget :: WorkspaceButtonController
-> WidgetUpdate -> WorkspacesIO WorkspaceButtonController
updateWidget wbc :: WorkspaceButtonController
wbc update :: WidgetUpdate
update = do
      WWC
newContents <- WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget (WorkspaceButtonController -> WWC
contentsController WorkspaceButtonController
wbc) WidgetUpdate
update
      WorkspaceButtonController -> WorkspacesIO WorkspaceButtonController
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceButtonController
wbc { contentsController :: WWC
contentsController = WWC
newContents }