{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Actions.WorkspaceCursors
-- Description  : Like "XMonad.Actions.Plane" for an arbitrary number of dimensions.
-- Copyright    : (c) 2009 Adam Vogt <vogt.adam@gmail.com>
-- License      : BSD
--
-- Maintainer   : Adam Vogt
-- Stability    : unstable
-- Portability  : unportable
--
-- Like "XMonad.Actions.Plane" for an arbitrary number of dimensions.
-----------------------------------------------------------------------------

module XMonad.Actions.WorkspaceCursors
    (
    -- * Usage
    -- $usage

     focusDepth
    ,makeCursors
    ,toList
    ,workspaceCursors

    ,WorkspaceCursors
    ,getFocus

    -- * Modifying the focus
    ,modifyLayer
    ,modifyLayer'
    ,shiftModifyLayer,shiftLayer

    -- * Functions to pass to 'modifyLayer'
    ,focusNth'
    ,noWrapUp,noWrapDown,

    -- * Todo
    -- $todo

    -- * Types
    Cursors,
    ) where

import qualified XMonad.StackSet as W

import XMonad.Actions.FocusNth(focusNth')
import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
                                    LayoutModifier(handleMess, redoLayout))
import XMonad(Message, WorkspaceId, X, XState(windowset),
              fromMessage, sendMessage, windows, gets)
import XMonad.Util.Stack (reverseS)
import XMonad.Prelude (find, fromJust, guard, liftA2, toList, when, (<=<))

-- $usage
--
-- Here is an example config:
--
-- > import XMonad
-- > import XMonad.Actions.WorkspaceCursors
-- > import XMonad.Util.EZConfig
-- > import qualified XMonad.StackSet as W
-- >
-- > main = xmonad conf
-- >
-- > conf = additionalKeysP def
-- >        { layoutHook = workspaceCursors myCursors $ layoutHook def
-- >        , workspaces = toList myCursors } $
-- >        [("M-"++shift++control++[k], f direction depth)
-- >          | (f,shift) <- zip [modifyLayer,shiftModifyLayer] ["","S-"]
-- >          , (direction,control) <- zip [W.focusUp',W.focusDown'] ["C-",""]
-- >          , (depth,k) <- zip (reverse [1..focusDepth myCursors]) "asdf"]
-- >        ++ moreKeybindings
-- >
-- > moreKeybindings = []
-- >
-- > myCursors = makeCursors $ map (map (\x -> [x])) [ "1234", "abc", "xyz"]
-- > -- myCursors = makeCursors [["wsA","wsB","wsC"],["-alpha-","-beta-","-gamma-"],["x","y"]]


-- $todo
--
-- * Find and document how to raise the allowable length of arguments:
--   restoring xmonad's state results in: @xmonad: executeFile: resource
--   exhausted (Argument list too long)@ when you specify more than about 50
--   workspaces. Or change it such that workspaces are created when you try to
--   view it.
--
-- * Function for pretty printing for "XMonad.Hooks.StatusBar.PP" that groups
--   workspaces by
-- common prefixes
--
-- * Examples of adding workspaces to the cursors, having them appear multiple
--   times for being able to show jumping to some n'th multiple workspace

-- | makeCursors requires a nonempty string, and each sublist must be nonempty
makeCursors ::  [[String]] -> Cursors String
makeCursors :: [[WorkspaceId]] -> Cursors WorkspaceId
makeCursors [] = WorkspaceId -> Cursors WorkspaceId
forall a. HasCallStack => WorkspaceId -> a
error WorkspaceId
"Workspace Cursors cannot be empty"
makeCursors [[WorkspaceId]]
a = [WorkspaceId] -> WorkspaceId
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([WorkspaceId] -> WorkspaceId)
-> ([WorkspaceId] -> [WorkspaceId]) -> [WorkspaceId] -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WorkspaceId] -> [WorkspaceId]
forall a. [a] -> [a]
reverse ([WorkspaceId] -> WorkspaceId)
-> Cursors [WorkspaceId] -> Cursors WorkspaceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cursors [WorkspaceId] -> [[WorkspaceId]] -> Cursors [WorkspaceId])
-> Cursors [WorkspaceId]
-> [[[WorkspaceId]]]
-> Cursors [WorkspaceId]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Cursors [WorkspaceId] -> [[WorkspaceId]] -> Cursors [WorkspaceId]
forall a. Monoid a => Cursors a -> [a] -> Cursors a
addDim Cursors [WorkspaceId]
x [[[WorkspaceId]]]
xs
    where x :: Cursors [WorkspaceId]
x = [[WorkspaceId]] -> Cursors [WorkspaceId]
forall a. [a] -> Cursors a
end ([[WorkspaceId]] -> Cursors [WorkspaceId])
-> [[WorkspaceId]] -> Cursors [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ (WorkspaceId -> [WorkspaceId]) -> [WorkspaceId] -> [[WorkspaceId]]
forall a b. (a -> b) -> [a] -> [b]
map WorkspaceId -> [WorkspaceId]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WorkspaceId] -> [[WorkspaceId]])
-> [WorkspaceId] -> [[WorkspaceId]]
forall a b. (a -> b) -> a -> b
$ [[WorkspaceId]] -> [WorkspaceId]
forall a. [a] -> a
head [[WorkspaceId]]
a
          xs :: [[[WorkspaceId]]]
xs = ([WorkspaceId] -> [[WorkspaceId]])
-> [[WorkspaceId]] -> [[[WorkspaceId]]]
forall a b. (a -> b) -> [a] -> [b]
map ((WorkspaceId -> [WorkspaceId]) -> [WorkspaceId] -> [[WorkspaceId]]
forall a b. (a -> b) -> [a] -> [b]
map WorkspaceId -> [WorkspaceId]
forall (m :: * -> *) a. Monad m => a -> m a
return) ([[WorkspaceId]] -> [[[WorkspaceId]]])
-> [[WorkspaceId]] -> [[[WorkspaceId]]]
forall a b. (a -> b) -> a -> b
$ [[WorkspaceId]] -> [[WorkspaceId]]
forall a. [a] -> [a]
tail [[WorkspaceId]]
a
          -- this could probably be simplified, but this true:
          -- toList . makeCursors == map (concat . reverse) . sequence . reverse . map (map (:[]))
          -- the strange order is used because it makes the regular M-1..9
          -- bindings change the prefixes first

addDim ::  (Monoid a) => Cursors a -> [a] -> Cursors a
addDim :: forall a. Monoid a => Cursors a -> [a] -> Cursors a
addDim Cursors a
prev [a]
prefixes = Stack (Cursors a) -> Cursors a
forall a. Stack (Cursors a) -> Cursors a
Cons (Stack (Cursors a) -> Cursors a)
-> ([Cursors a] -> Stack (Cursors a)) -> [Cursors a] -> Cursors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Stack (Cursors a)) -> Stack (Cursors a)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Stack (Cursors a)) -> Stack (Cursors a))
-> ([Cursors a] -> Maybe (Stack (Cursors a)))
-> [Cursors a]
-> Stack (Cursors a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cursors a] -> Maybe (Stack (Cursors a))
forall a. [a] -> Maybe (Stack a)
W.differentiate
            ([Cursors a] -> Cursors a) -> [Cursors a] -> Cursors a
forall a b. (a -> b) -> a -> b
$ (a -> Cursors a) -> [a] -> [Cursors a]
forall a b. (a -> b) -> [a] -> [b]
map (((a -> a) -> Cursors a -> Cursors a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cursors a
prev) ((a -> a) -> Cursors a) -> (a -> a -> a) -> a -> Cursors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) [a]
prefixes

end :: [a] -> Cursors a
end :: forall a. [a] -> Cursors a
end = Stack (Cursors a) -> Cursors a
forall a. Stack (Cursors a) -> Cursors a
Cons (Stack (Cursors a) -> Cursors a)
-> ([a] -> Stack (Cursors a)) -> [a] -> Cursors a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Stack (Cursors a)) -> Stack (Cursors a)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Stack (Cursors a)) -> Stack (Cursors a))
-> ([a] -> Maybe (Stack (Cursors a))) -> [a] -> Stack (Cursors a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cursors a] -> Maybe (Stack (Cursors a))
forall a. [a] -> Maybe (Stack a)
W.differentiate ([Cursors a] -> Maybe (Stack (Cursors a)))
-> ([a] -> [Cursors a]) -> [a] -> Maybe (Stack (Cursors a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Cursors a) -> [a] -> [Cursors a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Cursors a
forall a. a -> Cursors a
End

data Cursors a
    = Cons (W.Stack (Cursors a))
    | End a deriving (Cursors a -> Cursors a -> Bool
(Cursors a -> Cursors a -> Bool)
-> (Cursors a -> Cursors a -> Bool) -> Eq (Cursors a)
forall a. Eq a => Cursors a -> Cursors a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cursors a -> Cursors a -> Bool
$c/= :: forall a. Eq a => Cursors a -> Cursors a -> Bool
== :: Cursors a -> Cursors a -> Bool
$c== :: forall a. Eq a => Cursors a -> Cursors a -> Bool
Eq,Int -> Cursors a -> ShowS
[Cursors a] -> ShowS
Cursors a -> WorkspaceId
(Int -> Cursors a -> ShowS)
-> (Cursors a -> WorkspaceId)
-> ([Cursors a] -> ShowS)
-> Show (Cursors a)
forall a. Show a => Int -> Cursors a -> ShowS
forall a. Show a => [Cursors a] -> ShowS
forall a. Show a => Cursors a -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [Cursors a] -> ShowS
$cshowList :: forall a. Show a => [Cursors a] -> ShowS
show :: Cursors a -> WorkspaceId
$cshow :: forall a. Show a => Cursors a -> WorkspaceId
showsPrec :: Int -> Cursors a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Cursors a -> ShowS
Show,ReadPrec [Cursors a]
ReadPrec (Cursors a)
Int -> ReadS (Cursors a)
ReadS [Cursors a]
(Int -> ReadS (Cursors a))
-> ReadS [Cursors a]
-> ReadPrec (Cursors a)
-> ReadPrec [Cursors a]
-> Read (Cursors a)
forall a. Read a => ReadPrec [Cursors a]
forall a. Read a => ReadPrec (Cursors a)
forall a. Read a => Int -> ReadS (Cursors a)
forall a. Read a => ReadS [Cursors a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cursors a]
$creadListPrec :: forall a. Read a => ReadPrec [Cursors a]
readPrec :: ReadPrec (Cursors a)
$creadPrec :: forall a. Read a => ReadPrec (Cursors a)
readList :: ReadS [Cursors a]
$creadList :: forall a. Read a => ReadS [Cursors a]
readsPrec :: Int -> ReadS (Cursors a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Cursors a)
Read)

instance Foldable Cursors where
    foldMap :: forall m a. Monoid m => (a -> m) -> Cursors a -> m
foldMap a -> m
f (End a
x) = a -> m
f a
x
    foldMap a -> m
f (Cons (W.Stack Cursors a
x [Cursors a]
y [Cursors a]
z)) = (a -> m) -> Cursors a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Cursors a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` [m] -> m
forall a. Monoid a => [a] -> a
mconcat ((Cursors a -> m) -> [Cursors a] -> [m]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> m) -> Cursors a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) ([Cursors a] -> [m]) -> [Cursors a] -> [m]
forall a b. (a -> b) -> a -> b
$ [Cursors a] -> [Cursors a]
forall a. [a] -> [a]
reverse [Cursors a]
y [Cursors a] -> [Cursors a] -> [Cursors a]
forall a. [a] -> [a] -> [a]
++ [Cursors a]
z)

instance Functor Cursors where
    fmap :: forall a b. (a -> b) -> Cursors a -> Cursors b
fmap a -> b
f (End a
a) = b -> Cursors b
forall a. a -> Cursors a
End (b -> Cursors b) -> b -> Cursors b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
    fmap a -> b
f (Cons (W.Stack Cursors a
x [Cursors a]
y [Cursors a]
z)) = Stack (Cursors b) -> Cursors b
forall a. Stack (Cursors a) -> Cursors a
Cons (Stack (Cursors b) -> Cursors b) -> Stack (Cursors b) -> Cursors b
forall a b. (a -> b) -> a -> b
$ Cursors b -> [Cursors b] -> [Cursors b] -> Stack (Cursors b)
forall a. a -> [a] -> [a] -> Stack a
W.Stack ((a -> b) -> Cursors a -> Cursors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Cursors a
x) ((Cursors a -> Cursors b) -> [Cursors a] -> [Cursors b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Cursors a -> Cursors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Cursors a]
y) ((Cursors a -> Cursors b) -> [Cursors a] -> [Cursors b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Cursors a -> Cursors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Cursors a]
z)

changeFocus ::  (Cursors t -> Bool) -> Cursors t -> [Cursors t]
changeFocus :: forall t. (Cursors t -> Bool) -> Cursors t -> [Cursors t]
changeFocus Cursors t -> Bool
p (Cons Stack (Cursors t)
x) = do
    Stack (Cursors t)
choose <- (Cursors t -> Bool) -> Stack (Cursors t) -> [Stack (Cursors t)]
forall a. (a -> Bool) -> Stack a -> [Stack a]
chFocus Cursors t -> Bool
p Stack (Cursors t)
x
    Cursors t
foc    <- (Cursors t -> Bool) -> Cursors t -> [Cursors t]
forall t. (Cursors t -> Bool) -> Cursors t -> [Cursors t]
changeFocus Cursors t -> Bool
p (Cursors t -> [Cursors t]) -> Cursors t -> [Cursors t]
forall a b. (a -> b) -> a -> b
$ Stack (Cursors t) -> Cursors t
forall a. Stack a -> a
W.focus Stack (Cursors t)
choose
    Cursors t -> [Cursors t]
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursors t -> [Cursors t])
-> (Stack (Cursors t) -> Cursors t)
-> Stack (Cursors t)
-> [Cursors t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack (Cursors t) -> Cursors t
forall a. Stack (Cursors a) -> Cursors a
Cons (Stack (Cursors t) -> [Cursors t])
-> Stack (Cursors t) -> [Cursors t]
forall a b. (a -> b) -> a -> b
$ Stack (Cursors t)
choose { focus :: Cursors t
W.focus = Cursors t
foc }
changeFocus Cursors t -> Bool
p Cursors t
x = Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Cursors t -> Bool
p Cursors t
x) [()] -> [Cursors t] -> [Cursors t]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Cursors t -> [Cursors t]
forall (m :: * -> *) a. Monad m => a -> m a
return Cursors t
x

chFocus :: (a -> Bool) -> W.Stack a -> [W.Stack a]
chFocus :: forall a. (a -> Bool) -> Stack a -> [Stack a]
chFocus a -> Bool
p Stack a
st = (Stack a -> Bool) -> [Stack a] -> [Stack a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Bool
p (a -> Bool) -> (Stack a -> a) -> Stack a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack a -> a
forall a. Stack a -> a
W.focus) ([Stack a] -> [Stack a]) -> [Stack a] -> [Stack a]
forall a b. (a -> b) -> a -> b
$ (Stack a -> a -> Stack a) -> [Stack a] -> [a] -> [Stack a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Stack a -> a -> Stack a
forall a b. a -> b -> a
const ((Stack a -> Stack a) -> Stack a -> [Stack a]
forall a. (a -> a) -> a -> [a]
iterate Stack a -> Stack a
forall a. Stack a -> Stack a
W.focusDown' Stack a
st) (Stack a -> [a]
forall a. Stack a -> [a]
W.integrate Stack a
st)

getFocus ::  Cursors b -> b
getFocus :: forall b. Cursors b -> b
getFocus (Cons Stack (Cursors b)
x) = Cursors b -> b
forall b. Cursors b -> b
getFocus (Cursors b -> b) -> Cursors b -> b
forall a b. (a -> b) -> a -> b
$ Stack (Cursors b) -> Cursors b
forall a. Stack a -> a
W.focus Stack (Cursors b)
x
getFocus (End b
x) = b
x

-- This could be made more efficient, if the fact that the suffixes are grouped
focusTo ::  (Eq t) => t -> Cursors t -> Maybe (Cursors t)
focusTo :: forall t. Eq t => t -> Cursors t -> Maybe (Cursors t)
focusTo t
x = (Cursors t -> Bool) -> [Cursors t] -> Maybe (Cursors t)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((t
xt -> t -> Bool
forall a. Eq a => a -> a -> Bool
==) (t -> Bool) -> (Cursors t -> t) -> Cursors t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursors t -> t
forall b. Cursors b -> b
getFocus) ([Cursors t] -> Maybe (Cursors t))
-> (Cursors t -> [Cursors t]) -> Cursors t -> Maybe (Cursors t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cursors t -> Bool) -> Cursors t -> [Cursors t]
forall t. (Cursors t -> Bool) -> Cursors t -> [Cursors t]
changeFocus (Bool -> Cursors t -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | non-wrapping version of 'W.focusUp''
noWrapUp ::  W.Stack t -> W.Stack t
noWrapUp :: forall a. Stack a -> Stack a
noWrapUp (W.Stack t
t (t
l:[t]
ls) [t]
rs) = t -> [t] -> [t] -> Stack t
forall a. a -> [a] -> [a] -> Stack a
W.Stack t
l [t]
ls (t
tt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
rs)
noWrapUp x :: Stack t
x@(W.Stack t
_ []   [t]
_ ) = Stack t
x

-- | non-wrapping version of 'W.focusDown''
noWrapDown ::  W.Stack t -> W.Stack t
noWrapDown :: forall a. Stack a -> Stack a
noWrapDown = Stack t -> Stack t
forall a. Stack a -> Stack a
reverseS (Stack t -> Stack t) -> (Stack t -> Stack t) -> Stack t -> Stack t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack t -> Stack t
forall a. Stack a -> Stack a
noWrapUp (Stack t -> Stack t) -> (Stack t -> Stack t) -> Stack t -> Stack t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack t -> Stack t
forall a. Stack a -> Stack a
reverseS

focusDepth ::  Cursors t -> Int
focusDepth :: forall a. Cursors a -> Int
focusDepth (Cons Stack (Cursors t)
x) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Cursors t -> Int
forall a. Cursors a -> Int
focusDepth (Stack (Cursors t) -> Cursors t
forall a. Stack a -> a
W.focus Stack (Cursors t)
x)
focusDepth (End  t
_) = Int
0

descend :: Monad m =>(W.Stack (Cursors a) -> m (W.Stack (Cursors a)))-> Int-> Cursors a-> m (Cursors a)
descend :: forall (m :: * -> *) a.
Monad m =>
(Stack (Cursors a) -> m (Stack (Cursors a)))
-> Int -> Cursors a -> m (Cursors a)
descend Stack (Cursors a) -> m (Stack (Cursors a))
f Int
1 (Cons Stack (Cursors a)
x) = Stack (Cursors a) -> Cursors a
forall a. Stack (Cursors a) -> Cursors a
Cons (Stack (Cursors a) -> Cursors a)
-> m (Stack (Cursors a)) -> m (Cursors a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack (Cursors a) -> m (Stack (Cursors a))
f Stack (Cursors a)
x
descend Stack (Cursors a) -> m (Stack (Cursors a))
f Int
n (Cons Stack (Cursors a)
x) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = (Stack (Cursors a) -> Cursors a)
-> m (Stack (Cursors a)) -> m (Cursors a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stack (Cursors a) -> Cursors a
forall a. Stack (Cursors a) -> Cursors a
Cons (m (Stack (Cursors a)) -> m (Cursors a))
-> m (Stack (Cursors a)) -> m (Cursors a)
forall a b. (a -> b) -> a -> b
$ (Stack (Cursors a) -> m (Stack (Cursors a)))
-> Int -> Cursors a -> m (Cursors a)
forall (m :: * -> *) a.
Monad m =>
(Stack (Cursors a) -> m (Stack (Cursors a)))
-> Int -> Cursors a -> m (Cursors a)
descend Stack (Cursors a) -> m (Stack (Cursors a))
f (Int -> Int
forall a. Enum a => a -> a
pred Int
n) (Cursors a -> m (Cursors a))
-> Stack (Cursors a) -> m (Stack (Cursors a))
forall (m :: * -> *) a1.
Monad m =>
(a1 -> m a1) -> Stack a1 -> m (Stack a1)
`onFocus` Stack (Cursors a)
x
descend Stack (Cursors a) -> m (Stack (Cursors a))
_ Int
_ Cursors a
x = Cursors a -> m (Cursors a)
forall (m :: * -> *) a. Monad m => a -> m a
return Cursors a
x

onFocus :: (Monad m) => (a1 -> m a1) -> W.Stack a1 -> m (W.Stack a1)
onFocus :: forall (m :: * -> *) a1.
Monad m =>
(a1 -> m a1) -> Stack a1 -> m (Stack a1)
onFocus a1 -> m a1
f Stack a1
st = (\a1
x -> Stack a1
st { focus :: a1
W.focus = a1
x}) (a1 -> Stack a1) -> m a1 -> m (Stack a1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a1 -> m a1
f (Stack a1 -> a1
forall a. Stack a -> a
W.focus Stack a1
st)

-- | @modifyLayer@ is used to change the focus at a given depth
modifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors String)) -> Int -> X ()
modifyLayer :: (Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId))
-> Int -> X ()
modifyLayer Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId)
f Int
depth = (Cursors WorkspaceId -> X (Cursors WorkspaceId)) -> X ()
modifyCursors ((Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int -> Cursors WorkspaceId -> X (Cursors WorkspaceId)
forall (m :: * -> *) a.
Monad m =>
(Stack (Cursors a) -> m (Stack (Cursors a)))
-> Int -> Cursors a -> m (Cursors a)
descend (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> (Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId))
-> Stack (Cursors WorkspaceId)
-> X (Stack (Cursors WorkspaceId))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId)
f) Int
depth)

-- | @shiftModifyLayer@ is the same as 'modifyLayer', but also shifts the
-- currently focused window to the new workspace
shiftModifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors WorkspaceId))-> Int-> X ()
shiftModifyLayer :: (Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId))
-> Int -> X ()
shiftModifyLayer Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId)
f = (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int -> X ()
modifyLayer' ((Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
 -> Int -> X ())
-> (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int
-> X ()
forall a b. (a -> b) -> a -> b
$ \Stack (Cursors WorkspaceId)
st -> do
    let st' :: Stack (Cursors WorkspaceId)
st' = Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId)
f Stack (Cursors WorkspaceId)
st
    (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> WindowSet -> WindowSet
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.shift (WorkspaceId -> WindowSet -> WindowSet)
-> WorkspaceId -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ Cursors WorkspaceId -> WorkspaceId
forall b. Cursors b -> b
getFocus (Stack (Cursors WorkspaceId) -> Cursors WorkspaceId
forall a. Stack (Cursors a) -> Cursors a
Cons Stack (Cursors WorkspaceId)
st')
    Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId))
forall (m :: * -> *) a. Monad m => a -> m a
return Stack (Cursors WorkspaceId)
st'

-- | @shiftLayer@ is the same as 'shiftModifyLayer', but the focus remains on
-- the current workspace.
shiftLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors WorkspaceId))-> Int-> X ()
shiftLayer :: (Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId))
-> Int -> X ()
shiftLayer Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId)
f = (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int -> X ()
modifyLayer' ((Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
 -> Int -> X ())
-> (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int
-> X ()
forall a b. (a -> b) -> a -> b
$ \Stack (Cursors WorkspaceId)
st -> do
    (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> WindowSet -> WindowSet
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.shift (WorkspaceId -> WindowSet -> WindowSet)
-> WorkspaceId -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ Cursors WorkspaceId -> WorkspaceId
forall b. Cursors b -> b
getFocus (Cursors WorkspaceId -> WorkspaceId)
-> Cursors WorkspaceId -> WorkspaceId
forall a b. (a -> b) -> a -> b
$ Stack (Cursors WorkspaceId) -> Cursors WorkspaceId
forall a. Stack (Cursors a) -> Cursors a
Cons (Stack (Cursors WorkspaceId) -> Cursors WorkspaceId)
-> Stack (Cursors WorkspaceId) -> Cursors WorkspaceId
forall a b. (a -> b) -> a -> b
$ Stack (Cursors WorkspaceId) -> Stack (Cursors WorkspaceId)
f Stack (Cursors WorkspaceId)
st
    Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId))
forall (m :: * -> *) a. Monad m => a -> m a
return Stack (Cursors WorkspaceId)
st

-- | example usages are 'shiftLayer' and 'shiftModifyLayer'
modifyLayer' :: (W.Stack (Cursors String) -> X (W.Stack (Cursors String))) -> Int -> X ()
modifyLayer' :: (Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int -> X ()
modifyLayer' Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId))
f Int
depth = (Cursors WorkspaceId -> X (Cursors WorkspaceId)) -> X ()
modifyCursors ((Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId)))
-> Int -> Cursors WorkspaceId -> X (Cursors WorkspaceId)
forall (m :: * -> *) a.
Monad m =>
(Stack (Cursors a) -> m (Stack (Cursors a)))
-> Int -> Cursors a -> m (Cursors a)
descend Stack (Cursors WorkspaceId) -> X (Stack (Cursors WorkspaceId))
f Int
depth)

modifyCursors ::  (Cursors String -> X (Cursors String)) -> X ()
modifyCursors :: (Cursors WorkspaceId -> X (Cursors WorkspaceId)) -> X ()
modifyCursors = ChangeCursors -> X ()
forall a. Message a => a -> X ()
sendMessage (ChangeCursors -> X ())
-> ((Cursors WorkspaceId -> X (Cursors WorkspaceId))
    -> ChangeCursors)
-> (Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cursors WorkspaceId -> X (Cursors WorkspaceId)) -> ChangeCursors
ChangeCursors ((Cursors WorkspaceId -> X (Cursors WorkspaceId)) -> ChangeCursors)
-> ((Cursors WorkspaceId -> X (Cursors WorkspaceId))
    -> Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> (Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> ChangeCursors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((X () -> X (Cursors WorkspaceId) -> X (Cursors WorkspaceId))
-> (Cursors WorkspaceId -> X ())
-> (Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> Cursors WorkspaceId
-> X (Cursors WorkspaceId)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 X () -> X (Cursors WorkspaceId) -> X (Cursors WorkspaceId)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) Cursors WorkspaceId -> X ()
updateXMD Cursors WorkspaceId -> X (Cursors WorkspaceId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> (Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> Cursors WorkspaceId
-> X (Cursors WorkspaceId)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<)

newtype WorkspaceCursors a = WorkspaceCursors (Cursors String)
    deriving (ReadPrec [WorkspaceCursors a]
ReadPrec (WorkspaceCursors a)
Int -> ReadS (WorkspaceCursors a)
ReadS [WorkspaceCursors a]
(Int -> ReadS (WorkspaceCursors a))
-> ReadS [WorkspaceCursors a]
-> ReadPrec (WorkspaceCursors a)
-> ReadPrec [WorkspaceCursors a]
-> Read (WorkspaceCursors a)
forall a. ReadPrec [WorkspaceCursors a]
forall a. ReadPrec (WorkspaceCursors a)
forall a. Int -> ReadS (WorkspaceCursors a)
forall a. ReadS [WorkspaceCursors a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WorkspaceCursors a]
$creadListPrec :: forall a. ReadPrec [WorkspaceCursors a]
readPrec :: ReadPrec (WorkspaceCursors a)
$creadPrec :: forall a. ReadPrec (WorkspaceCursors a)
readList :: ReadS [WorkspaceCursors a]
$creadList :: forall a. ReadS [WorkspaceCursors a]
readsPrec :: Int -> ReadS (WorkspaceCursors a)
$creadsPrec :: forall a. Int -> ReadS (WorkspaceCursors a)
Read,Int -> WorkspaceCursors a -> ShowS
[WorkspaceCursors a] -> ShowS
WorkspaceCursors a -> WorkspaceId
(Int -> WorkspaceCursors a -> ShowS)
-> (WorkspaceCursors a -> WorkspaceId)
-> ([WorkspaceCursors a] -> ShowS)
-> Show (WorkspaceCursors a)
forall a. Int -> WorkspaceCursors a -> ShowS
forall a. [WorkspaceCursors a] -> ShowS
forall a. WorkspaceCursors a -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceCursors a] -> ShowS
$cshowList :: forall a. [WorkspaceCursors a] -> ShowS
show :: WorkspaceCursors a -> WorkspaceId
$cshow :: forall a. WorkspaceCursors a -> WorkspaceId
showsPrec :: Int -> WorkspaceCursors a -> ShowS
$cshowsPrec :: forall a. Int -> WorkspaceCursors a -> ShowS
Show)

-- | The state is stored in the 'WorkspaceCursors' layout modifier. Put this as
-- your outermost modifier, unless you want different cursors at different
-- times (using "XMonad.Layout.MultiToggle")
workspaceCursors :: Cursors String -> l a -> ModifiedLayout WorkspaceCursors l a
workspaceCursors :: forall (l :: * -> *) a.
Cursors WorkspaceId -> l a -> ModifiedLayout WorkspaceCursors l a
workspaceCursors = WorkspaceCursors a -> l a -> ModifiedLayout WorkspaceCursors l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (WorkspaceCursors a -> l a -> ModifiedLayout WorkspaceCursors l a)
-> (Cursors WorkspaceId -> WorkspaceCursors a)
-> Cursors WorkspaceId
-> l a
-> ModifiedLayout WorkspaceCursors l a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursors WorkspaceId -> WorkspaceCursors a
forall a. Cursors WorkspaceId -> WorkspaceCursors a
WorkspaceCursors

newtype ChangeCursors = ChangeCursors { ChangeCursors -> Cursors WorkspaceId -> X (Cursors WorkspaceId)
unWrap :: Cursors String -> X (Cursors String) }

instance Message ChangeCursors

updateXMD ::  Cursors WorkspaceId -> X ()
updateXMD :: Cursors WorkspaceId -> X ()
updateXMD Cursors WorkspaceId
cs = do
    Bool
changed <- (XState -> Bool) -> X Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Bool) -> X Bool) -> (XState -> Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ (Cursors WorkspaceId -> WorkspaceId
forall b. Cursors b -> b
getFocus Cursors WorkspaceId
cs WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
/=) (WorkspaceId -> Bool) -> (XState -> WorkspaceId) -> XState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag (WindowSet -> WorkspaceId)
-> (XState -> WindowSet) -> XState -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ 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 (WorkspaceId -> WindowSet -> WindowSet)
-> WorkspaceId -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ Cursors WorkspaceId -> WorkspaceId
forall b. Cursors b -> b
getFocus Cursors WorkspaceId
cs

instance LayoutModifier WorkspaceCursors a where
    redoLayout :: WorkspaceCursors a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (WorkspaceCursors a))
redoLayout (WorkspaceCursors Cursors WorkspaceId
cs) Rectangle
_ Maybe (Stack a)
_ [(a, Rectangle)]
arrs = do
        WorkspaceId
cws <- (XState -> WorkspaceId) -> X WorkspaceId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> WorkspaceId) -> X WorkspaceId)
-> (XState -> WorkspaceId) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ WindowSet -> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag (WindowSet -> WorkspaceId)
-> (XState -> WindowSet) -> XState -> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        ([(a, Rectangle)], Maybe (WorkspaceCursors a))
-> X ([(a, Rectangle)], Maybe (WorkspaceCursors a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
arrs,Cursors WorkspaceId -> WorkspaceCursors a
forall a. Cursors WorkspaceId -> WorkspaceCursors a
WorkspaceCursors (Cursors WorkspaceId -> WorkspaceCursors a)
-> Maybe (Cursors WorkspaceId) -> Maybe (WorkspaceCursors a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WorkspaceId -> Cursors WorkspaceId -> Maybe (Cursors WorkspaceId)
forall t. Eq t => t -> Cursors t -> Maybe (Cursors t)
focusTo WorkspaceId
cws Cursors WorkspaceId
cs)

    handleMess :: WorkspaceCursors a -> SomeMessage -> X (Maybe (WorkspaceCursors a))
handleMess (WorkspaceCursors Cursors WorkspaceId
cs) SomeMessage
m =
        (ChangeCursors -> X (WorkspaceCursors a))
-> Maybe ChangeCursors -> X (Maybe (WorkspaceCursors a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Cursors WorkspaceId -> WorkspaceCursors a)
-> X (Cursors WorkspaceId) -> X (WorkspaceCursors a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cursors WorkspaceId -> WorkspaceCursors a
forall a. Cursors WorkspaceId -> WorkspaceCursors a
WorkspaceCursors (X (Cursors WorkspaceId) -> X (WorkspaceCursors a))
-> (ChangeCursors -> X (Cursors WorkspaceId))
-> ChangeCursors
-> X (WorkspaceCursors a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> Cursors WorkspaceId -> X (Cursors WorkspaceId)
forall a b. (a -> b) -> a -> b
$ Cursors WorkspaceId
cs) ((Cursors WorkspaceId -> X (Cursors WorkspaceId))
 -> X (Cursors WorkspaceId))
-> (ChangeCursors
    -> Cursors WorkspaceId -> X (Cursors WorkspaceId))
-> ChangeCursors
-> X (Cursors WorkspaceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeCursors -> Cursors WorkspaceId -> X (Cursors WorkspaceId)
unWrap) (SomeMessage -> Maybe ChangeCursors
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m)