{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
module XMonad.Actions.TreeSelect
(
treeselectWorkspace
, toWorkspaces
, treeselectAction
, Pixel
, TSConfig(..)
, tsDefaultConfig
, def
, defaultNavigation
, select
, cancel
, moveParent
, moveChild
, moveNext
, movePrev
, moveHistBack
, moveHistForward
, moveTo
, TSNode(..)
, treeselect
, treeselectAt
) where
import Control.Monad.Reader
import Control.Monad.State
import Data.Tree
import Foreign (shiftL, shiftR, (.&.))
import System.IO
import XMonad hiding (liftX)
import XMonad.Prelude
import XMonad.StackSet as W
import XMonad.Util.Font
import XMonad.Util.NamedWindows
import XMonad.Util.TreeZipper
import XMonad.Hooks.WorkspaceHistory
import qualified Data.Map as M
#ifdef XFT
import qualified Data.List.NonEmpty as NE
import Graphics.X11.Xrender
import Graphics.X11.Xft
#endif
data TSConfig a = TSConfig { forall a. TSConfig a -> Bool
ts_hidechildren :: Bool
, forall a. TSConfig a -> Pixel
ts_background :: Pixel
, forall a. TSConfig a -> WorkspaceId
ts_font :: String
, forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
, forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
, forall a. TSConfig a -> (Pixel, Pixel)
ts_highlight :: (Pixel, Pixel)
, :: Pixel
, forall a. TSConfig a -> Int
ts_node_width :: Int
, forall a. TSConfig a -> Int
ts_node_height :: Int
, forall a. TSConfig a -> Int
ts_originX :: Int
, forall a. TSConfig a -> Int
ts_originY :: Int
, forall a. TSConfig a -> Int
ts_indent :: Int
, forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a))
}
instance Default (TSConfig a) where
def :: TSConfig a
def = TSConfig { ts_hidechildren :: Bool
ts_hidechildren = Bool
True
, ts_background :: Pixel
ts_background = Pixel
0xc0c0c0c0
, ts_font :: WorkspaceId
ts_font = WorkspaceId
"xft:Sans-16"
, ts_node :: (Pixel, Pixel)
ts_node = (Pixel
0xff000000, Pixel
0xff50d0db)
, ts_nodealt :: (Pixel, Pixel)
ts_nodealt = (Pixel
0xff000000, Pixel
0xff10b8d6)
, ts_highlight :: (Pixel, Pixel)
ts_highlight = (Pixel
0xffffffff, Pixel
0xffff0000)
, ts_extra :: Pixel
ts_extra = Pixel
0xff000000
, ts_node_width :: Int
ts_node_width = Int
200
, ts_node_height :: Int
ts_node_height = Int
30
, ts_originX :: Int
ts_originX = Int
0
, ts_originY :: Int
ts_originY = Int
0
, ts_indent :: Int
ts_indent = Int
80
, ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate = forall a. Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
defaultNavigation
}
defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a))
defaultNavigation :: forall a. Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
defaultNavigation = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ ((KeyMask
0, Pixel
xK_Escape), forall a. TreeSelect a (Maybe a)
cancel)
, ((KeyMask
0, Pixel
xK_Return), forall a. TreeSelect a (Maybe a)
select)
, ((KeyMask
0, Pixel
xK_space), forall a. TreeSelect a (Maybe a)
select)
, ((KeyMask
0, Pixel
xK_Up), forall a. TreeSelect a (Maybe a)
movePrev)
, ((KeyMask
0, Pixel
xK_Down), forall a. TreeSelect a (Maybe a)
moveNext)
, ((KeyMask
0, Pixel
xK_Left), forall a. TreeSelect a (Maybe a)
moveParent)
, ((KeyMask
0, Pixel
xK_Right), forall a. TreeSelect a (Maybe a)
moveChild)
, ((KeyMask
0, Pixel
xK_k), forall a. TreeSelect a (Maybe a)
movePrev)
, ((KeyMask
0, Pixel
xK_j), forall a. TreeSelect a (Maybe a)
moveNext)
, ((KeyMask
0, Pixel
xK_h), forall a. TreeSelect a (Maybe a)
moveParent)
, ((KeyMask
0, Pixel
xK_l), forall a. TreeSelect a (Maybe a)
moveChild)
, ((KeyMask
0, Pixel
xK_o), forall a. TreeSelect a (Maybe a)
moveHistBack)
, ((KeyMask
0, Pixel
xK_i), forall a. TreeSelect a (Maybe a)
moveHistForward)
]
tsDefaultConfig :: TSConfig a
tsDefaultConfig :: forall a. TSConfig a
tsDefaultConfig = forall a. Default a => a
def
{-# DEPRECATED tsDefaultConfig "Use def (from Data.Default, and re-exported by XMonad.Actions.TreeSelect) instead." #-}
data TSNode a = TSNode { forall a. TSNode a -> WorkspaceId
tsn_name :: String
, :: String
, forall a. TSNode a -> a
tsn_value :: a
}
data TSState a = TSState { forall a. TSState a -> TreeZipper (TSNode a)
tss_tree :: TreeZipper (TSNode a)
, forall a. TSState a -> Pixel
tss_window :: Window
, forall a. TSState a -> Display
tss_display :: Display
, forall a. TSState a -> (Int, Int)
tss_size :: (Int, Int)
, forall a. TSState a -> XMonadFont
tss_xfont :: XMonadFont
, forall a. TSState a -> GC
tss_gc :: GC
, forall a. TSState a -> Visual
tss_visual :: Visual
, forall a. TSState a -> Pixel
tss_colormap :: Colormap
, forall a. TSState a -> ([[WorkspaceId]], [[WorkspaceId]])
tss_history :: ([[String]], [[String]])
}
newtype TreeSelect a b = TreeSelect { forall a b.
TreeSelect a b -> ReaderT (TSConfig a) (StateT (TSState a) X) b
runTreeSelect :: ReaderT (TSConfig a) (StateT (TSState a) X) b }
deriving (forall {a}. Applicative (TreeSelect a)
forall a. a -> TreeSelect a a
forall a a. a -> TreeSelect a a
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> TreeSelect a a
$creturn :: forall a a. a -> TreeSelect a a
>> :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$c>> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
>>= :: forall a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
$c>>= :: forall a a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
Monad, forall {a}. Functor (TreeSelect a)
forall a. a -> TreeSelect a a
forall a a. a -> TreeSelect a a
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
forall a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
forall a a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
$c<* :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
*> :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$c*> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
liftA2 :: forall a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
$cliftA2 :: forall a a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
<*> :: forall a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
$c<*> :: forall a a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
pure :: forall a. a -> TreeSelect a a
$cpure :: forall a a. a -> TreeSelect a a
Applicative, forall a b. a -> TreeSelect a b -> TreeSelect a a
forall a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
forall a a b. a -> TreeSelect a b -> TreeSelect a a
forall a a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TreeSelect a b -> TreeSelect a a
$c<$ :: forall a a b. a -> TreeSelect a b -> TreeSelect a a
fmap :: forall a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
$cfmap :: forall a a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
Functor, MonadState (TSState a), MonadReader (TSConfig a), forall a. Monad (TreeSelect a)
forall a. IO a -> TreeSelect a a
forall a a. IO a -> TreeSelect a a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> TreeSelect a a
$cliftIO :: forall a a. IO a -> TreeSelect a a
MonadIO)
liftX :: X a -> TreeSelect b a
liftX :: forall a b. X a -> TreeSelect b a
liftX = forall a b.
ReaderT (TSConfig a) (StateT (TSState a) X) b -> TreeSelect a b
TreeSelect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
treeselect :: TSConfig a
-> Forest (TSNode a)
-> X (Maybe a)
treeselect :: forall a. TSConfig a -> Forest (TSNode a) -> X (Maybe a)
treeselect TSConfig a
c Forest (TSNode a)
t = forall a.
TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
treeselectAt TSConfig a
c (forall a. Forest a -> TreeZipper a
fromForest Forest (TSNode a)
t) []
treeselectAt :: TSConfig a
-> TreeZipper (TSNode a)
-> [[String]]
-> X (Maybe a)
treeselectAt :: forall a.
TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
treeselectAt conf :: TSConfig a
conf@TSConfig{Bool
Int
WorkspaceId
Pixel
(Pixel, Pixel)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: Int
ts_originY :: Int
ts_originX :: Int
ts_node_height :: Int
ts_node_width :: Int
ts_extra :: Pixel
ts_highlight :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
ts_font :: WorkspaceId
ts_background :: Pixel
ts_hidechildren :: Bool
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_node_width :: forall a. TSConfig a -> Int
ts_extra :: forall a. TSConfig a -> Pixel
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} TreeZipper (TSNode a)
zipper [[WorkspaceId]]
hist = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
display -> do
Pixel
rootw <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Pixel
theRoot
Rectangle{Position
Dimension
rect_x :: Rectangle -> Position
rect_y :: Rectangle -> Position
rect_width :: Rectangle -> Dimension
rect_height :: Rectangle -> Dimension
rect_height :: Dimension
rect_width :: Dimension
rect_y :: Position
rect_x :: Position
..} <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
Just VisualInfo
vinfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Dimension -> CInt -> CInt -> IO (Maybe VisualInfo)
matchVisualInfo Display
display (Display -> Dimension
defaultScreen Display
display) CInt
32 CInt
4
Pixel
colormap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Visual -> CInt -> IO Pixel
createColormap Display
display Pixel
rootw (VisualInfo -> Visual
visualInfo_visual VisualInfo
vinfo) CInt
allocNone
Pixel
win <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
attributes -> do
Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
Ptr SetWindowAttributes -> Pixel -> IO ()
set_colormap Ptr SetWindowAttributes
attributes Pixel
colormap
Ptr SetWindowAttributes -> Pixel -> IO ()
set_background_pixel Ptr SetWindowAttributes
attributes Pixel
ts_background
Ptr SetWindowAttributes -> Pixel -> IO ()
set_border_pixel Ptr SetWindowAttributes
attributes Pixel
0
Pixel
w <- Display
-> Pixel
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> Pixel
-> Ptr SetWindowAttributes
-> IO Pixel
createWindow Display
display Pixel
rootw Position
rect_x Position
rect_y Dimension
rect_width Dimension
rect_height CInt
0 (VisualInfo -> CInt
visualInfo_depth VisualInfo
vinfo) CInt
inputOutput (VisualInfo -> Visual
visualInfo_visual VisualInfo
vinfo) (Pixel
cWColormap forall a. Bits a => a -> a -> a
.|. Pixel
cWBorderPixel forall a. Bits a => a -> a -> a
.|. Pixel
cWBackPixel) Ptr SetWindowAttributes
attributes
Display -> Pixel -> ClassHint -> IO ()
setClassHint Display
display Pixel
w (WorkspaceId -> WorkspaceId -> ClassHint
ClassHint WorkspaceId
"xmonad-tree_select" WorkspaceId
"xmonad")
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel
w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Display -> Pixel -> IO ()
mapWindow Display
display Pixel
win
Display -> Pixel -> Pixel -> IO ()
selectInput Display
display Pixel
win (Pixel
exposureMask forall a. Bits a => a -> a -> a
.|. Pixel
keyPressMask forall a. Bits a => a -> a -> a
.|. Pixel
buttonReleaseMask)
Display
-> Dimension
-> KeyMask
-> Pixel
-> Bool
-> Pixel
-> CInt
-> CInt
-> Pixel
-> Pixel
-> IO ()
grabButton Display
display Dimension
button1 KeyMask
anyModifier Pixel
win Bool
True Pixel
buttonReleaseMask CInt
grabModeAsync CInt
grabModeAsync Pixel
none Pixel
none
CInt
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Bool -> CInt -> CInt -> Pixel -> IO CInt
grabKeyboard Display
display Pixel
win Bool
True CInt
grabModeAsync CInt
grabModeAsync Pixel
currentTime
Maybe a
r <- if CInt
status forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess
then do
GC
gc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO GC
createGC Display
display Pixel
win
XMonadFont
xfont <- WorkspaceId -> X XMonadFont
initXMF WorkspaceId
ts_font
Maybe a
ret <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a b.
TreeSelect a b -> ReaderT (TSConfig a) (StateT (TSState a) X) b
runTreeSelect (forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate)) TSConfig a
conf)
TSState{ tss_tree :: TreeZipper (TSNode a)
tss_tree = TreeZipper (TSNode a)
zipper
, tss_window :: Pixel
tss_window = Pixel
win
, tss_display :: Display
tss_display = Display
display
, tss_xfont :: XMonadFont
tss_xfont = XMonadFont
xfont
, tss_size :: (Int, Int)
tss_size = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
rect_width, forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
rect_height)
, tss_gc :: GC
tss_gc = GC
gc
, tss_visual :: Visual
tss_visual = VisualInfo -> Visual
visualInfo_visual VisualInfo
vinfo
, tss_colormap :: Pixel
tss_colormap = Pixel
colormap
, tss_history :: ([[WorkspaceId]], [[WorkspaceId]])
tss_history = ([], [[WorkspaceId]]
hist)
}
XMonadFont -> X ()
releaseXMF XMonadFont
xfont
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC Display
display GC
gc
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
ret
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Display -> Pixel -> IO ()
unmapWindow Display
display Pixel
win
Display -> Pixel -> IO ()
destroyWindow Display
display Pixel
win
Display -> Pixel -> IO ()
freeColormap Display
display Pixel
colormap
Display -> Bool -> IO ()
sync Display
display Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r
treeselectWorkspace :: TSConfig WorkspaceId
-> Forest String
-> (WorkspaceId -> WindowSet -> WindowSet)
-> X ()
treeselectWorkspace :: TSConfig WorkspaceId
-> Forest WorkspaceId
-> (WorkspaceId -> WindowSet -> WindowSet)
-> X ()
treeselectWorkspace TSConfig WorkspaceId
c Forest WorkspaceId
xs WorkspaceId -> WindowSet -> WindowSet
f = do
[Workspace WorkspaceId (Layout Pixel) Pixel]
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall i l a. Workspace i l a -> i
tag [Workspace WorkspaceId (Layout Pixel) Pixel]
ws) (Forest WorkspaceId -> [WorkspaceId]
toWorkspaces Forest WorkspaceId
xs)
then do
[Tree (TSNode WorkspaceId)]
wsf <- forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
[Tree a] -> (a -> m b) -> m [Tree b]
forMForest (Forest WorkspaceId -> Forest (WorkspaceId, WorkspaceId)
mkPaths Forest WorkspaceId
xs) forall a b. (a -> b) -> a -> b
$ \(WorkspaceId
n, WorkspaceId
i) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. WorkspaceId -> WorkspaceId -> a -> TSNode a
TSNode WorkspaceId
n WorkspaceId
"Does not exist!" WorkspaceId
"")) (forall {a} {l}. WorkspaceId -> Workspace a l Pixel -> X (TSNode a)
mkNode WorkspaceId
n) (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Workspace WorkspaceId (Layout Pixel) Pixel
w -> WorkspaceId
i forall a. Eq a => a -> a -> Bool
== forall i l a. Workspace i l a -> i
tag Workspace WorkspaceId (Layout Pixel) Pixel
w) [Workspace WorkspaceId (Layout Pixel) Pixel]
ws)
WorkspaceId
me <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
[WorkspaceId]
hist <- X [WorkspaceId]
workspaceHistory
forall a.
TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
treeselectAt TSConfig WorkspaceId
c (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall b a.
Eq b =>
(a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a)
followPath forall a. TSNode a -> WorkspaceId
tsn_name (WorkspaceId -> [WorkspaceId]
splitPath WorkspaceId
me) forall a b. (a -> b) -> a -> b
$ forall a. Forest a -> TreeZipper a
fromForest [Tree (TSNode WorkspaceId)]
wsf) (forall a b. (a -> b) -> [a] -> [b]
map WorkspaceId -> [WorkspaceId]
splitPath [WorkspaceId]
hist) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId -> WindowSet -> WindowSet
f)
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let msg :: WorkspaceId
msg = [WorkspaceId] -> WorkspaceId
unlines forall a b. (a -> b) -> a -> b
$ [ WorkspaceId
"Please add:"
, WorkspaceId
" workspaces = toWorkspaces myWorkspaces"
, WorkspaceId
"to your XMonad config!"
, WorkspaceId
""
, WorkspaceId
"XConfig.workspaces: "
] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall i l a. Workspace i l a -> i
tag [Workspace WorkspaceId (Layout Pixel) Pixel]
ws
Handle -> WorkspaceId -> IO ()
hPutStrLn Handle
stderr WorkspaceId
msg
forall (m :: * -> *). MonadIO m => WorkspaceId -> m ()
xmessage WorkspaceId
msg
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
mkNode :: WorkspaceId -> Workspace a l Pixel -> X (TSNode a)
mkNode WorkspaceId
n Workspace a l Pixel
w = do
WorkspaceId
name <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceId
"") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> WorkspaceId
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel -> X NamedWindow
getName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stack a -> a
W.focus) forall a b. (a -> b) -> a -> b
$ forall i l a. Workspace i l a -> Maybe (Stack a)
stack Workspace a l Pixel
w
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. WorkspaceId -> WorkspaceId -> a -> TSNode a
TSNode WorkspaceId
n WorkspaceId
name (forall i l a. Workspace i l a -> i
tag Workspace a l Pixel
w)
toWorkspaces :: Forest String -> [WorkspaceId]
toWorkspaces :: Forest WorkspaceId -> [WorkspaceId]
toWorkspaces = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest WorkspaceId -> Forest (WorkspaceId, WorkspaceId)
mkPaths
mkPaths :: Forest String -> Forest (String, WorkspaceId)
mkPaths :: Forest WorkspaceId -> Forest (WorkspaceId, WorkspaceId)
mkPaths = forall a b. (a -> b) -> [a] -> [b]
map (\(Node WorkspaceId
n Forest WorkspaceId
ns) -> forall a. a -> [Tree a] -> Tree a
Node (WorkspaceId
n, WorkspaceId
n) (forall a b. (a -> b) -> [a] -> [b]
map (WorkspaceId -> Tree WorkspaceId -> Tree (WorkspaceId, WorkspaceId)
f WorkspaceId
n) Forest WorkspaceId
ns))
where
f :: WorkspaceId -> Tree WorkspaceId -> Tree (WorkspaceId, WorkspaceId)
f WorkspaceId
pth (Node WorkspaceId
x Forest WorkspaceId
xs) = let pth' :: WorkspaceId
pth' = WorkspaceId
pth forall a. [a] -> [a] -> [a]
++ Char
'.' forall a. a -> [a] -> [a]
: WorkspaceId
x
in forall a. a -> [Tree a] -> Tree a
Node (WorkspaceId
x, WorkspaceId
pth') (forall a b. (a -> b) -> [a] -> [b]
map (WorkspaceId -> Tree WorkspaceId -> Tree (WorkspaceId, WorkspaceId)
f WorkspaceId
pth') Forest WorkspaceId
xs)
splitPath :: WorkspaceId -> [String]
splitPath :: WorkspaceId -> [WorkspaceId]
splitPath WorkspaceId
i = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'.') WorkspaceId
i of
(WorkspaceId
x, []) -> [WorkspaceId
x]
(WorkspaceId
x, Char
_:WorkspaceId
xs) -> WorkspaceId
x forall a. a -> [a] -> [a]
: WorkspaceId -> [WorkspaceId]
splitPath WorkspaceId
xs
treeselectAction :: TSConfig (X a) -> Forest (TSNode (X a)) -> X ()
treeselectAction :: forall a. TSConfig (X a) -> Forest (TSNode (X a)) -> X ()
treeselectAction TSConfig (X a)
c Forest (TSNode (X a))
xs = forall a. TSConfig a -> Forest (TSNode a) -> X (Maybe a)
treeselect TSConfig (X a)
c Forest (TSNode (X a))
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just X a
a -> forall (f :: * -> *) a. Functor f => f a -> f ()
void X a
a
Maybe (X a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forMForest :: (Functor m, Applicative m, Monad m) => [Tree a] -> (a -> m b) -> m [Tree b]
forMForest :: forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
[Tree a] -> (a -> m b) -> m [Tree b]
forMForest [Tree a]
x a -> m b
g = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
(a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
g) [Tree a]
x
mapMTree :: (Functor m, Applicative m, Monad m) => (a -> m b) -> Tree a -> m (Tree b)
mapMTree :: forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
(a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
f (Node a
x [Tree a]
xs) = forall a. a -> [Tree a] -> Tree a
Node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
(a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
f) [Tree a]
xs
select :: TreeSelect a (Maybe a)
select :: forall a. TreeSelect a (Maybe a)
select = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. TSNode a -> a
tsn_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TreeZipper a -> a
cursor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TSState a -> TreeZipper (TSNode a)
tss_tree))
cancel :: TreeSelect a (Maybe a)
cancel :: forall a. TreeSelect a (Maybe a)
cancel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
moveParent :: TreeSelect a (Maybe a)
moveParent :: forall a. TreeSelect a (Maybe a)
moveParent = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
parent forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate
moveChild :: TreeSelect a (Maybe a)
moveChild :: forall a. TreeSelect a (Maybe a)
moveChild = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
children forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate
moveNext :: TreeSelect a (Maybe a)
moveNext :: forall a. TreeSelect a (Maybe a)
moveNext = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
nextChild forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate
movePrev :: TreeSelect a (Maybe a)
movePrev :: forall a. TreeSelect a (Maybe a)
movePrev = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
previousChild forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate
moveHistBack :: TreeSelect a (Maybe a)
moveHistBack :: forall a. TreeSelect a (Maybe a)
moveHistBack = do
TSState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
case forall a. TSState a -> ([[WorkspaceId]], [[WorkspaceId]])
tss_history TSState a
s of
([[WorkspaceId]]
xs, [WorkspaceId]
a:[WorkspaceId]
y:[[WorkspaceId]]
ys) -> do
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{tss_history :: ([[WorkspaceId]], [[WorkspaceId]])
tss_history = ([WorkspaceId]
aforall a. a -> [a] -> [a]
:[[WorkspaceId]]
xs, [WorkspaceId]
yforall a. a -> [a] -> [a]
:[[WorkspaceId]]
ys)}
forall a. [WorkspaceId] -> TreeSelect a (Maybe a)
moveTo [WorkspaceId]
y
([[WorkspaceId]], [[WorkspaceId]])
_ -> forall a. TreeSelect a (Maybe a)
navigate
moveHistForward :: TreeSelect a (Maybe a)
moveHistForward :: forall a. TreeSelect a (Maybe a)
moveHistForward = do
TSState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
case forall a. TSState a -> ([[WorkspaceId]], [[WorkspaceId]])
tss_history TSState a
s of
([WorkspaceId]
x:[[WorkspaceId]]
xs, [[WorkspaceId]]
ys) -> do
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{tss_history :: ([[WorkspaceId]], [[WorkspaceId]])
tss_history = ([[WorkspaceId]]
xs, [WorkspaceId]
xforall a. a -> [a] -> [a]
:[[WorkspaceId]]
ys)}
forall a. [WorkspaceId] -> TreeSelect a (Maybe a)
moveTo [WorkspaceId]
x
([[WorkspaceId]], [[WorkspaceId]])
_ -> forall a. TreeSelect a (Maybe a)
navigate
moveTo :: [String]
-> TreeSelect a (Maybe a)
moveTo :: forall a. [WorkspaceId] -> TreeSelect a (Maybe a)
moveTo [WorkspaceId]
i = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith (forall b a.
Eq b =>
(a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a)
followPath forall a. TSNode a -> WorkspaceId
tsn_name [WorkspaceId]
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TreeZipper a -> TreeZipper a
rootNode) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate
moveWith :: (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))) -> TreeSelect a ()
moveWith :: forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
f = do
TSState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
case TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
f (forall a. TSState a -> TreeZipper (TSNode a)
tss_tree TSState a
s) of
Just TreeZipper (TSNode a)
t -> forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{ tss_tree :: TreeZipper (TSNode a)
tss_tree = TreeZipper (TSNode a)
t }
Maybe (TreeZipper (TSNode a))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
navigate :: TreeSelect a (Maybe a)
navigate :: forall a. TreeSelect a (Maybe a)
navigate = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Display
tss_display forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
Display -> Pixel -> XEventPtr -> IO ()
maskEvent Display
d (Pixel
exposureMask forall a. Bits a => a -> a -> a
.|. Pixel
keyPressMask forall a. Bits a => a -> a -> a
.|. Pixel
buttonReleaseMask forall a. Bits a => a -> a -> a
.|. Pixel
buttonPressMask) XEventPtr
e
Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
if | Event -> Dimension
ev_event_type Event
ev forall a. Eq a => a -> a -> Bool
== Dimension
keyPress -> do
Pixel
ks <- Display -> KeyCode -> CInt -> IO Pixel
keycodeToKeysym Display
d (Event -> KeyCode
ev_keycode Event
ev) CInt
0
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
KeyMask
mask <- forall a b. X a -> TreeSelect b a
liftX forall a b. (a -> b) -> a -> b
$ X (KeyMask -> KeyMask)
cleanKeyMask forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event -> KeyMask
ev_state Event
ev)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
f <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate
forall a. a -> Maybe a -> a
fromMaybe forall a. TreeSelect a (Maybe a)
navigate forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
mask, Pixel
ks) Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
f
| Event -> Dimension
ev_event_type Event
ev forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress -> do
Display -> CInt -> Pixel -> IO ()
allowEvents Display
d CInt
replayPointer Pixel
currentTime
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. TreeSelect a (Maybe a)
navigate
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. TreeSelect a (Maybe a)
navigate
redraw :: TreeSelect a ()
redraw :: forall a. TreeSelect a ()
redraw = do
Pixel
win <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Pixel
tss_window
Display
dpy <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Display
tss_display
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO ()
clearWindow Display
dpy Pixel
win
TreeZipper (TSNode a)
t <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> TreeZipper (TSNode a)
tss_tree
Int
_ <- forall a.
Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers Int
0 Int
0 (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ (forall a. TreeZipper a -> Forest a
tz_before TreeZipper (TSNode a)
t, forall a. TreeZipper a -> a
cursor TreeZipper (TSNode a)
t, forall a. TreeZipper a -> Forest a
tz_after TreeZipper (TSNode a)
t) forall a. a -> [a] -> [a]
: forall a. TreeZipper a -> [(Forest a, a, Forest a)]
tz_parents TreeZipper (TSNode a)
t)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawLayers :: Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers :: forall a.
Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers Int
_ Int
yl [] = forall (m :: * -> *) a. Monad m => a -> m a
return Int
yl
drawLayers Int
xl Int
yl ((Forest (TSNode a)
bs, TSNode a
c, Forest (TSNode a)
as):[(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs) = do
TSConfig{Bool
Int
WorkspaceId
Pixel
(Pixel, Pixel)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: Int
ts_originY :: Int
ts_originX :: Int
ts_node_height :: Int
ts_node_width :: Int
ts_extra :: Pixel
ts_highlight :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
ts_font :: WorkspaceId
ts_background :: Pixel
ts_hidechildren :: Bool
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_node_width :: forall a. TSConfig a -> Int
ts_extra :: forall a. TSConfig a -> Pixel
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
let nodeColor :: a -> (Pixel, Pixel)
nodeColor a
y = if forall a. Integral a => a -> Bool
odd a
y then (Pixel, Pixel)
ts_node else (Pixel, Pixel)
ts_nodealt
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
yl ..] (forall a. [a] -> [a]
reverse Forest (TSNode a)
bs)) forall a b. (a -> b) -> a -> b
$ \(Int
y, Node TSNode a
n Forest (TSNode a)
_) ->
forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
y TSNode a
n (forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
y)
let current_level :: Int
current_level = Int
yl forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
bs
forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
current_level TSNode a
c forall a b. (a -> b) -> a -> b
$
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs then (Pixel, Pixel)
ts_highlight
else forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
current_level
Int
l2 <- forall a.
Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers (Int
xl forall a. Num a => a -> a -> a
+ Int
1) (Int
current_level forall a. Num a => a -> a -> a
+ Int
1) [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
l2 ..] Forest (TSNode a)
as) forall a b. (a -> b) -> a -> b
$ \(Int
y, Node TSNode a
n Forest (TSNode a)
_) ->
forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
y TSNode a
n (forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l2 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
as)
drawNode :: Int
-> Int
-> TSNode a
-> (Pixel, Pixel)
-> TreeSelect a ()
drawNode :: forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
ix Int
iy TSNode{a
WorkspaceId
tsn_value :: a
tsn_extra :: WorkspaceId
tsn_name :: WorkspaceId
tsn_value :: forall a. TSNode a -> a
tsn_extra :: forall a. TSNode a -> WorkspaceId
tsn_name :: forall a. TSNode a -> WorkspaceId
..} (Pixel, Pixel)
col = do
TSConfig{Bool
Int
WorkspaceId
Pixel
(Pixel, Pixel)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: Int
ts_originY :: Int
ts_originX :: Int
ts_node_height :: Int
ts_node_width :: Int
ts_extra :: Pixel
ts_highlight :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
ts_font :: WorkspaceId
ts_background :: Pixel
ts_hidechildren :: Bool
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_node_width :: forall a. TSConfig a -> Int
ts_extra :: forall a. TSConfig a -> Pixel
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
Pixel
window <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Pixel
tss_window
Display
display <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Display
tss_display
XMonadFont
font <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> XMonadFont
tss_xfont
GC
gc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> GC
tss_gc
Pixel
colormap <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Pixel
tss_colormap
Visual
visual <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Visual
tss_visual
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pixel
-> Display
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> (Pixel, Pixel)
-> WorkspaceId
-> Pixel
-> WorkspaceId
-> Int
-> Int
-> Int
-> Int
-> IO ()
drawWinBox Pixel
window Display
display Visual
visual Pixel
colormap GC
gc XMonadFont
font (Pixel, Pixel)
col WorkspaceId
tsn_name Pixel
ts_extra WorkspaceId
tsn_extra
(Int
ix forall a. Num a => a -> a -> a
* Int
ts_indent forall a. Num a => a -> a -> a
+ Int
ts_originX) (Int
iy forall a. Num a => a -> a -> a
* Int
ts_node_height forall a. Num a => a -> a -> a
+ Int
ts_originY)
Int
ts_node_width Int
ts_node_height
drawWinBox :: Window -> Display -> Visual -> Colormap -> GC -> XMonadFont -> (Pixel, Pixel) -> String -> Pixel -> String -> Int -> Int -> Int -> Int -> IO ()
drawWinBox :: Pixel
-> Display
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> (Pixel, Pixel)
-> WorkspaceId
-> Pixel
-> WorkspaceId
-> Int
-> Int
-> Int
-> Int
-> IO ()
drawWinBox Pixel
win Display
display Visual
visual Pixel
colormap GC
gc XMonadFont
font (Pixel
fg, Pixel
bg) WorkspaceId
text Pixel
fg2 WorkspaceId
text2 Int
x Int
y Int
w Int
h = do
Display -> GC -> Pixel -> IO ()
setForeground Display
display GC
gc Pixel
bg
Display
-> Pixel
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
display Pixel
win GC
gc (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> WorkspaceId
-> IO ()
drawStringXMF Display
display Pixel
win Visual
visual Pixel
colormap GC
gc XMonadFont
font Pixel
fg
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
x forall a. Num a => a -> a -> a
+ Int
8)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
y forall a. Num a => a -> a -> a
+ Int
h forall a. Num a => a -> a -> a
- Int
8)
WorkspaceId
text
Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> WorkspaceId
-> IO ()
drawStringXMF Display
display Pixel
win Visual
visual Pixel
colormap GC
gc XMonadFont
font Pixel
fg2
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
x forall a. Num a => a -> a -> a
+ Int
w forall a. Num a => a -> a -> a
+ Int
8)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
y forall a. Num a => a -> a -> a
+ Int
h forall a. Num a => a -> a -> a
- Int
8)
WorkspaceId
text2
drawStringXMF :: Display -> Drawable -> Visual -> Colormap -> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> String
-> IO ()
drawStringXMF :: Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> WorkspaceId
-> IO ()
drawStringXMF Display
display Pixel
window Visual
visual Pixel
colormap GC
gc XMonadFont
font Pixel
col Position
x Position
y WorkspaceId
text = case XMonadFont
font of
Core FontStruct
fnt -> do
Display -> GC -> Pixel -> IO ()
setForeground Display
display GC
gc Pixel
col
Display -> GC -> Pixel -> IO ()
setFont Display
display GC
gc forall a b. (a -> b) -> a -> b
$ FontStruct -> Pixel
fontFromFontStruct FontStruct
fnt
Display
-> Pixel -> GC -> Position -> Position -> WorkspaceId -> IO ()
drawImageString Display
display Pixel
window GC
gc Position
x Position
y WorkspaceId
text
Utf8 FontSet
fnt -> do
Display -> GC -> Pixel -> IO ()
setForeground Display
display GC
gc Pixel
col
Display
-> Pixel
-> FontSet
-> GC
-> Position
-> Position
-> WorkspaceId
-> IO ()
wcDrawImageString Display
display Pixel
window FontSet
fnt GC
gc Position
x Position
y WorkspaceId
text
#ifdef XFT
Xft NonEmpty XftFont
fnts -> do
forall a.
Display -> Pixel -> Visual -> Pixel -> (XftDraw -> IO a) -> IO a
withXftDraw Display
display Pixel
window Visual
visual Pixel
colormap forall a b. (a -> b) -> a -> b
$
\XftDraw
ft_draw -> forall a.
Display
-> Visual -> Pixel -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue Display
display Visual
visual Pixel
colormap (Pixel -> XRenderColor
fromARGB Pixel
col) forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_X11_xft(0, 3, 4)
\XftColor
ft_color -> XftDraw
-> XftColor -> [XftFont] -> Int -> Int -> WorkspaceId -> IO ()
xftDrawStringFallback XftDraw
ft_draw XftColor
ft_color (forall a. NonEmpty a -> [a]
NE.toList NonEmpty XftFont
fnts) (forall a b. (Integral a, Num b) => a -> b
fi Position
x) (forall a b. (Integral a, Num b) => a -> b
fi Position
y) WorkspaceId
text
#else
\ft_color -> xftDrawString ft_draw ft_color (NE.head fnts) x y text
#endif
fromARGB :: Pixel -> XRenderColor
fromARGB :: Pixel -> XRenderColor
fromARGB Pixel
x =
#if MIN_VERSION_X11_xft(0, 3, 3)
Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
r Int
g Int
b Int
a
#else
XRenderColor r b g a
#endif
where
r :: Int
r = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> Int -> a
shiftR Pixel
x Int
8
g :: Int
g = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. Pixel
x
b :: Int
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> Int -> a
shiftL Pixel
x Int
8
a :: Int
a = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> Int -> a
shiftR Pixel
x Int
16
#endif