{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings, StrictData #-}
-----------------------------------------------------------------------------
-- |
-- 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.Arrow ((&&&))
import           Control.Concurrent
import qualified Control.Concurrent.MVar as MV
import           Control.Exception.Enclosed (catchAny)
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Reader
import           Control.RateLimit
import           Data.Default (Default(..))
import qualified Data.Foldable as F
import           Data.GI.Base.ManagedPtr (unsafeCastTo)
import           Data.Int
import           Data.List (elemIndex, intersect, sortBy, (\\))
import qualified Data.Map as M
import           Data.Maybe
import qualified Data.MultiMap as MM
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           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.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 -> String -> String
[WorkspaceState] -> String -> String
WorkspaceState -> String
(Int -> WorkspaceState -> String -> String)
-> (WorkspaceState -> String)
-> ([WorkspaceState] -> String -> String)
-> Show WorkspaceState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> WorkspaceState -> String -> String
showsPrec :: Int -> WorkspaceState -> String -> String
$cshow :: WorkspaceState -> String
show :: WorkspaceState -> String
$cshowList :: [WorkspaceState] -> String -> String
showList :: [WorkspaceState] -> String -> String
Show, WorkspaceState -> WorkspaceState -> Bool
(WorkspaceState -> WorkspaceState -> Bool)
-> (WorkspaceState -> WorkspaceState -> Bool) -> Eq WorkspaceState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorkspaceState -> WorkspaceState -> Bool
== :: WorkspaceState -> WorkspaceState -> Bool
$c/= :: WorkspaceState -> WorkspaceState -> Bool
/= :: WorkspaceState -> WorkspaceState -> Bool
Eq)

getCSSClass :: (Show s) => s -> T.Text
getCSSClass :: forall s. Show s => 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 -> String -> String
[WindowData] -> String -> String
WindowData -> String
(Int -> WindowData -> String -> String)
-> (WindowData -> String)
-> ([WindowData] -> String -> String)
-> Show WindowData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> WindowData -> String -> String
showsPrec :: Int -> WindowData -> String -> String
$cshow :: WindowData -> String
show :: WindowData -> String
$cshowList :: [WindowData] -> String -> String
showList :: [WindowData] -> String -> String
Show, WindowData -> WindowData -> Bool
(WindowData -> WindowData -> Bool)
-> (WindowData -> WindowData -> Bool) -> Eq WindowData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WindowData -> WindowData -> Bool
== :: WindowData -> WindowData -> Bool
$c/= :: WindowData -> WindowData -> Bool
/= :: 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 -> String -> String
[Workspace] -> String -> String
Workspace -> String
(Int -> Workspace -> String -> String)
-> (Workspace -> String)
-> ([Workspace] -> String -> String)
-> Show Workspace
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Workspace -> String -> String
showsPrec :: Int -> Workspace -> String -> String
$cshow :: Workspace -> String
show :: Workspace -> String
$cshowList :: [Workspace] -> String -> String
showList :: [Workspace] -> String -> String
Show, Workspace -> Workspace -> Bool
(Workspace -> Workspace -> Bool)
-> (Workspace -> Workspace -> Bool) -> Eq Workspace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Workspace -> Workspace -> Bool
== :: Workspace -> Workspace -> Bool
$c/= :: Workspace -> Workspace -> Bool
/= :: 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 :: forall a. TaffyIO a -> WorkspacesIO a
liftContext TaffyIO a
action = (WorkspacesContext -> Context)
-> ReaderT WorkspacesContext IO Context
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> Context
taffyContext ReaderT WorkspacesContext IO Context
-> (Context -> ReaderT WorkspacesContext IO a)
-> ReaderT WorkspacesContext IO a
forall a b.
ReaderT WorkspacesContext IO a
-> (a -> ReaderT WorkspacesContext IO b)
-> ReaderT WorkspacesContext IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> ReaderT WorkspacesContext IO a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT WorkspacesContext m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT WorkspacesContext IO a)
-> (Context -> IO a) -> Context -> ReaderT WorkspacesContext IO 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 :: forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def a
dflt 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
dflt X11Property a
prop

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

updateWidgetClasses ::
  (Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m)
  => a
  -> t1 T.Text
  -> t T.Text
  -> m ()
updateWidgetClasses :: forall (t1 :: * -> *) (t :: * -> *) a (m :: * -> *).
(Foldable t1, Foldable t, IsWidget a, MonadIO m) =>
a -> t1 Text -> t Text -> m ()
updateWidgetClasses a
widget t1 Text
toAdd t Text
toRemove = do
  context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
  let hasClass = StyleContext -> Text -> m Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m Bool
Gtk.styleContextHasClass StyleContext
context
      addIfMissing Text
klass =
        Text -> m Bool
hasClass Text
klass m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
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
klass = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
klass Text -> t1 Text -> Bool
forall a. Eq a => a -> t1 a -> 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 a b. m a -> (a -> m b) -> m b
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)
  mapM_ removeIfPresent toRemove
  mapM_ addIfMissing toAdd

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

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

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

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

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

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

instance Default WorkspacesConfig where
  def :: WorkspacesConfig
def = WorkspacesConfig
defaultWorkspacesConfig

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

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

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

updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceId Workspace)
updateWorkspacesVar :: WorkspacesIO (Map WorkspaceId Workspace)
updateWorkspacesVar = do
  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
  updateVar workspacesRef buildWorkspaceData

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

getWindowData :: Maybe X11Window
              -> [X11Window]
              -> X11Window
              -> X11Property WindowData
getWindowData :: Maybe X11Window
-> [X11Window] -> X11Window -> X11Property WindowData
getWindowData Maybe X11Window
activeWindow [X11Window]
urgentWindows X11Window
window = do
  wTitle <- X11Window -> X11Property String
getWindowTitle X11Window
window
  wClass <- getWindowClass window
  wMinimized <- getWindowMinimized window
  return
    WindowData
    { windowId = window
    , windowTitle = wTitle
    , windowClass = wClass
    , windowUrgent = window `elem` urgentWindows
    , windowActive = Just window == activeWindow
    , windowMinimized = wMinimized
    }

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

addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel :: WorkspacesIO ()
addWidgetsToTopLevel = do
  WorkspacesContext
    { controllersVar = controllersRef
    , workspacesWidget = cont
    } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  controllersMap <- lift $ MV.readMVar controllersRef
  -- Elems returns elements in ascending order of their keys so this will always
  -- add the widgets in the correct order
  mapM_ addWidget $ M.elems controllersMap
  lift $ Gtk.widgetShowAll cont

addWidget :: WWC -> WorkspacesIO ()
addWidget :: WWC -> WorkspacesIO ()
addWidget WWC
controller = do
  cont <- (WorkspacesContext -> Box) -> ReaderT WorkspacesContext IO Box
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks WorkspacesContext -> Box
workspacesWidget
  workspaceWidget <- getWidget controller
  lift $ 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.
    hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0
    void $ Gtk.widgetGetParent workspaceWidget >>=
         traverse (unsafeCastTo Gtk.Box) >>=
         traverse (`Gtk.containerRemove` workspaceWidget)
    Gtk.containerAdd hbox workspaceWidget
    Gtk.containerAdd cont hbox

workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget
workspacesNew :: WorkspacesConfig -> TaffyIO Widget
workspacesNew WorkspacesConfig
cfg = ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Context IO Context
-> (Context -> TaffyIO Widget) -> TaffyIO Widget
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context
tContext -> IO Widget -> TaffyIO Widget
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> TaffyIO Widget) -> IO Widget -> TaffyIO Widget
forall a b. (a -> b) -> a -> b
$ do
  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)
  controllersRef <- MV.newMVar M.empty
  workspacesRef <- MV.newMVar M.empty
  let context =
        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
  runReaderT updateAllWorkspaceWidgets context
  updateHandler <- onWorkspaceUpdate context
  iconHandler <- onIconsChanged context
  let doUpdate = IO () -> ReaderT Context IO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Context IO ())
-> (Event -> IO ()) -> Event -> ReaderT Context IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> IO ()
updateHandler
      handleConfigureEvents e :: Event
e@(ConfigureEvent {}) = Event -> ReaderT Context IO ()
doUpdate Event
e
      handleConfigureEvents Event
_ = () -> ReaderT Context IO ()
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (workspaceSubscription, iconSubscription, geometrySubscription) <-
    flip runReaderT tContext $ sequenceT
         ( subscribeToPropertyEvents (updateEvents cfg) doUpdate
         , subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler)
         , subscribeToAll handleConfigureEvents
         )
  let 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 ()
unsubscribe
              [ Unique
iconSubscription
              , Unique
workspaceSubscription
              , Unique
geometrySubscription
              ]
  _ <- Gtk.onWidgetUnrealize cont doUnsubscribe
  _ <- widgetSetClassGI cont "workspaces"
  Gtk.toWidget cont

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

  workspacesMap <- WorkspacesIO (Map WorkspaceId Workspace)
updateWorkspacesVar
  wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap

  wLog DEBUG "Adding and removing widgets"
  updateWorkspaceControllers

  let updateController' WorkspaceId
idx WWC
controller =
        WorkspacesIO WWC
-> ControllerConstructor -> Maybe Workspace -> WorkspacesIO WWC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (WWC -> WorkspacesIO WWC
forall a. a -> ReaderT WorkspacesContext IO a
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
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 -> String -> String
forall r. PrintfType r => String -> r
printf String
"Updating %s workspace widget" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
i
      updateController WorkspaceId
i WWC
cont = WorkspaceId -> WorkspacesIO ()
forall {m :: * -> *} {a}. (MonadIO m, Show a) => a -> m ()
logUpdateController WorkspaceId
i WorkspacesIO () -> WorkspacesIO WWC -> WorkspacesIO WWC
forall a b.
ReaderT WorkspacesContext IO a
-> ReaderT WorkspacesContext IO b -> ReaderT WorkspacesContext IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                WorkspaceId -> WWC -> WorkspacesIO WWC
updateController' WorkspaceId
i WWC
cont

  wLog DEBUG "Done updating individual widget"

  doWidgetUpdate updateController

  wLog DEBUG "Showing and hiding controllers"
  setControllerWidgetVisibility

setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility :: WorkspacesIO ()
setControllerWidgetVisibility = do
  ctx@WorkspacesContext
    { workspacesVar = workspacesRef
    , controllersVar = controllersRef
    , workspacesConfig = cfg
    } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  lift $ do
    workspacesMap <- MV.readMVar workspacesRef
    controllersMap <- MV.readMVar controllersRef
    forM_ (M.elems workspacesMap) $ \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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Widget -> IO ()
action

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

updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers :: WorkspacesIO ()
updateWorkspaceControllers = do
  WorkspacesContext
    { controllersVar = controllersRef
    , workspacesVar = workspacesRef
    , workspacesWidget = cont
    , workspacesConfig = cfg
    } <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  workspacesMap <- lift $ MV.readMVar workspacesRef
  controllersMap <- lift $ MV.readMVar controllersRef

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

  when (existingWorkspacesSet /= newWorkspacesSet) $ do
    let 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 -> Set WorkspaceId -> Set WorkspaceId
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set WorkspaceId
existingWorkspacesSet Set WorkspaceId
newWorkspacesSet
        builder = WorkspacesConfig -> ControllerConstructor
widgetBuilder WorkspacesConfig
cfg

    _ <- updateVar controllersRef $ \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 b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' ((WorkspaceId -> Map WorkspaceId WWC -> Map WorkspaceId WWC)
-> Map WorkspaceId WWC -> WorkspaceId -> Map WorkspaceId WWC
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspaceId -> Map WorkspaceId WWC -> Map WorkspaceId WWC
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map WorkspaceId WWC
controllers Set WorkspaceId
removeWorkspaces
          buildController :: WorkspaceId -> Maybe (WorkspacesIO WWC)
buildController WorkspaceId
idx = ControllerConstructor
builder ControllerConstructor
-> Maybe Workspace -> Maybe (WorkspacesIO WWC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceId -> Map WorkspaceId Workspace -> Maybe Workspace
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
idx Map WorkspaceId Workspace
workspacesMap
          buildAndAddController :: Map WorkspaceId WWC
-> WorkspaceId
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
buildAndAddController Map WorkspaceId WWC
theMap WorkspaceId
idx =
            ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
-> (WorkspacesIO WWC
    -> ReaderT WorkspacesContext IO (Map WorkspaceId WWC))
-> Maybe (WorkspacesIO WWC)
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a. a -> ReaderT WorkspacesContext IO a
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 a b.
ReaderT WorkspacesContext IO a
-> (a -> ReaderT WorkspacesContext IO b)
-> ReaderT WorkspacesContext IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map WorkspaceId WWC
-> ReaderT WorkspacesContext IO (Map WorkspaceId WWC)
forall a. a -> ReaderT WorkspacesContext IO a
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
    lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)
    addWidgetsToTopLevel

rateLimitFn
  :: forall req resp.
     WorkspacesContext
  -> (req -> IO resp)
  -> ResultsCombiner req resp
  -> IO (req -> IO resp)
rateLimitFn :: forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn WorkspacesContext
context =
  let limit :: Integer
limit = (WorkspacesConfig -> Integer
updateRateLimitMicroseconds (WorkspacesConfig -> Integer) -> WorkspacesConfig -> Integer
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
context)
      rate :: Microsecond
rate = Integer -> Microsecond
forall a. TimeUnit a => Integer -> a
fromMicroseconds Integer
limit :: Microsecond in
  RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
forall req resp t.
TimeUnit t =>
RateLimit t
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
generateRateLimitedFunction (RateLimit Microsecond
 -> (req -> IO resp)
 -> ResultsCombiner req resp
 -> IO (req -> IO resp))
-> RateLimit Microsecond
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
forall a b. (a -> b) -> a -> b
$ Microsecond -> RateLimit Microsecond
forall a. a -> RateLimit a
PerInvocation Microsecond
rate

onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())
onWorkspaceUpdate WorkspacesContext
context = do
  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
event = do
        case Event
event of
          PropertyEvent Word32
_ SignalHandlerId
_ Bool
_ Display
_ X11Window
_ X11Window
atom X11Window
_ CInt
_ ->
            Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Event %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ X11Window -> String
forall a. Show a => a -> String
show X11Window
atom
          Event
_anythingElse -> () -> IO ()
forall a. a -> IO a
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
  return withLog
  where
    combineRequests :: p -> a -> Maybe (a, b -> ((), ()))
combineRequests p
_ a
b = (a, b -> ((), ())) -> Maybe (a, b -> ((), ()))
forall a. a -> Maybe a
Just (a
b, ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()))
    doUpdate :: Event -> IO ()
doUpdate Event
_ = IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesIO ()
updateAllWorkspaceWidgets WorkspacesContext
context

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

onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())
onIconsChanged :: WorkspacesContext -> IO (Set X11Window -> IO ())
onIconsChanged WorkspacesContext
context = WorkspacesContext
-> (Set X11Window -> IO ())
-> ResultsCombiner (Set X11Window) ()
-> IO (Set X11Window -> IO ())
forall req resp.
WorkspacesContext
-> (req -> IO resp)
-> ResultsCombiner req resp
-> IO (req -> IO resp)
rateLimitFn WorkspacesContext
context Set X11Window -> IO ()
onIconsChanged' ResultsCombiner (Set X11Window) ()
forall {a} {b}.
Ord a =>
Set a -> Set a -> Maybe (Set a, b -> ((), ()))
combineRequests
  where
    combineRequests :: Set a -> Set a -> Maybe (Set a, b -> ((), ()))
combineRequests Set a
windows1 Set a
windows2 =
      (Set a, b -> ((), ())) -> Maybe (Set a, b -> ((), ()))
forall a. a -> Maybe a
Just (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
windows1 Set a
windows2, ((), ()) -> b -> ((), ())
forall a b. a -> b -> a
const ((), ()))
    onIconsChanged' :: Set X11Window -> IO ()
onIconsChanged' Set X11Window
wids = do
      Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Icon update execute %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Set X11Window -> String
forall a. Show a => a -> String
show Set X11Window
wids
      IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
context (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (WorkspaceId -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()
doWidgetUpdate
          (\WorkspaceId
idx WWC
c ->
             Priority -> String -> WorkspacesIO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
DEBUG (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Updating %s icons." (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> String
forall a. Show a => a -> String
show WorkspaceId
idx) WorkspacesIO () -> WorkspacesIO WWC -> WorkspacesIO WWC
forall a b.
ReaderT WorkspacesContext IO a
-> ReaderT WorkspacesContext IO b -> ReaderT WorkspacesContext IO b
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))

initializeWWC ::
  WorkspaceWidgetController a => a -> Workspace -> ReaderT WorkspacesContext IO WWC
initializeWWC :: forall a. WorkspaceWidgetController a => a -> ControllerConstructor
initializeWWC a
controller Workspace
ws =
  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
controller (Workspace -> WidgetUpdate
WorkspaceUpdate Workspace
ws)

-- | A WrappingController can be used to wrap some child widget with another
-- abitrary widget.
data WrappingController = WrappingController
  { WrappingController -> Widget
wrappedWidget :: Gtk.Widget
  , WrappingController -> WWC
wrappedController :: WWC
  }

instance WorkspaceWidgetController WrappingController where
  getWidget :: WrappingController -> WorkspacesIO Widget
getWidget = IO Widget -> WorkspacesIO Widget
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT WorkspacesContext m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> WorkspacesIO Widget)
-> (WrappingController -> IO Widget)
-> WrappingController
-> WorkspacesIO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget (Widget -> IO Widget)
-> (WrappingController -> Widget)
-> WrappingController
-> IO Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappingController -> Widget
wrappedWidget
  updateWidget :: WrappingController
-> WidgetUpdate -> WorkspacesIO WrappingController
updateWidget WrappingController
wc WidgetUpdate
update = do
    updated <- WWC -> WidgetUpdate -> WorkspacesIO WWC
forall wc.
WorkspaceWidgetController wc =>
wc -> WidgetUpdate -> WorkspacesIO wc
updateWidget (WrappingController -> WWC
wrappedController WrappingController
wc) WidgetUpdate
update
    return wc { wrappedController = updated }

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

buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController :: [ControllerConstructor] -> ControllerConstructor
buildContentsController [ControllerConstructor]
constructors Workspace
ws = do
  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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ParentControllerConstructor
forall a b. (a -> b) -> a -> b
$ Workspace
ws) [ControllerConstructor]
constructors
  ctx <- ask
  tempController <- lift $ do
    cons <- Gtk.boxNew Gtk.OrientationHorizontal 0
    mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers
    outerBox <- Gtk.toWidget cons >>= buildPadBox
    _ <- widgetSetClassGI cons "contents"
    widget <- Gtk.toWidget outerBox
    return
      WorkspaceContentsController
      { containerWidget = widget
      , contentsControllers = controllers
      }
  initializeWWC tempController ws

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

bottomLeftAlignedBoxWrapper :: T.Text -> ControllerConstructor -> ControllerConstructor
bottomLeftAlignedBoxWrapper :: Text -> ParentControllerConstructor
bottomLeftAlignedBoxWrapper Text
boxClass ControllerConstructor
constructor Workspace
ws = do
  controller <- ControllerConstructor
constructor Workspace
ws
  widget <- getWidget controller
  ebox <- Gtk.eventBoxNew
  _ <- widgetSetClassGI ebox boxClass
  Gtk.widgetSetHalign ebox Gtk.AlignStart
  Gtk.widgetSetValign ebox Gtk.AlignEnd
  Gtk.containerAdd ebox widget
  wrapped <- Gtk.toWidget ebox
  let wrappingController = WrappingController
                           { wrappedWidget :: Widget
wrappedWidget = Widget
wrapped
                           , wrappedController :: WWC
wrappedController = WWC
controller
                           }
  initializeWWC wrappingController ws

buildLabelOverlayController :: ControllerConstructor
buildLabelOverlayController :: ControllerConstructor
buildLabelOverlayController =
  [ControllerConstructor]
-> [ControllerConstructor] -> ControllerConstructor
buildOverlayContentsController
  [ControllerConstructor
buildIconController]
  [Text -> ParentControllerConstructor
bottomLeftAlignedBoxWrapper Text
"overlay-box" ControllerConstructor
buildLabelController]

buildOverlayContentsController ::
  [ControllerConstructor] -> [ControllerConstructor] -> ControllerConstructor
buildOverlayContentsController :: [ControllerConstructor]
-> [ControllerConstructor] -> ControllerConstructor
buildOverlayContentsController [ControllerConstructor]
mainConstructors [ControllerConstructor]
overlayConstructors Workspace
ws = do
  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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ParentControllerConstructor
forall a b. (a -> b) -> a -> b
$ Workspace
ws) [ControllerConstructor]
mainConstructors
  overlayControllers <- mapM ($ ws) overlayConstructors
  ctx <- ask
  tempController <- lift $ do
    mainContents <- Gtk.boxNew Gtk.OrientationHorizontal 0
    mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd mainContents)
        controllers
    outerBox <- Gtk.toWidget mainContents >>= buildPadBox
    _ <- widgetSetClassGI mainContents "contents"
    overlay <- Gtk.overlayNew
    Gtk.containerAdd overlay outerBox
    mapM_ (flip runReaderT ctx . getWidget >=>
                Gtk.overlayAddOverlay overlay) overlayControllers

    widget <- Gtk.toWidget overlay
    return
      WorkspaceContentsController
      { containerWidget = widget
      , contentsControllers = controllers ++ overlayControllers
      }
  initializeWWC tempController ws

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

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

buildLabelController :: ControllerConstructor
buildLabelController :: ControllerConstructor
buildLabelController Workspace
ws = do
  tempController <- IO LabelController -> ReaderT WorkspacesContext IO LabelController
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT WorkspacesContext m a
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
    lbl <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew Maybe Text
forall a. Maybe a
Nothing
    _ <- widgetSetClassGI lbl "workspace-label"
    return LabelController { label = lbl }
  initializeWWC tempController ws

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

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

getPixbufForIconWidget :: Bool
                       -> MV.MVar (Maybe WindowData)
                       -> Int32
                       -> WorkspacesIO (Maybe Gdk.Pixbuf)
getPixbufForIconWidget :: Bool
-> MVar (Maybe WindowData) -> Int32 -> WorkspacesIO (Maybe Pixbuf)
getPixbufForIconWidget Bool
transparentOnNone MVar (Maybe WindowData)
dataVar Int32
size = do
  ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let tContext = WorkspacesContext -> Context
taffyContext WorkspacesContext
ctx
      getPBFromData = WorkspacesConfig -> WindowIconPixbufGetter
getWindowIconPixbuf (WorkspacesConfig -> WindowIconPixbufGetter)
-> WorkspacesConfig -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ WorkspacesContext -> WorkspacesConfig
workspacesConfig WorkspacesContext
ctx
      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 (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (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 a b.
MaybeT (ReaderT Context IO) a
-> (a -> MaybeT (ReaderT Context IO) b)
-> MaybeT (ReaderT Context IO) b
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 = 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 Word32
0)
              else ReaderT Context IO (Maybe Pixbuf)
getPB'
  lift $ runReaderT getPB tContext

buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget Bool
transparentOnNone Workspace
ws = do
  ctx <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  lift $ do
    windowVar <- MV.newMVar Nothing
    img <- Gtk.imageNew
    refreshImage <-
      autoSizeImage img
        (flip runReaderT ctx . getPixbufForIconWidget transparentOnNone windowVar)
        Gtk.OrientationHorizontal
    ebox <- Gtk.eventBoxNew
    _ <- widgetSetClassGI img "window-icon"
    _ <- widgetSetClassGI ebox "window-icon-container"
    Gtk.containerAdd ebox img
    _ <-
      Gtk.onWidgetButtonPressEvent ebox $
      const $ liftIO $ do
        info <- MV.readMVar windowVar
        case info of
          Just WindowData
updatedInfo ->
            (WorkspacesIO () -> WorkspacesContext -> IO ())
-> WorkspacesContext -> WorkspacesIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WorkspacesIO () -> WorkspacesContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT WorkspacesContext
ctx (WorkspacesIO () -> IO ()) -> WorkspacesIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            () -> X11Property () -> WorkspacesIO ()
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def () (X11Property () -> WorkspacesIO ())
-> X11Property () -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ X11Window -> X11Property ()
focusWindow (X11Window -> X11Property ()) -> X11Window -> X11Property ()
forall a b. (a -> b) -> a -> b
$ WindowData -> X11Window
windowId WindowData
updatedInfo
          Maybe WindowData
_ -> IO () -> IO ()
forall a. IO a -> IO a
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)
        return True
    return
      IconWidget
      { iconContainer = ebox
      , iconImage = img
      , iconWindow = windowVar
      , iconForceUpdate = refreshImage
      }

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

buildIconController :: ControllerConstructor
buildIconController :: ControllerConstructor
buildIconController Workspace
ws = do
  tempController <-
    IO IconController -> ReaderT WorkspacesContext IO IconController
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT WorkspacesContext m a
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
      hbox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
      return
        IconController
        {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}
  initializeWWC tempController ws

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

updateWindowIconsById ::
  IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById :: IconController -> [X11Window] -> WorkspacesIO ()
updateWindowIconsById IconController
ic [X11Window]
windowIds =
  (IconWidget -> WorkspacesIO ()) -> [IconWidget] -> WorkspacesIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ IconWidget -> WorkspacesIO ()
maybeUpdateWindowIcon ([IconWidget] -> WorkspacesIO ())
-> [IconWidget] -> WorkspacesIO ()
forall a b. (a -> b) -> a -> b
$ IconController -> [IconWidget]
iconImages IconController
ic
  where
    maybeUpdateWindowIcon :: IconWidget -> WorkspacesIO ()
maybeUpdateWindowIcon IconWidget
widget =
      do
        info <- IO (Maybe WindowData)
-> ReaderT WorkspacesContext IO (Maybe WindowData)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT WorkspacesContext m a
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
        when (maybe False (flip elem windowIds . windowId) info) $
         updateIconWidget ic widget info

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

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

handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter
handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter
handleIconGetterException WindowIconPixbufGetter
getter Int32
size WindowData
windowData =
  ReaderT Context IO (Maybe Pixbuf)
-> (SomeException -> ReaderT Context IO (Maybe Pixbuf))
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny (WindowIconPixbufGetter
getter Int32
size WindowData
windowData) ((SomeException -> ReaderT Context IO (Maybe Pixbuf))
 -> ReaderT Context IO (Maybe Pixbuf))
-> (SomeException -> ReaderT Context IO (Maybe Pixbuf))
-> ReaderT Context IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
    Priority -> String -> ReaderT Context IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
wLog Priority
WARNING (String -> ReaderT Context IO ())
-> String -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Failed to get window icon for %s: %s" (WindowData -> String
forall a. Show a => a -> String
show WindowData
windowData) (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
    Maybe Pixbuf -> ReaderT Context IO (Maybe Pixbuf)
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pixbuf
forall a. Maybe a
Nothing

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

getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass :: WindowIconPixbufGetter
getWindowIconPixbufFromClass = WindowIconPixbufGetter -> WindowIconPixbufGetter
handleIconGetterException (WindowIconPixbufGetter -> WindowIconPixbufGetter)
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ \Int32
size WindowData
windowData ->
  IO (Maybe Pixbuf) -> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (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 = WindowIconPixbufGetter -> WindowIconPixbufGetter
handleIconGetterException (WindowIconPixbufGetter -> WindowIconPixbufGetter)
-> WindowIconPixbufGetter -> WindowIconPixbufGetter
forall a b. (a -> b) -> a -> b
$ \Int32
size WindowData
windowData ->
  Int32 -> String -> ReaderT Context IO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClasses Int32
size (WindowData -> String
windowClass WindowData
windowData)

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

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

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

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

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

-- | Sort windows by top-left corner position.
sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByPosition [WindowData]
wins = do
  let getGeometryWorkspaces :: X11Window
-> ReaderT
     X11Context
     IO
     (X11Window, Int32, Int32, Word32, Word32, Word32, CInt)
getGeometryWorkspaces 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 a b.
ReaderT X11Context IO a
-> (a -> ReaderT X11Context IO b) -> ReaderT X11Context IO b
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 a. IO a -> ReaderT X11Context IO a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> ReaderT X11Context IO a
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 b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (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
  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
wd =
        (Int32, Int32) -> Maybe (Int32, Int32) -> (Int32, Int32)
forall a. a -> Maybe a -> a
fromMaybe (Int32
999999999, Int32
99999999) (Maybe (Int32, Int32) -> (Int32, Int32))
-> Maybe (Int32, Int32) -> (Int32, Int32)
forall a b. (a -> b) -> a -> b
$ X11Window -> [(X11Window, (Int32, Int32))] -> Maybe (Int32, Int32)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (WindowData -> X11Window
windowId WindowData
wd) [(X11Window, (Int32, Int32))]
windowGeometries
      compareWindowData WindowData
a WindowData
b =
        (Bool, (Int32, Int32)) -> (Bool, (Int32, Int32)) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
          (WindowData -> Bool
windowMinimized WindowData
a, WindowData -> (Int32, Int32)
getLeftPos WindowData
a)
          (WindowData -> Bool
windowMinimized WindowData
b, WindowData -> (Int32, Int32)
getLeftPos WindowData
b)
  return $ sortBy compareWindowData wins

-- | Sort windows in reverse _NET_CLIENT_LIST_STACKING order.
-- Starting in xmonad-contrib 0.17.0, this is effectively focus history, active first.
-- Previous versions erroneously stored focus-sort-order in _NET_CLIENT_LIST.
sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByStackIndex :: [WindowData] -> WorkspacesIO [WindowData]
sortWindowsByStackIndex [WindowData]
wins = do
  stackingWindows <- [X11Window] -> X11Property [X11Window] -> WorkspacesIO [X11Window]
forall a. a -> X11Property a -> WorkspacesIO a
liftX11Def [] X11Property [X11Window]
getWindowsStacking
  let getStackIdx WindowData
wd = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (-Int
1) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ X11Window -> [X11Window] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (WindowData -> X11Window
windowId WindowData
wd) [X11Window]
stackingWindows
      compareWindowData WindowData
a WindowData
b = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (WindowData -> Int
getStackIdx WindowData
b) (WindowData -> Int
getStackIdx WindowData
a)
  return $ sortBy compareWindowData wins

updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]
updateImages IconController
ic Workspace
ws = do
  WorkspacesContext {workspacesConfig = cfg} <- ReaderT WorkspacesContext IO WorkspacesContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  sortedWindows <- iconSort cfg $ windows ws
  wLog DEBUG $ printf "Updating images for %s" (show ws)
  let updateIconWidget' WorkspacesIO IconWidget
getImageAction Maybe WindowData
wdata = do
        iconWidget <- WorkspacesIO IconWidget
getImageAction
        _ <- updateIconWidget ic iconWidget wdata
        return iconWidget
      existingImages = (IconWidget -> WorkspacesIO IconWidget)
-> [IconWidget] -> [WorkspacesIO IconWidget]
forall a b. (a -> b) -> [a] -> [b]
map IconWidget -> WorkspacesIO IconWidget
forall a. a -> ReaderT WorkspacesContext IO a
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
transparentOnNone = do
        iw <- Bool -> Workspace -> WorkspacesIO IconWidget
buildIconWidget Bool
transparentOnNone Workspace
ws
        lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw
        return iw
      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 a. [a] -> 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 = [WindowData] -> Int
forall a. [a] -> 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 -> (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 = [WorkspacesIO IconWidget] -> Int
forall a. [a] -> 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 =
        if Bool
newImagesNeeded
          then [WorkspacesIO IconWidget]
infiniteImages
          else [WorkspacesIO IconWidget]
existingImages
      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 = (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 =
        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 a. [a] -> 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
  newImgs <-
    zipWithM updateIconWidget' getImgs windowDatas
  when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic
  return newImgs

getWindowStatusString :: WindowData -> T.Text
getWindowStatusString :: WindowData -> Text
getWindowStatusString WindowData
windowData = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
  case WindowData
windowData of
    WindowData { windowMinimized :: WindowData -> Bool
windowMinimized = Bool
True } -> String
"minimized"
    WindowData { windowActive :: WindowData -> Bool
windowActive = Bool
True } -> WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Active
    WindowData { windowUrgent :: WindowData -> Bool
windowUrgent = Bool
True } -> WorkspaceState -> String
forall a. Show a => a -> String
show WorkspaceState
Urgent
    WindowData
_ -> String
"normal"

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

updateIconWidget
  :: IconController
  -> IconWidget
  -> Maybe WindowData
  -> WorkspacesIO ()
updateIconWidget :: IconController -> IconWidget -> Maybe WindowData -> WorkspacesIO ()
updateIconWidget IconController
_ IconWidget
                   { iconContainer :: IconWidget -> EventBox
iconContainer = EventBox
iconButton
                   , iconWindow :: IconWidget -> MVar (Maybe WindowData)
iconWindow = MVar (Maybe WindowData)
windowRef
                   , iconForceUpdate :: IconWidget -> IO ()
iconForceUpdate = IO ()
updateIcon
                   } Maybe WindowData
windowData = do
  let statusString :: Text
statusString = Text -> (WindowData -> Text) -> Maybe WindowData -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"inactive" WindowData -> Text
getWindowStatusString Maybe WindowData
windowData :: T.Text
      title :: Maybe Text
title = String -> Text
T.pack (String -> Text) -> (WindowData -> String) -> WindowData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowData -> String
windowTitle (WindowData -> Text) -> Maybe WindowData -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe WindowData
windowData
      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 a. a -> ReaderT WorkspacesContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WindowData
windowData
  EventBox -> Maybe Text -> WorkspacesIO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Maybe Text -> m ()
Gtk.widgetSetTooltipText EventBox
iconButton Maybe Text
title
  IO () -> WorkspacesIO ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT WorkspacesContext m a
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
setIconWidgetProperties

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

buildButtonController :: ParentControllerConstructor
buildButtonController :: ParentControllerConstructor
buildButtonController ControllerConstructor
contentsBuilder Workspace
workspace = do
  cc <- ControllerConstructor
contentsBuilder Workspace
workspace
  workspacesRef <- asks workspacesVar
  ctx <- ask
  widget <- getWidget cc
  lift $ do
    ebox <- Gtk.eventBoxNew
    Gtk.containerAdd ebox widget
    Gtk.eventBoxSetVisibleWindow ebox False
    _ <-
      Gtk.onWidgetScrollEvent ebox $ \EventScroll
scrollEvent -> do
        dir <- EventScroll -> IO ScrollDirection
forall (m :: * -> *). MonadIO m => EventScroll -> m ScrollDirection
Gdk.getEventScrollDirection EventScroll
scrollEvent
        workspaces <- liftIO $ MV.readMVar workspacesRef
        let switchOne Bool
a =
              IO Bool -> IO Bool
forall a. IO a -> IO a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Map WorkspaceId Workspace -> [(WorkspaceId, Workspace)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorkspaceId Workspace
workspaces) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) WorkspacesIO ()
-> ReaderT WorkspacesContext IO Bool
-> ReaderT WorkspacesContext IO Bool
forall a b.
ReaderT WorkspacesContext IO a
-> ReaderT WorkspacesContext IO b -> ReaderT WorkspacesContext IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              Bool -> ReaderT WorkspacesContext IO Bool
forall a. a -> ReaderT WorkspacesContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        case dir of
          ScrollDirection
Gdk.ScrollDirectionUp -> Bool -> IO Bool
switchOne Bool
True
          ScrollDirection
Gdk.ScrollDirectionLeft -> Bool -> IO Bool
switchOne Bool
True
          ScrollDirection
Gdk.ScrollDirectionDown -> Bool -> IO Bool
switchOne Bool
False
          ScrollDirection
Gdk.ScrollDirectionRight -> Bool -> IO Bool
switchOne Bool
False
          ScrollDirection
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ switch ctx $ workspaceIdx workspace
    return $
      WWC
        WorkspaceButtonController
        { button = ebox, buttonWorkspace = workspace, contentsController = cc }

switch :: (MonadIO m) => WorkspacesContext -> WorkspaceId -> m Bool
switch :: forall (m :: * -> *).
MonadIO m =>
WorkspacesContext -> WorkspaceId -> m Bool
switch WorkspacesContext
ctx WorkspaceId
idx = do
  IO () -> m ()
forall a. IO a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

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