-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.CycleWorkspaceByScreen
-- Copyright   :  (c) 2017 Ivan Malison
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  IvanMalison@gmail.com
-- Stability   :  unstable
-- Portability :  unportable
--
-- Cycle through previously viewed workspaces in the order they were viewed most
-- recently on the screen where cycling is taking place.
--
-----------------------------------------------------------------------------

module XMonad.Actions.CycleWorkspaceByScreen (
    -- * Usage
    -- $usage
    cycleWorkspaceOnScreen
  , cycleWorkspaceOnCurrentScreen
  , handleKeyEvent
  , repeatableAction
  ) where

import           Control.Monad
import           Data.IORef
import           Data.List
import           Data.Maybe

import           Graphics.X11.Xlib.Extras

import           XMonad
import           XMonad.Hooks.WorkspaceHistory
import qualified XMonad.StackSet as W

-- $usage
-- This module must be used in conjuction with XMonad.Hooks.WorkspaceHistory
--
-- To use, add something like the following to your keybindings
-- , ((mod4Mask,  xK_slash), cycleWorkspaceOnCurrentScreen [xK_Super_L] xK_slash xK_p)

repeatableAction :: [KeySym] -> (EventType -> KeySym -> X ()) -> X ()
repeatableAction :: [KeySym] -> (KeySym -> KeySym -> X ()) -> X ()
repeatableAction [KeySym]
mods KeySym -> KeySym -> X ()
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
  let getNextEvent :: X (KeySym, KeySym)
getNextEvent = IO (KeySym, KeySym) -> X (KeySym, KeySym)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (KeySym, KeySym) -> X (KeySym, KeySym))
-> IO (KeySym, KeySym) -> X (KeySym, KeySym)
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO (KeySym, KeySym)) -> IO (KeySym, KeySym)
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (KeySym, KeySym)) -> IO (KeySym, KeySym))
-> (XEventPtr -> IO (KeySym, KeySym)) -> IO (KeySym, 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 -> KeySym
ev_event_type = KeySym
t, ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
c} <- XEventPtr -> IO Event
getEvent XEventPtr
p
                   KeySym
s <- IO KeySym -> IO KeySym
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO KeySym -> IO KeySym) -> IO KeySym -> IO KeySym
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
d KeyCode
c CInt
0
                   (KeySym, KeySym) -> IO (KeySym, KeySym)
forall (m :: * -> *) a. Monad m => a -> m a
return (KeySym
t, KeySym
s)
      handleEvent :: (KeySym, KeySym) -> X ()
handleEvent (KeySym
t, KeySym
s)
        | KeySym
t KeySym -> KeySym -> Bool
forall a. Eq a => a -> a -> Bool
== KeySym
keyRelease Bool -> Bool -> Bool
&& KeySym
s KeySym -> [KeySym] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeySym]
mods = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = (KeySym -> KeySym -> X ()
pressHandler KeySym
t KeySym
s) X () -> X (KeySym, KeySym) -> X (KeySym, KeySym)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X (KeySym, KeySym)
getNextEvent X (KeySym, KeySym) -> ((KeySym, KeySym) -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (KeySym, KeySym) -> X ()
handleEvent

  IO CInt -> X CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO CInt -> X CInt) -> IO CInt -> X CInt
forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> Bool -> CInt -> CInt -> KeySym -> IO CInt
grabKeyboard Display
d KeySym
root Bool
False CInt
grabModeAsync CInt
grabModeAsync KeySym
currentTime
  X (KeySym, KeySym)
getNextEvent X (KeySym, KeySym) -> ((KeySym, KeySym) -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (KeySym, KeySym) -> X ()
handleEvent
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> IO ()
ungrabKeyboard Display
d KeySym
currentTime

handleKeyEvent :: EventType
               -> KeySym
               -> X ()
               -> EventType
               -> KeySym
               -> Maybe (X ())
handleKeyEvent :: KeySym -> KeySym -> X () -> KeySym -> KeySym -> Maybe (X ())
handleKeyEvent KeySym
eventType KeySym
key X ()
action = KeySym -> KeySym -> Maybe (X ())
helper
  where
  helper :: KeySym -> KeySym -> Maybe (X ())
helper KeySym
et KeySym
k
    | KeySym
et KeySym -> KeySym -> Bool
forall a. Eq a => a -> a -> Bool
== KeySym
eventType Bool -> Bool -> Bool
&& KeySym
k KeySym -> KeySym -> Bool
forall a. Eq a => a -> a -> Bool
== KeySym
key = X () -> Maybe (X ())
forall a. a -> Maybe a
Just X ()
action
    | Bool
otherwise = Maybe (X ())
forall a. Maybe a
Nothing


runFirst :: [EventType -> KeySym -> Maybe (X ())] -> EventType -> KeySym -> X ()
runFirst :: [KeySym -> KeySym -> Maybe (X ())] -> KeySym -> KeySym -> X ()
runFirst [KeySym -> KeySym -> Maybe (X ())]
matchers KeySym
eventType KeySym
key =
  X () -> Maybe (X ()) -> X ()
forall a. a -> Maybe a -> a
fromMaybe (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe (X ()) -> X ()) -> Maybe (X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe (X ())) -> Maybe (X ())
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (X ())) -> Maybe (X ()))
-> Maybe (Maybe (X ())) -> Maybe (X ())
forall a b. (a -> b) -> a -> b
$ (Maybe (X ()) -> Bool) -> [Maybe (X ())] -> Maybe (Maybe (X ()))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Maybe (X ()) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (X ())] -> Maybe (Maybe (X ())))
-> [Maybe (X ())] -> Maybe (Maybe (X ()))
forall a b. (a -> b) -> a -> b
$ ((KeySym -> KeySym -> Maybe (X ())) -> Maybe (X ()))
-> [KeySym -> KeySym -> Maybe (X ())] -> [Maybe (X ())]
forall a b. (a -> b) -> [a] -> [b]
map (\KeySym -> KeySym -> Maybe (X ())
fn -> KeySym -> KeySym -> Maybe (X ())
fn KeySym
eventType KeySym
key) [KeySym -> KeySym -> Maybe (X ())]
matchers

cycleWorkspaceOnScreen :: ScreenId -> [KeySym] -> KeySym -> KeySym -> X ()
cycleWorkspaceOnScreen :: ScreenId -> [KeySym] -> KeySym -> KeySym -> X ()
cycleWorkspaceOnScreen ScreenId
screenId [KeySym]
mods KeySym
nextKey KeySym
prevKey = X () -> X ()
workspaceHistoryTransaction (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
  [(ScreenId, [WorkspaceId])]
startingHistory <- X [(ScreenId, [WorkspaceId])]
workspaceHistoryByScreen
  IORef Int
currentWSIndex <- IO (IORef Int) -> X (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (IORef Int) -> X (IORef Int))
-> IO (IORef Int) -> X (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
1
  let cycleWorkspaces :: [WorkspaceId]
cycleWorkspaces = [WorkspaceId] -> Maybe [WorkspaceId] -> [WorkspaceId]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [WorkspaceId] -> [WorkspaceId])
-> Maybe [WorkspaceId] -> [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ ScreenId -> [(ScreenId, [WorkspaceId])] -> Maybe [WorkspaceId]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ScreenId
screenId [(ScreenId, [WorkspaceId])]
startingHistory
      getAndIncrementWS :: Int -> IO WorkspaceId
getAndIncrementWS Int
increment = do
        Int
current <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
currentWSIndex
        IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef
          IORef Int
currentWSIndex
          ((Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` ([WorkspaceId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [WorkspaceId]
cycleWorkspaces)) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
increment))
        WorkspaceId -> IO WorkspaceId
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId -> IO WorkspaceId) -> WorkspaceId -> IO WorkspaceId
forall a b. (a -> b) -> a -> b
$ [WorkspaceId]
cycleWorkspaces [WorkspaceId] -> Int -> WorkspaceId
forall a. [a] -> Int -> a
!! Int
current
      focusIncrement :: Int -> X ()
focusIncrement Int
i = (IO WorkspaceId -> X WorkspaceId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WorkspaceId -> X WorkspaceId)
-> IO WorkspaceId -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ Int -> IO WorkspaceId
getAndIncrementWS Int
i) X WorkspaceId -> (WorkspaceId -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WorkspaceId -> WindowSet -> WindowSet) -> WorkspaceId -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId -> 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.greedyView)

  Int -> X ()
focusIncrement Int
1 -- Do the first workspace cycle
  [KeySym] -> (KeySym -> KeySym -> X ()) -> X ()
repeatableAction [KeySym]
mods ((KeySym -> KeySym -> X ()) -> X ())
-> (KeySym -> KeySym -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$
    [KeySym -> KeySym -> Maybe (X ())] -> KeySym -> KeySym -> X ()
runFirst
      [ KeySym -> KeySym -> X () -> KeySym -> KeySym -> Maybe (X ())
handleKeyEvent KeySym
keyPress KeySym
nextKey (X () -> KeySym -> KeySym -> Maybe (X ()))
-> X () -> KeySym -> KeySym -> Maybe (X ())
forall a b. (a -> b) -> a -> b
$ Int -> X ()
focusIncrement Int
1
      , KeySym -> KeySym -> X () -> KeySym -> KeySym -> Maybe (X ())
handleKeyEvent KeySym
keyPress KeySym
prevKey (X () -> KeySym -> KeySym -> Maybe (X ()))
-> X () -> KeySym -> KeySym -> Maybe (X ())
forall a b. (a -> b) -> a -> b
$ Int -> X ()
focusIncrement (-Int
1)
      ]
  () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

cycleWorkspaceOnCurrentScreen
  :: [KeySym] -> KeySym -> KeySym -> X ()
cycleWorkspaceOnCurrentScreen :: [KeySym] -> KeySym -> KeySym -> X ()
cycleWorkspaceOnCurrentScreen [KeySym]
mods KeySym
n KeySym
p =
  (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws ->
    ScreenId -> [KeySym] -> KeySym -> KeySym -> X ()
cycleWorkspaceOnScreen (Screen WorkspaceId (Layout KeySym) KeySym ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (Screen WorkspaceId (Layout KeySym) KeySym ScreenId ScreenDetail
 -> ScreenId)
-> Screen WorkspaceId (Layout KeySym) KeySym ScreenId ScreenDetail
-> ScreenId
forall a b. (a -> b) -> a -> b
$ WindowSet
-> Screen WorkspaceId (Layout KeySym) KeySym ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws) [KeySym]
mods KeySym
n KeySym
p