-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.Repeatable
-- Description :  Actions you'd like to repeat.
-- Copyright   :  (c) 2022 L. S. Leary
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  @LSLeary (on github)
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module factors out the shared logic of "XMonad.Actions.CycleRecentWS",
-- "XMonad.Actions.CycleWorkspaceByScreen", "XMonad.Actions.CycleWindows" and
-- "XMonad.Actions.MostRecentlyUsed".
--
-- See the source of these modules for usage examples.
--
-----------------------------------------------------------------------------

module XMonad.Actions.Repeatable
  ( repeatable
  , repeatableSt
  , repeatableM
  ) where

-- mtl
import Control.Monad.State (StateT(..))

-- X11
import Graphics.X11.Xlib.Extras

-- xmonad
import XMonad


-- | An action that temporarily usurps and responds to key press/release events,
--   concluding when one of the modifier keys is released.
repeatable
  :: [KeySym]                      -- ^ The list of 'KeySym's under the
                                   --   modifiers used to invoke the action.
  -> KeySym                        -- ^ The keypress that invokes the action.
  -> (EventType -> KeySym -> X ()) -- ^ The keypress handler.
  -> X ()
repeatable :: [KeySym] -> KeySym -> (EventType -> KeySym -> X ()) -> X ()
repeatable = (X () -> X ())
-> [KeySym] -> KeySym -> (EventType -> KeySym -> X ()) -> X ()
forall (m :: * -> *) a b.
(MonadIO m, Monoid a) =>
(m a -> X b)
-> [KeySym] -> KeySym -> (EventType -> KeySym -> m a) -> X b
repeatableM X () -> X ()
forall a. a -> a
id

-- | A more general variant of 'repeatable' with a stateful handler,
--   accumulating a monoidal return value throughout the events.
repeatableSt
  :: Monoid a
  => s                                     -- ^ Initial state.
  -> [KeySym]                              -- ^ The list of 'KeySym's under the
                                           --   modifiers used to invoke the
                                           --   action.
  -> KeySym                                -- ^ The keypress that invokes the
                                           --   action.
  -> (EventType -> KeySym -> StateT s X a) -- ^ The keypress handler.
  -> X (a, s)
repeatableSt :: forall a s.
Monoid a =>
s
-> [KeySym]
-> KeySym
-> (EventType -> KeySym -> StateT s X a)
-> X (a, s)
repeatableSt s
iSt = (StateT s X a -> X (a, s))
-> [KeySym]
-> KeySym
-> (EventType -> KeySym -> StateT s X a)
-> X (a, s)
forall (m :: * -> *) a b.
(MonadIO m, Monoid a) =>
(m a -> X b)
-> [KeySym] -> KeySym -> (EventType -> KeySym -> m a) -> X b
repeatableM ((StateT s X a -> X (a, s))
 -> [KeySym]
 -> KeySym
 -> (EventType -> KeySym -> StateT s X a)
 -> X (a, s))
-> (StateT s X a -> X (a, s))
-> [KeySym]
-> KeySym
-> (EventType -> KeySym -> StateT s X a)
-> X (a, s)
forall a b. (a -> b) -> a -> b
$ \StateT s X a
m -> StateT s X a -> s -> X (a, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT s X a
m s
iSt

-- | A more general variant of 'repeatable' with an arbitrary monadic handler,
--   accumulating a monoidal return value throughout the events.
repeatableM
  :: (MonadIO m, Monoid a)
  => (m a -> X b)                 -- ^ How to run the monad in 'X'.
  -> [KeySym]                     -- ^ The list of 'KeySym's under the
                                  --   modifiers used to invoke the action.
  -> KeySym                       -- ^ The keypress that invokes the action.
  -> (EventType -> KeySym -> m a) -- ^ The keypress handler.
  -> X b
repeatableM :: forall (m :: * -> *) a b.
(MonadIO m, Monoid a) =>
(m a -> X b)
-> [KeySym] -> KeySym -> (EventType -> KeySym -> m a) -> X b
repeatableM m a -> X b
run [KeySym]
mods KeySym
key EventType -> KeySym -> m a
pressHandler = do
  XConf{ theRoot :: XConf -> KeySym
theRoot = KeySym
root, display :: XConf -> Display
display = Display
d } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
  m a -> X b
run (Display
-> KeySym
-> [KeySym]
-> KeySym
-> (EventType -> KeySym -> m a)
-> m a
forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
Display
-> KeySym
-> [KeySym]
-> KeySym
-> (EventType -> KeySym -> m a)
-> m a
repeatableRaw Display
d KeySym
root [KeySym]
mods KeySym
key EventType -> KeySym -> m a
pressHandler)

repeatableRaw
  :: (MonadIO m, Monoid a)
  => Display -> Window
  -> [KeySym] -> KeySym -> (EventType -> KeySym -> m a) -> m a
repeatableRaw :: forall (m :: * -> *) a.
(MonadIO m, Monoid a) =>
Display
-> KeySym
-> [KeySym]
-> KeySym
-> (EventType -> KeySym -> m a)
-> m a
repeatableRaw Display
d KeySym
root [KeySym]
mods KeySym
key EventType -> KeySym -> m a
pressHandler = do
  IO GrabStatus -> m GrabStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display
-> KeySym
-> Bool
-> GrabStatus
-> GrabStatus
-> KeySym
-> IO GrabStatus
grabKeyboard Display
d KeySym
root Bool
False GrabStatus
grabModeAsync GrabStatus
grabModeAsync KeySym
currentTime)
  (EventType, KeySym) -> m a
handleEvent (EventType
keyPress, KeySym
key) m a -> m () -> m a
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeySym -> IO ()
ungrabKeyboard Display
d KeySym
currentTime)
  where
    getNextEvent :: m (EventType, KeySym)
getNextEvent = IO (EventType, KeySym) -> m (EventType, KeySym)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (EventType, KeySym) -> m (EventType, KeySym))
-> IO (EventType, KeySym) -> m (EventType, KeySym)
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO (EventType, KeySym)) -> IO (EventType, KeySym)
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (EventType, KeySym)) -> IO (EventType, KeySym))
-> (XEventPtr -> IO (EventType, KeySym)) -> IO (EventType, KeySym)
forall a b. (a -> b) -> a -> b
$ \XEventPtr
p -> do
      Display -> KeySym -> XEventPtr -> IO ()
maskEvent Display
d (KeySym
keyPressMask KeySym -> KeySym -> KeySym
forall a. Bits a => a -> a -> a
.|. KeySym
keyReleaseMask) XEventPtr
p
      KeyEvent{ ev_event_type :: Event -> EventType
ev_event_type = EventType
t, ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
c } <- XEventPtr -> IO Event
getEvent XEventPtr
p
      KeySym
s <- Display -> KeyCode -> GrabStatus -> IO KeySym
keycodeToKeysym Display
d KeyCode
c GrabStatus
0
      (EventType, KeySym) -> IO (EventType, KeySym)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventType
t, KeySym
s)
    handleEvent :: (EventType, KeySym) -> m a
handleEvent (EventType
t, KeySym
s)
      | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
keyRelease Bool -> Bool -> Bool
&& KeySym
s KeySym -> [KeySym] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeySym]
mods = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
      | Bool
otherwise = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (a -> a -> a) -> m a -> m (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventType -> KeySym -> m a
pressHandler EventType
t KeySym
s m (a -> a) -> m a -> m a
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (m (EventType, KeySym)
getNextEvent m (EventType, KeySym) -> ((EventType, KeySym) -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (EventType, KeySym) -> m a
handleEvent)