{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module XMonad.Hooks.Rescreen (
addAfterRescreenHook,
addRandrChangeHook,
setRescreenWorkspacesHook,
setRescreenDelay,
RescreenConfig(..),
rescreenHook,
) where
import Control.Concurrent (threadDelay)
import Graphics.X11.Xrandr
import XMonad
import XMonad.Prelude
import qualified XMonad.Util.ExtensibleConf as XC
data RescreenConfig = RescreenConfig
{ RescreenConfig -> X ()
afterRescreenHook :: X ()
, RescreenConfig -> X ()
randrChangeHook :: X ()
, RescreenConfig -> Last (X ())
rescreenWorkspacesHook :: Last (X ())
, RescreenConfig -> Last Int
rescreenDelay :: Last Int
}
instance Default RescreenConfig where
def :: RescreenConfig
def = RescreenConfig
{ afterRescreenHook :: X ()
afterRescreenHook = forall a. Monoid a => a
mempty
, randrChangeHook :: X ()
randrChangeHook = forall a. Monoid a => a
mempty
, rescreenWorkspacesHook :: Last (X ())
rescreenWorkspacesHook = forall a. Monoid a => a
mempty
, rescreenDelay :: Last Int
rescreenDelay = forall a. Monoid a => a
mempty
}
instance Semigroup RescreenConfig where
RescreenConfig X ()
arh X ()
rch Last (X ())
rwh Last Int
rd <> :: RescreenConfig -> RescreenConfig -> RescreenConfig
<> RescreenConfig X ()
arh' X ()
rch' Last (X ())
rwh' Last Int
rd' =
X () -> X () -> Last (X ()) -> Last Int -> RescreenConfig
RescreenConfig (X ()
arh forall a. Semigroup a => a -> a -> a
<> X ()
arh') (X ()
rch forall a. Semigroup a => a -> a -> a
<> X ()
rch') (Last (X ())
rwh forall a. Semigroup a => a -> a -> a
<> Last (X ())
rwh') (Last Int
rd forall a. Semigroup a => a -> a -> a
<> Last Int
rd')
instance Monoid RescreenConfig where
mempty :: RescreenConfig
mempty = forall a. Default a => a
def
rescreenHook :: RescreenConfig -> XConfig l -> XConfig l
rescreenHook :: forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook = forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once forall {l :: * -> *}. XConfig l -> XConfig l
hook forall b c a. (b -> c) -> (a -> b) -> a -> c
. RescreenConfig -> RescreenConfig
catchUserCode
where
hook :: XConfig l -> XConfig l
hook XConfig l
c = XConfig l
c
{ startupHook :: X ()
startupHook = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
c forall a. Semigroup a => a -> a -> a
<> X ()
rescreenStartupHook
, handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
c forall a. Semigroup a => a -> a -> a
<> Event -> X All
rescreenEventHook }
catchUserCode :: RescreenConfig -> RescreenConfig
catchUserCode rc :: RescreenConfig
rc@RescreenConfig{Last Int
Last (X ())
X ()
rescreenDelay :: Last Int
rescreenWorkspacesHook :: Last (X ())
randrChangeHook :: X ()
afterRescreenHook :: X ()
rescreenDelay :: RescreenConfig -> Last Int
rescreenWorkspacesHook :: RescreenConfig -> Last (X ())
randrChangeHook :: RescreenConfig -> X ()
afterRescreenHook :: RescreenConfig -> X ()
..} = RescreenConfig
rc
{ afterRescreenHook :: X ()
afterRescreenHook = forall a. a -> X a -> X a
userCodeDef () X ()
afterRescreenHook
, randrChangeHook :: X ()
randrChangeHook = forall a. a -> X a -> X a
userCodeDef () X ()
randrChangeHook
, rescreenWorkspacesHook :: Last (X ())
rescreenWorkspacesHook = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. X a -> X a -> X a
catchX X ()
rescreen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Last (X ())
rescreenWorkspacesHook
}
addAfterRescreenHook :: X () -> XConfig l -> XConfig l
addAfterRescreenHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
addAfterRescreenHook X ()
h = forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook forall a. Default a => a
def{ afterRescreenHook :: X ()
afterRescreenHook = X ()
h }
addRandrChangeHook :: X () -> XConfig l -> XConfig l
addRandrChangeHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
addRandrChangeHook X ()
h = forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook forall a. Default a => a
def{ randrChangeHook :: X ()
randrChangeHook = X ()
h }
setRescreenWorkspacesHook :: X () -> XConfig l -> XConfig l
setRescreenWorkspacesHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
setRescreenWorkspacesHook X ()
h = forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook forall a. Default a => a
def{ rescreenWorkspacesHook :: Last (X ())
rescreenWorkspacesHook = forall (f :: * -> *) a. Applicative f => a -> f a
pure X ()
h }
setRescreenDelay :: Int -> XConfig l -> XConfig l
setRescreenDelay :: forall (l :: * -> *). Int -> XConfig l -> XConfig l
setRescreenDelay Int
d = forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook forall a. Default a => a
def{ rescreenDelay :: Last Int
rescreenDelay = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
d }
rescreenStartupHook :: X ()
rescreenStartupHook :: X ()
rescreenStartupHook = 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
rescreenEventHook :: Event -> X All
rescreenEventHook :: Event -> X All
rescreenEventHook Event
e = do
Bool
shouldHandle <- case Event
e of
ConfigureEvent{ ev_window :: Event -> Window
ev_window = Window
w } -> Window -> X Bool
isRoot Window
w
RRScreenChangeNotifyEvent{ ev_window :: Event -> Window
ev_window = Window
w } -> Window -> X Bool
isRoot Window
w
Event
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
if Bool
shouldHandle
then Bool -> All
All Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event -> X ()
handleEvent Event
e
else forall a. Monoid a => a
mempty
handleEvent :: Event -> X ()
handleEvent :: Event -> X ()
handleEvent Event
e = forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Monoid b) =>
(a -> m b) -> m b
XC.with forall a b. (a -> b) -> a -> b
$ \RescreenConfig{Last Int
Last (X ())
X ()
rescreenDelay :: Last Int
rescreenWorkspacesHook :: Last (X ())
randrChangeHook :: X ()
afterRescreenHook :: X ()
rescreenDelay :: RescreenConfig -> Last Int
rescreenWorkspacesHook :: RescreenConfig -> Last (X ())
randrChangeHook :: RescreenConfig -> X ()
afterRescreenHook :: RescreenConfig -> X ()
..} -> do
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. Last a -> Maybe a
getLast Last Int
rescreenDelay) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay)
Bool
moreConfigureEvents <- Window -> EventType -> X Bool
clearTypedWindowEvents (Event -> Window
ev_window Event
e) EventType
configureNotify
Bool
_ <- Window -> EventType -> X Bool
clearTypedWindowRREvents (Event -> Window
ev_window Event
e) EventType
rrScreenChangeNotify
if Event -> EventType
ev_event_type Event
e forall a. Eq a => a -> a -> Bool
== EventType
configureNotify Bool -> Bool -> Bool
|| Bool
moreConfigureEvents
then forall a. a -> Maybe a -> a
fromMaybe X ()
rescreen (forall a. Last a -> Maybe a
getLast Last (X ())
rescreenWorkspacesHook) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
afterRescreenHook
else X ()
randrChangeHook
clearTypedWindowEvents :: Window -> EventType -> X Bool
clearTypedWindowEvents :: Window -> EventType -> X Bool
clearTypedWindowEvents Window
w EventType
t = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent (Display -> XEventPtr -> IO Bool
go Display
d)
where
go :: Display -> XEventPtr -> IO Bool
go Display
d XEventPtr
e' = do
Display -> Bool -> IO ()
sync Display
d Bool
False
Bool
gotEvent <- Display -> Window -> EventType -> XEventPtr -> IO Bool
checkTypedWindowEvent Display
d Window
w EventType
t XEventPtr
e'
Maybe Event
e <- if Bool
gotEvent then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XEventPtr -> IO Event
getEvent XEventPtr
e' else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Bool
gotEvent forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ if
| Bool -> Bool
not Bool
gotEvent -> forall a. Monoid a => a
mempty
| (Event -> Window
ev_window forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Event
e) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Window
w -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Display -> XEventPtr -> IO Bool
go Display
d XEventPtr
e'
| Bool
otherwise -> forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent (Display -> XEventPtr -> IO Bool
go Display
d) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> XEventPtr -> IO ()
putBackEvent Display
d XEventPtr
e')
clearTypedWindowRREvents :: Window -> EventType -> X Bool
clearTypedWindowRREvents :: Window -> EventType -> X Bool
clearTypedWindowRREvents Window
w EventType
t =
X (Maybe EventType)
rrEventBase forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just EventType
base -> Window -> EventType -> X Bool
clearTypedWindowEvents Window
w (EventType
base forall a. Num a => a -> a -> a
+ EventType
t)
Maybe EventType
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
rrEventBase :: X (Maybe EventType)
rrEventBase :: X (Maybe EventType)
rrEventBase = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> IO (Maybe (CInt, CInt))
xrrQueryExtension Display
d)