{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module XMonad.Hooks.Rescreen (
addAfterRescreenHook,
addRandrChangeHook,
RescreenConfig(..),
rescreenHook,
) where
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 ()
}
instance Default RescreenConfig where
def :: RescreenConfig
def = RescreenConfig
{ afterRescreenHook :: X ()
afterRescreenHook = X ()
forall a. Monoid a => a
mempty
, randrChangeHook :: X ()
randrChangeHook = X ()
forall a. Monoid a => a
mempty
}
instance Semigroup RescreenConfig where
RescreenConfig X ()
arh X ()
rch <> :: RescreenConfig -> RescreenConfig -> RescreenConfig
<> RescreenConfig X ()
arh' X ()
rch' = X () -> X () -> RescreenConfig
RescreenConfig (X ()
arh X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
arh') (X ()
rch X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
rch')
instance Monoid RescreenConfig where
mempty :: RescreenConfig
mempty = RescreenConfig
forall a. Default a => a
def
rescreenHook :: RescreenConfig -> XConfig l -> XConfig l
rescreenHook :: forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook = (XConfig l -> XConfig l)
-> RescreenConfig -> XConfig l -> XConfig l
forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once ((XConfig l -> XConfig l)
-> RescreenConfig -> XConfig l -> XConfig l)
-> (XConfig l -> XConfig l)
-> RescreenConfig
-> XConfig l
-> XConfig l
forall a b. (a -> b) -> a -> b
$ \XConfig l
c -> XConfig l
c
{ startupHook = startupHook c <> rescreenStartupHook
, handleEventHook = handleEventHook c <> rescreenEventHook }
addAfterRescreenHook :: X () -> XConfig l -> XConfig l
addAfterRescreenHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
addAfterRescreenHook X ()
h = RescreenConfig -> XConfig l -> XConfig l
forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook RescreenConfig
forall a. Default a => a
def{ afterRescreenHook = userCodeDef () h }
addRandrChangeHook :: X () -> XConfig l -> XConfig l
addRandrChangeHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
addRandrChangeHook X ()
h = RescreenConfig -> XConfig l -> XConfig l
forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook RescreenConfig
forall a. Default a => a
def{ randrChangeHook = userCodeDef () h }
rescreenStartupHook :: X ()
rescreenStartupHook :: X ()
rescreenStartupHook = do
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
root <- asks theRoot
io $ xrrSelectInput dpy root rrScreenChangeNotifyMask
rescreenEventHook :: Event -> X All
rescreenEventHook :: Event -> X All
rescreenEventHook Event
e = do
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
_ -> Bool -> X Bool
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
if shouldHandle
then All False <$ handleEvent e
else mempty
handleEvent :: Event -> X ()
handleEvent :: Event -> X ()
handleEvent Event
e = (RescreenConfig -> X ()) -> X ()
forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Monoid b) =>
(a -> m b) -> m b
XC.with ((RescreenConfig -> X ()) -> X ())
-> (RescreenConfig -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \RescreenConfig{X ()
afterRescreenHook :: RescreenConfig -> X ()
randrChangeHook :: RescreenConfig -> X ()
afterRescreenHook :: X ()
randrChangeHook :: X ()
..} -> do
moreConfigureEvents <- Window -> EventType -> X Bool
clearTypedWindowEvents (Event -> Window
ev_window Event
e) EventType
configureNotify
_ <- clearTypedWindowRREvents (ev_window e) rrScreenChangeNotify
if ev_event_type e == configureNotify || moreConfigureEvents
then rescreen >> afterRescreenHook
else randrChangeHook
clearTypedWindowEvents :: Window -> EventType -> X Bool
clearTypedWindowEvents :: Window -> EventType -> X Bool
clearTypedWindowEvents Window
w EventType
t = (Display -> X Bool) -> X Bool
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Bool) -> X Bool) -> (Display -> X Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO Bool -> X Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Bool -> X Bool) -> IO Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO Bool) -> IO Bool
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
gotEvent <- Display -> Window -> EventType -> XEventPtr -> IO Bool
checkTypedWindowEvent Display
d Window
w EventType
t XEventPtr
e'
e <- if gotEvent then Just <$> getEvent e' else pure Nothing
gotEvent <$ if
| not gotEvent -> mempty
| (ev_window <$> e) == Just w -> void $ go d e'
| otherwise -> allocaXEvent (go d) >> io (putBackEvent d e')
clearTypedWindowRREvents :: Window -> EventType -> X Bool
clearTypedWindowRREvents :: Window -> EventType -> X Bool
clearTypedWindowRREvents Window
w EventType
t =
X (Maybe EventType)
rrEventBase X (Maybe EventType) -> (Maybe EventType -> X Bool) -> X Bool
forall a b. X a -> (a -> X b) -> X b
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 EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
+ EventType
t)
Maybe EventType
Nothing -> Bool -> X Bool
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
rrEventBase :: X (Maybe EventType)
rrEventBase :: X (Maybe EventType)
rrEventBase = (Display -> X (Maybe EventType)) -> X (Maybe EventType)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Maybe EventType)) -> X (Maybe EventType))
-> (Display -> X (Maybe EventType)) -> X (Maybe EventType)
forall a b. (a -> b) -> a -> b
$ \Display
d ->
((CInt, CInt) -> EventType)
-> Maybe (CInt, CInt) -> Maybe EventType
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> EventType
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> EventType)
-> ((CInt, CInt) -> CInt) -> (CInt, CInt) -> EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CInt, CInt) -> CInt
forall a b. (a, b) -> a
fst) (Maybe (CInt, CInt) -> Maybe EventType)
-> X (Maybe (CInt, CInt)) -> X (Maybe EventType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (CInt, CInt)) -> X (Maybe (CInt, CInt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> IO (Maybe (CInt, CInt))
xrrQueryExtension Display
d)