module XMonad.Hooks.DynamicBars {-# DEPRECATED "Use XMonad.Hooks.StatusBar instead" #-} (
DynamicStatusBar
, DynamicStatusBarCleanup
, DynamicStatusBarPartialCleanup
, dynStatusBarStartup
, dynStatusBarStartup'
, dynStatusBarEventHook
, dynStatusBarEventHook'
, multiPP
, multiPPFormat
) where
import Prelude
import Control.Monad.Trans (lift)
import Control.Monad.Writer (WriterT, execWriterT, tell)
import Graphics.X11.Xinerama
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrandr
import System.IO
import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W
import XMonad.Hooks.DynamicLog
import qualified XMonad.Util.ExtensibleState as XS
newtype DynStatusBarInfo = DynStatusBarInfo
{ DynStatusBarInfo -> [(ScreenId, Handle)]
dsbInfo :: [(ScreenId, Handle)]
}
instance ExtensionClass DynStatusBarInfo where
initialValue :: DynStatusBarInfo
initialValue = [(ScreenId, Handle)] -> DynStatusBarInfo
DynStatusBarInfo []
type DynamicStatusBar = ScreenId -> IO Handle
type DynamicStatusBarCleanup = IO ()
type DynamicStatusBarPartialCleanup = ScreenId -> IO ()
dynStatusBarSetup :: X ()
dynStatusBarSetup :: X ()
dynStatusBarSetup = do
Display
dpy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
Window
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
xrrSelectInput Display
dpy Window
root Window
rrScreenChangeNotifyMask
dynStatusBarStartup :: DynamicStatusBar -> DynamicStatusBarCleanup -> X ()
dynStatusBarStartup :: DynamicStatusBar -> IO () -> X ()
dynStatusBarStartup DynamicStatusBar
sb IO ()
cleanup = do
X ()
dynStatusBarSetup
DynamicStatusBar -> IO () -> X ()
updateStatusBars DynamicStatusBar
sb IO ()
cleanup
dynStatusBarStartup' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()
dynStatusBarStartup' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()
dynStatusBarStartup' DynamicStatusBar
sb DynamicStatusBarPartialCleanup
cleanup = do
X ()
dynStatusBarSetup
DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()
updateStatusBars' DynamicStatusBar
sb DynamicStatusBarPartialCleanup
cleanup
dynStatusBarEventHook :: DynamicStatusBar -> DynamicStatusBarCleanup -> Event -> X All
dynStatusBarEventHook :: DynamicStatusBar -> IO () -> Event -> X All
dynStatusBarEventHook DynamicStatusBar
sb IO ()
cleanup = X () -> Event -> X All
dynStatusBarRun (DynamicStatusBar -> IO () -> X ()
updateStatusBars DynamicStatusBar
sb IO ()
cleanup)
dynStatusBarEventHook' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> Event -> X All
dynStatusBarEventHook' :: DynamicStatusBar
-> DynamicStatusBarPartialCleanup -> Event -> X All
dynStatusBarEventHook' DynamicStatusBar
sb DynamicStatusBarPartialCleanup
cleanup = X () -> Event -> X All
dynStatusBarRun (DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()
updateStatusBars' DynamicStatusBar
sb DynamicStatusBarPartialCleanup
cleanup)
dynStatusBarRun :: X () -> Event -> X All
dynStatusBarRun :: X () -> Event -> X All
dynStatusBarRun X ()
action RRScreenChangeNotifyEvent{} = X ()
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
dynStatusBarRun X ()
_ Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
updateStatusBars :: DynamicStatusBar -> DynamicStatusBarCleanup -> X ()
updateStatusBars :: DynamicStatusBar -> IO () -> X ()
updateStatusBars DynamicStatusBar
sb IO ()
cleanup = do
([ScreenId]
dsbInfoScreens, [Handle]
dsbInfoHandles) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynStatusBarInfo -> [(ScreenId, Handle)]
dsbInfo
[ScreenId]
screens <- forall (m :: * -> *). MonadIO m => m [ScreenId]
getScreens
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ScreenId]
screens forall a. Eq a => a -> a -> Bool
/= [ScreenId]
dsbInfoScreens) forall a b. (a -> b) -> a -> b
$ do
[Handle]
newHandles <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hClose forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Handle]
dsbInfoHandles
IO ()
cleanup
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DynamicStatusBar
sb [ScreenId]
screens
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ [(ScreenId, Handle)] -> DynStatusBarInfo
DynStatusBarInfo (forall a b. [a] -> [b] -> [(a, b)]
zip [ScreenId]
screens [Handle]
newHandles)
updateStatusBars' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()
updateStatusBars' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()
updateStatusBars' DynamicStatusBar
sb DynamicStatusBarPartialCleanup
cleanup = do
([ScreenId]
dsbInfoScreens, [Handle]
dsbInfoHandles) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynStatusBarInfo -> [(ScreenId, Handle)]
dsbInfo)
[ScreenId]
screens <- forall (m :: * -> *). MonadIO m => m [ScreenId]
getScreens
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ScreenId]
screens forall a. Eq a => a -> a -> Bool
/= [ScreenId]
dsbInfoScreens) forall a b. (a -> b) -> a -> b
$ do
let oldInfo :: [(ScreenId, Handle)]
oldInfo = forall a b. [a] -> [b] -> [(a, b)]
zip [ScreenId]
dsbInfoScreens [Handle]
dsbInfoHandles
let ([(ScreenId, Handle)]
infoToKeep, [(ScreenId, Handle)]
infoToClose) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [ScreenId]
screens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ScreenId, Handle)]
oldInfo
[(ScreenId, Handle)]
newInfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> IO ()
hClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ScreenId, Handle)]
infoToClose
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynamicStatusBarPartialCleanup
cleanup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ScreenId, Handle)]
infoToClose
let newScreens :: [ScreenId]
newScreens = [ScreenId]
screens forall a. Eq a => [a] -> [a] -> [a]
\\ [ScreenId]
dsbInfoScreens
[Handle]
newHandles <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DynamicStatusBar
sb [ScreenId]
newScreens
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [ScreenId]
newScreens [Handle]
newHandles
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ScreenId, Handle)] -> DynStatusBarInfo
DynStatusBarInfo forall a b. (a -> b) -> a -> b
$ [(ScreenId, Handle)]
infoToKeep forall a. [a] -> [a] -> [a]
++ [(ScreenId, Handle)]
newInfo
multiPP :: PP
-> PP
-> X ()
multiPP :: PP -> PP -> X ()
multiPP = (PP -> X WorkspaceId) -> PP -> PP -> X ()
multiPPFormat PP -> X WorkspaceId
dynamicLogString
multiPPFormat :: (PP -> X String) -> PP -> PP -> X ()
multiPPFormat :: (PP -> X WorkspaceId) -> PP -> PP -> X ()
multiPPFormat PP -> X WorkspaceId
dynlStr PP
focusPP PP
unfocusPP = do
([ScreenId]
_, [Handle]
dsbInfoHandles) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynStatusBarInfo -> [(ScreenId, Handle)]
dsbInfo
(PP -> X WorkspaceId) -> PP -> PP -> [Handle] -> X ()
multiPP' PP -> X WorkspaceId
dynlStr PP
focusPP PP
unfocusPP [Handle]
dsbInfoHandles
multiPP' :: (PP -> X String) -> PP -> PP -> [Handle] -> X ()
multiPP' :: (PP -> X WorkspaceId) -> PP -> PP -> [Handle] -> X ()
multiPP' PP -> X WorkspaceId
dynlStr PP
focusPP PP
unfocusPP [Handle]
handles = do
XState
st <- forall s (m :: * -> *). MonadState s m => m s
get
let pickPP :: WorkspaceId -> WriterT (Last XState) X String
pickPP :: WorkspaceId -> WriterT (Last XState) X WorkspaceId
pickPP WorkspaceId
ws = do
let isFoc :: Bool
isFoc = (WorkspaceId
ws forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall a b. (a -> b) -> a -> b
$ XState -> WindowSet
windowset XState
st
forall s (m :: * -> *). MonadState s m => s -> m ()
put XState
st{ windowset :: WindowSet
windowset = forall s i l a sd.
(Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.view WorkspaceId
ws forall a b. (a -> b) -> a -> b
$ XState -> WindowSet
windowset XState
st }
WorkspaceId
out <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PP -> X WorkspaceId
dynlStr forall a b. (a -> b) -> a -> b
$ if Bool
isFoc then PP
focusPP else PP
unfocusPP
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isFoc forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Last a
Last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceId
out
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall s (m :: * -> *). MonadState s m => s -> m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Last a -> Maybe a
getLast
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Handle -> WorkspaceId -> IO ()
hPutStrLn [Handle]
handles forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WorkspaceId -> WriterT (Last XState) X WorkspaceId
pickPP) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ScreenId -> X (Maybe WorkspaceId)
screenWorkspace (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. a -> b -> a
const [ScreenId
0 .. ] [Handle]
handles)
getScreens :: MonadIO m => m [ScreenId]
getScreens :: forall (m :: * -> *). MonadIO m => m [ScreenId]
getScreens = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[Rectangle]
screens <- do
Display
dpy <- WorkspaceId -> IO Display
openDisplay WorkspaceId
""
[Rectangle]
rects <- Display -> IO [Rectangle]
getScreenInfo Display
dpy
Display -> IO ()
closeDisplay Display
dpy
forall (m :: * -> *) a. Monad m => a -> m a
return [Rectangle]
rects
let ids :: [(ScreenId, Rectangle)]
ids = forall a b. [a] -> [b] -> [(a, b)]
zip [ScreenId
0 .. ] [Rectangle]
screens
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ScreenId, Rectangle)]
ids