{-# 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 = Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
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 = [((KeyMask, Pixel), TreeSelect a (Maybe a))]
-> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ ((KeyMask
0, Pixel
xK_Escape), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
cancel)
, ((KeyMask
0, Pixel
xK_Return), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
select)
, ((KeyMask
0, Pixel
xK_space), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
select)
, ((KeyMask
0, Pixel
xK_Up), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
movePrev)
, ((KeyMask
0, Pixel
xK_Down), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveNext)
, ((KeyMask
0, Pixel
xK_Left), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveParent)
, ((KeyMask
0, Pixel
xK_Right), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveChild)
, ((KeyMask
0, Pixel
xK_k), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
movePrev)
, ((KeyMask
0, Pixel
xK_j), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveNext)
, ((KeyMask
0, Pixel
xK_h), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveParent)
, ((KeyMask
0, Pixel
xK_l), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveChild)
, ((KeyMask
0, Pixel
xK_o), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveHistBack)
, ((KeyMask
0, Pixel
xK_i), TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
moveHistForward)
]
tsDefaultConfig :: TSConfig a
tsDefaultConfig :: forall a. TSConfig a
tsDefaultConfig = TSConfig a
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 (Applicative (TreeSelect a)
Applicative (TreeSelect a) =>
(forall a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b)
-> (forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b)
-> (forall a. a -> TreeSelect a a)
-> Monad (TreeSelect a)
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
$c>>= :: forall a a b.
TreeSelect a 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 -> TreeSelect a b -> TreeSelect a b
>> :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$creturn :: forall a a. a -> TreeSelect a a
return :: forall a. a -> TreeSelect a a
Monad, Functor (TreeSelect a)
Functor (TreeSelect a) =>
(forall a. a -> TreeSelect a a)
-> (forall 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 b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b)
-> (forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a)
-> Applicative (TreeSelect a)
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
$cpure :: forall a a. a -> TreeSelect a a
pure :: forall a. a -> TreeSelect a a
$c<*> :: forall a a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
<*> :: forall a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
$cliftA2 :: forall a a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
liftA2 :: forall a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
$c*> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
*> :: 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 a
<* :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
Applicative, (forall a b. (a -> b) -> TreeSelect a a -> TreeSelect a b)
-> (forall a b. a -> TreeSelect a b -> TreeSelect a a)
-> Functor (TreeSelect a)
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
$cfmap :: forall a a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
fmap :: forall a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
$c<$ :: forall a a b. a -> TreeSelect a b -> TreeSelect a a
<$ :: forall a b. a -> TreeSelect a b -> TreeSelect a a
Functor, MonadState (TSState a), MonadReader (TSConfig a), Monad (TreeSelect a)
Monad (TreeSelect a) =>
(forall a. IO a -> TreeSelect a a) -> MonadIO (TreeSelect 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
$cliftIO :: forall a a. IO a -> TreeSelect a a
liftIO :: forall a. IO a -> TreeSelect a a
MonadIO)
liftX :: X a -> TreeSelect b a
liftX :: forall a b. X a -> TreeSelect b a
liftX = ReaderT (TSConfig b) (StateT (TSState b) X) a -> TreeSelect b a
forall a b.
ReaderT (TSConfig a) (StateT (TSState a) X) b -> TreeSelect a b
TreeSelect (ReaderT (TSConfig b) (StateT (TSState b) X) a -> TreeSelect b a)
-> (X a -> ReaderT (TSConfig b) (StateT (TSState b) X) a)
-> X a
-> TreeSelect b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (TSState b) X a
-> ReaderT (TSConfig b) (StateT (TSState b) X) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT (TSConfig b) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (TSState b) X a
-> ReaderT (TSConfig b) (StateT (TSState b) X) a)
-> (X a -> StateT (TSState b) X a)
-> X a
-> ReaderT (TSConfig b) (StateT (TSState b) X) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X a -> StateT (TSState b) X a
forall (m :: * -> *) a. Monad m => m a -> StateT (TSState b) m a
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 = TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
forall a.
TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
treeselectAt TSConfig a
c (Forest (TSNode a) -> TreeZipper (TSNode a)
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_hidechildren :: forall a. TSConfig a -> Bool
ts_background :: forall a. TSConfig a -> Pixel
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_extra :: forall a. TSConfig a -> Pixel
ts_node_width :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_indent :: forall a. TSConfig a -> Int
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_hidechildren :: Bool
ts_background :: Pixel
ts_font :: WorkspaceId
ts_node :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_highlight :: (Pixel, Pixel)
ts_extra :: Pixel
ts_node_width :: Int
ts_node_height :: Int
ts_originX :: Int
ts_originY :: Int
ts_indent :: Int
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
..} TreeZipper (TSNode a)
zipper [[WorkspaceId]]
hist = (Display -> X (Maybe a)) -> X (Maybe a)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Maybe a)) -> X (Maybe a))
-> (Display -> X (Maybe a)) -> X (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Display
display -> do
rootw <- (XConf -> Pixel) -> X Pixel
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Pixel
theRoot
Rectangle{..} <- gets $ screenRect . W.screenDetail . W.current . windowset
Just vinfo <- liftIO $ matchVisualInfo display (defaultScreen display) 32 4
colormap <- liftIO $ createColormap display rootw (visualInfo_visual vinfo) allocNone
win <- liftIO $ allocaSetWindowAttributes $ \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
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 Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
cWBorderPixel Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
cWBackPixel) Ptr SetWindowAttributes
attributes
setClassHint display w (ClassHint "xmonad-tree_select" "xmonad")
pure w
liftIO $ do
mapWindow display win
selectInput display win (exposureMask .|. keyPressMask .|. buttonReleaseMask)
grabButton display button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none
status <- liftIO $ grabKeyboard display win True grabModeAsync grabModeAsync currentTime
r <- if status == grabSuccess
then do
gc <- liftIO $ createGC display win
xfont <- initXMF ts_font
ret <- evalStateT (runReaderT (runTreeSelect (redraw >> navigate)) conf)
TSState{ tss_tree = zipper
, tss_window = win
, tss_display = display
, tss_xfont = xfont
, tss_size = (fromIntegral rect_width, fromIntegral rect_height)
, tss_gc = gc
, tss_visual = visualInfo_visual vinfo
, tss_colormap = colormap
, tss_history = ([], hist)
}
releaseXMF xfont
liftIO $ freeGC display gc
return ret
else return Nothing
liftIO $ do
unmapWindow display win
destroyWindow display win
freeColormap display colormap
sync display False
return r
treeselectWorkspace :: TSConfig WorkspaceId
-> Forest String
-> (WorkspaceId -> WindowSet -> WindowSet)
-> X ()
treeselectWorkspace :: TSConfig WorkspaceId
-> Forest WorkspaceId
-> (WorkspaceId
-> StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> X ()
treeselectWorkspace TSConfig WorkspaceId
c Forest WorkspaceId
xs WorkspaceId
-> StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
f = do
ws <- (XState -> [Workspace WorkspaceId (Layout Pixel) Pixel])
-> X [Workspace WorkspaceId (Layout Pixel) Pixel]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces (StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Workspace WorkspaceId (Layout Pixel) Pixel])
-> (XState
-> StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet WorkspaceId (Layout Pixel) Pixel ScreenId ScreenDetail
windowset)
if all (`elem` map tag ws) (toWorkspaces xs)
then do
wsf <- forMForest (mkPaths xs) $ \(WorkspaceId
n, WorkspaceId
i) -> X (TSNode WorkspaceId)
-> (Workspace WorkspaceId (Layout Pixel) Pixel
-> X (TSNode WorkspaceId))
-> Maybe (Workspace WorkspaceId (Layout Pixel) Pixel)
-> X (TSNode WorkspaceId)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TSNode WorkspaceId -> X (TSNode WorkspaceId)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId -> WorkspaceId -> WorkspaceId -> TSNode WorkspaceId
forall a. WorkspaceId -> WorkspaceId -> a -> TSNode a
TSNode WorkspaceId
n WorkspaceId
"Does not exist!" WorkspaceId
"")) (WorkspaceId
-> Workspace WorkspaceId (Layout Pixel) Pixel
-> X (TSNode WorkspaceId)
forall {a} {l}. WorkspaceId -> Workspace a l Pixel -> X (TSNode a)
mkNode WorkspaceId
n) ((Workspace WorkspaceId (Layout Pixel) Pixel -> Bool)
-> [Workspace WorkspaceId (Layout Pixel) Pixel]
-> Maybe (Workspace WorkspaceId (Layout Pixel) Pixel)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Workspace WorkspaceId (Layout Pixel) Pixel
w -> WorkspaceId
i WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
tag Workspace WorkspaceId (Layout Pixel) Pixel
w) [Workspace WorkspaceId (Layout Pixel) Pixel]
ws)
me <- gets (W.tag . W.workspace . W.current . windowset)
hist <- workspaceHistory
treeselectAt c (fromJust $ followPath tsn_name (splitPath me) $ fromForest wsf) (map splitPath hist) >>= maybe (return ()) (windows . f)
else liftIO $ do
let msg = [WorkspaceId] -> WorkspaceId
unlines ([WorkspaceId] -> WorkspaceId) -> [WorkspaceId] -> WorkspaceId
forall a b. (a -> b) -> a -> b
$ [ WorkspaceId
"Please add:"
, WorkspaceId
" workspaces = toWorkspaces myWorkspaces"
, WorkspaceId
"to your XMonad config!"
, WorkspaceId
""
, WorkspaceId
"XConfig.workspaces: "
] [WorkspaceId] -> [WorkspaceId] -> [WorkspaceId]
forall a. [a] -> [a] -> [a]
++ (Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId)
-> [Workspace WorkspaceId (Layout Pixel) Pixel] -> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map Workspace WorkspaceId (Layout Pixel) Pixel -> WorkspaceId
forall i l a. Workspace i l a -> i
tag [Workspace WorkspaceId (Layout Pixel) Pixel]
ws
hPutStrLn stderr msg
xmessage msg
return ()
where
mkNode :: WorkspaceId -> Workspace a l Pixel -> X (TSNode a)
mkNode WorkspaceId
n Workspace a l Pixel
w = do
name <- X WorkspaceId
-> (Stack Pixel -> X WorkspaceId)
-> Maybe (Stack Pixel)
-> X WorkspaceId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (WorkspaceId -> X WorkspaceId
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceId
"") ((NamedWindow -> WorkspaceId) -> X NamedWindow -> X WorkspaceId
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedWindow -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show (X NamedWindow -> X WorkspaceId)
-> (Stack Pixel -> X NamedWindow) -> Stack Pixel -> X WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel -> X NamedWindow
getName (Pixel -> X NamedWindow)
-> (Stack Pixel -> Pixel) -> Stack Pixel -> X NamedWindow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack Pixel -> Pixel
forall a. Stack a -> a
W.focus) (Maybe (Stack Pixel) -> X WorkspaceId)
-> Maybe (Stack Pixel) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ Workspace a l Pixel -> Maybe (Stack Pixel)
forall i l a. Workspace i l a -> Maybe (Stack a)
stack Workspace a l Pixel
w
return $ TSNode n name (tag w)
toWorkspaces :: Forest String -> [WorkspaceId]
toWorkspaces :: Forest WorkspaceId -> [WorkspaceId]
toWorkspaces = ((WorkspaceId, WorkspaceId) -> WorkspaceId)
-> [(WorkspaceId, WorkspaceId)] -> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map (WorkspaceId, WorkspaceId) -> WorkspaceId
forall a b. (a, b) -> b
snd ([(WorkspaceId, WorkspaceId)] -> [WorkspaceId])
-> (Forest WorkspaceId -> [(WorkspaceId, WorkspaceId)])
-> Forest WorkspaceId
-> [WorkspaceId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (WorkspaceId, WorkspaceId) -> [(WorkspaceId, WorkspaceId)])
-> [Tree (WorkspaceId, WorkspaceId)]
-> [(WorkspaceId, WorkspaceId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree (WorkspaceId, WorkspaceId) -> [(WorkspaceId, WorkspaceId)]
forall a. Tree a -> [a]
flatten ([Tree (WorkspaceId, WorkspaceId)] -> [(WorkspaceId, WorkspaceId)])
-> (Forest WorkspaceId -> [Tree (WorkspaceId, WorkspaceId)])
-> Forest WorkspaceId
-> [(WorkspaceId, WorkspaceId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest WorkspaceId -> [Tree (WorkspaceId, WorkspaceId)]
mkPaths
mkPaths :: Forest String -> Forest (String, WorkspaceId)
mkPaths :: Forest WorkspaceId -> [Tree (WorkspaceId, WorkspaceId)]
mkPaths = (Tree WorkspaceId -> Tree (WorkspaceId, WorkspaceId))
-> Forest WorkspaceId -> [Tree (WorkspaceId, WorkspaceId)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node WorkspaceId
n Forest WorkspaceId
ns) -> (WorkspaceId, WorkspaceId)
-> [Tree (WorkspaceId, WorkspaceId)]
-> Tree (WorkspaceId, WorkspaceId)
forall a. a -> [Tree a] -> Tree a
Node (WorkspaceId
n, WorkspaceId
n) ((Tree WorkspaceId -> Tree (WorkspaceId, WorkspaceId))
-> Forest WorkspaceId -> [Tree (WorkspaceId, WorkspaceId)]
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 WorkspaceId -> WorkspaceId -> WorkspaceId
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> WorkspaceId -> WorkspaceId
forall a. a -> [a] -> [a]
: WorkspaceId
x
in (WorkspaceId, WorkspaceId)
-> [Tree (WorkspaceId, WorkspaceId)]
-> Tree (WorkspaceId, WorkspaceId)
forall a. a -> [Tree a] -> Tree a
Node (WorkspaceId
x, WorkspaceId
pth') ((Tree WorkspaceId -> Tree (WorkspaceId, WorkspaceId))
-> Forest WorkspaceId -> [Tree (WorkspaceId, WorkspaceId)]
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 (Char -> Bool) -> WorkspaceId -> (WorkspaceId, WorkspaceId)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') WorkspaceId
i of
(WorkspaceId
x, []) -> [WorkspaceId
x]
(WorkspaceId
x, Char
_:WorkspaceId
xs) -> WorkspaceId
x WorkspaceId -> [WorkspaceId] -> [WorkspaceId]
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 = TSConfig (X a) -> Forest (TSNode (X a)) -> X (Maybe (X a))
forall a. TSConfig a -> Forest (TSNode a) -> X (Maybe a)
treeselect TSConfig (X a)
c Forest (TSNode (X a))
xs X (Maybe (X a)) -> (Maybe (X a) -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just X a
a -> X a -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void X a
a
Maybe (X a)
Nothing -> () -> X ()
forall a. a -> X a
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 = (Tree a -> m (Tree b)) -> [Tree a] -> m [Tree b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((a -> m b) -> Tree a -> m (Tree b)
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) = b -> [Tree b] -> Tree b
forall a. a -> [Tree a] -> Tree a
Node (b -> [Tree b] -> Tree b) -> m b -> m ([Tree b] -> Tree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x m ([Tree b] -> Tree b) -> m [Tree b] -> m (Tree b)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Tree a -> m (Tree b)) -> [Tree a] -> m [Tree b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((a -> m b) -> Tree a -> m (Tree b)
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 = (TSState a -> Maybe a) -> TreeSelect a (Maybe a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (TSState a -> a) -> TSState a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TSNode a -> a
forall a. TSNode a -> a
tsn_value (TSNode a -> a) -> (TSState a -> TSNode a) -> TSState a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeZipper (TSNode a) -> TSNode a
forall a. TreeZipper a -> a
cursor (TreeZipper (TSNode a) -> TSNode a)
-> (TSState a -> TreeZipper (TSNode a)) -> TSState a -> TSNode a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSState a -> TreeZipper (TSNode a)
forall a. TSState a -> TreeZipper (TSNode a)
tss_tree))
cancel :: TreeSelect a (Maybe a)
cancel :: forall a. TreeSelect a (Maybe a)
cancel = Maybe a -> TreeSelect a (Maybe a)
forall a. a -> TreeSelect a a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
moveParent :: TreeSelect a (Maybe a)
moveParent :: forall a. TreeSelect a (Maybe a)
moveParent = (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
forall a. TreeZipper a -> Maybe (TreeZipper a)
parent TreeSelect a () -> TreeSelect a () -> TreeSelect a ()
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a ()
forall a. TreeSelect a ()
redraw TreeSelect a () -> TreeSelect a (Maybe a) -> TreeSelect a (Maybe a)
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
moveChild :: TreeSelect a (Maybe a)
moveChild :: forall a. TreeSelect a (Maybe a)
moveChild = (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
forall a. TreeZipper a -> Maybe (TreeZipper a)
children TreeSelect a () -> TreeSelect a () -> TreeSelect a ()
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a ()
forall a. TreeSelect a ()
redraw TreeSelect a () -> TreeSelect a (Maybe a) -> TreeSelect a (Maybe a)
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
moveNext :: TreeSelect a (Maybe a)
moveNext :: forall a. TreeSelect a (Maybe a)
moveNext = (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
forall a. TreeZipper a -> Maybe (TreeZipper a)
nextChild TreeSelect a () -> TreeSelect a () -> TreeSelect a ()
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a ()
forall a. TreeSelect a ()
redraw TreeSelect a () -> TreeSelect a (Maybe a) -> TreeSelect a (Maybe a)
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
movePrev :: TreeSelect a (Maybe a)
movePrev :: forall a. TreeSelect a (Maybe a)
movePrev = (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
forall a. TreeZipper a -> Maybe (TreeZipper a)
previousChild TreeSelect a () -> TreeSelect a () -> TreeSelect a ()
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a ()
forall a. TreeSelect a ()
redraw TreeSelect a () -> TreeSelect a (Maybe a) -> TreeSelect a (Maybe a)
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
moveHistBack :: TreeSelect a (Maybe a)
moveHistBack :: forall a. TreeSelect a (Maybe a)
moveHistBack = do
s <- TreeSelect a (TSState a)
forall s (m :: * -> *). MonadState s m => m s
get
case tss_history s of
([[WorkspaceId]]
xs, [WorkspaceId]
a:[WorkspaceId]
y:[[WorkspaceId]]
ys) -> do
TSState a -> TreeSelect a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{tss_history = (a:xs, y:ys)}
[WorkspaceId] -> TreeSelect a (Maybe a)
forall a. [WorkspaceId] -> TreeSelect a (Maybe a)
moveTo [WorkspaceId]
y
([[WorkspaceId]], [[WorkspaceId]])
_ -> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
moveHistForward :: TreeSelect a (Maybe a)
moveHistForward :: forall a. TreeSelect a (Maybe a)
moveHistForward = do
s <- TreeSelect a (TSState a)
forall s (m :: * -> *). MonadState s m => m s
get
case tss_history s of
([WorkspaceId]
x:[[WorkspaceId]]
xs, [[WorkspaceId]]
ys) -> do
TSState a -> TreeSelect a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{tss_history = (xs, x:ys)}
[WorkspaceId] -> TreeSelect a (Maybe a)
forall a. [WorkspaceId] -> TreeSelect a (Maybe a)
moveTo [WorkspaceId]
x
([[WorkspaceId]], [[WorkspaceId]])
_ -> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
moveTo :: [String]
-> TreeSelect a (Maybe a)
moveTo :: forall a. [WorkspaceId] -> TreeSelect a (Maybe a)
moveTo [WorkspaceId]
i = (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith ((TSNode a -> WorkspaceId)
-> [WorkspaceId]
-> TreeZipper (TSNode a)
-> Maybe (TreeZipper (TSNode a))
forall b a.
Eq b =>
(a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a)
followPath TSNode a -> WorkspaceId
forall a. TSNode a -> WorkspaceId
tsn_name [WorkspaceId]
i (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> (TreeZipper (TSNode a) -> TreeZipper (TSNode a))
-> TreeZipper (TSNode a)
-> Maybe (TreeZipper (TSNode a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeZipper (TSNode a) -> TreeZipper (TSNode a)
forall a. TreeZipper a -> TreeZipper a
rootNode) TreeSelect a () -> TreeSelect a () -> TreeSelect a ()
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a ()
forall a. TreeSelect a ()
redraw TreeSelect a () -> TreeSelect a (Maybe a) -> TreeSelect a (Maybe a)
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
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
s <- TreeSelect a (TSState a)
forall s (m :: * -> *). MonadState s m => m s
get
case f (tss_tree s) of
Just TreeZipper (TSNode a)
t -> TSState a -> TreeSelect a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{ tss_tree = t }
Maybe (TreeZipper (TSNode a))
Nothing -> () -> TreeSelect a ()
forall a. a -> TreeSelect a a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
navigate :: TreeSelect a (Maybe a)
navigate :: forall a. TreeSelect a (Maybe a)
navigate = (TSState a -> Display) -> TreeSelect a Display
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TSState a -> Display
forall a. TSState a -> Display
tss_display TreeSelect a Display
-> (Display -> TreeSelect a (Maybe a)) -> TreeSelect a (Maybe a)
forall a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> TreeSelect a (TreeSelect a (Maybe a)) -> TreeSelect a (Maybe a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (TreeSelect a (TreeSelect a (Maybe a)) -> TreeSelect a (Maybe a))
-> ((XEventPtr -> IO (TreeSelect a (Maybe a)))
-> TreeSelect a (TreeSelect a (Maybe a)))
-> (XEventPtr -> IO (TreeSelect a (Maybe a)))
-> TreeSelect a (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (TreeSelect a (Maybe a))
-> TreeSelect a (TreeSelect a (Maybe a))
forall a. IO a -> TreeSelect a a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TreeSelect a (Maybe a))
-> TreeSelect a (TreeSelect a (Maybe a)))
-> ((XEventPtr -> IO (TreeSelect a (Maybe a)))
-> IO (TreeSelect a (Maybe a)))
-> (XEventPtr -> IO (TreeSelect a (Maybe a)))
-> TreeSelect a (TreeSelect a (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XEventPtr -> IO (TreeSelect a (Maybe a)))
-> IO (TreeSelect a (Maybe a))
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (TreeSelect a (Maybe a)))
-> TreeSelect a (Maybe a))
-> (XEventPtr -> IO (TreeSelect a (Maybe a)))
-> TreeSelect a (Maybe a)
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
Display -> Pixel -> XEventPtr -> IO ()
maskEvent Display
d (Pixel
exposureMask Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
keyPressMask Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
buttonReleaseMask Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.|. Pixel
buttonPressMask) XEventPtr
e
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
if | ev_event_type ev == keyPress -> do
ks <- keycodeToKeysym d (ev_keycode ev) 0
return $ do
mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)
f <- asks ts_navigate
fromMaybe navigate $ M.lookup (mask, ks) f
| ev_event_type ev == buttonPress -> do
allowEvents d replayPointer currentTime
return navigate
| otherwise -> return navigate
redraw :: TreeSelect a ()
redraw :: forall a. TreeSelect a ()
redraw = do
win <- (TSState a -> Pixel) -> TreeSelect a Pixel
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TSState a -> Pixel
forall a. TSState a -> Pixel
tss_window
dpy <- gets tss_display
liftIO $ clearWindow dpy win
t <- gets tss_tree
_ <- drawLayers 0 0 (reverse $ (tz_before t, cursor t, tz_after t) : tz_parents t)
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 [] = Int -> TreeSelect a Int
forall a. a -> TreeSelect a a
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{..} <- TreeSelect a (TSConfig a)
forall r (m :: * -> *). MonadReader r m => m r
ask
let nodeColor a
y = if a -> Bool
forall a. Integral a => a -> Bool
odd a
y then (Pixel, Pixel)
ts_node else (Pixel, Pixel)
ts_nodealt
forM_ (zip [yl ..] (reverse bs)) $ \(Int
y, Node TSNode a
n Forest (TSNode a)
_) ->
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
y TSNode a
n (Int -> (Pixel, Pixel)
forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
y)
let current_level = Int
yl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Forest (TSNode a) -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
bs
drawNode xl current_level c $
if null xs then ts_highlight
else nodeColor current_level
l2 <- drawLayers (xl + 1) (current_level + 1) xs
forM_ (zip [l2 ..] as) $ \(Int
y, Node TSNode a
n Forest (TSNode a)
_) ->
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
y TSNode a
n (Int -> (Pixel, Pixel)
forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
y)
return (l2 + length 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_name :: forall a. TSNode a -> WorkspaceId
tsn_extra :: forall a. TSNode a -> WorkspaceId
tsn_value :: forall a. TSNode a -> a
tsn_name :: WorkspaceId
tsn_extra :: WorkspaceId
tsn_value :: a
..} (Pixel, Pixel)
col = do
TSConfig{..} <- TreeSelect a (TSConfig a)
forall r (m :: * -> *). MonadReader r m => m r
ask
window <- gets tss_window
display <- gets tss_display
font <- gets tss_xfont
gc <- gets tss_gc
colormap <- gets tss_colormap
visual <- gets tss_visual
liftIO $ drawWinBox window display visual colormap gc font col tsn_name ts_extra tsn_extra
(ix * ts_indent + ts_originX) (iy * ts_node_height + ts_originY)
ts_node_width 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 (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Dimension
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
(Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Position) -> Int -> Position
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8)
(Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Position) -> Int -> Position
forall a b. (a -> b) -> a -> b
$ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
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
(Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Position) -> Int -> Position
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8)
(Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Position) -> Int -> Position
forall a b. (a -> b) -> a -> b
$ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
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 (Pixel -> IO ()) -> Pixel -> IO ()
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
Display -> Pixel -> Visual -> Pixel -> (XftDraw -> IO ()) -> IO ()
forall a.
Display -> Pixel -> Visual -> Pixel -> (XftDraw -> IO a) -> IO a
withXftDraw Display
display Pixel
window Visual
visual Pixel
colormap ((XftDraw -> IO ()) -> IO ()) -> (XftDraw -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\XftDraw
ft_draw -> Display
-> Visual -> Pixel -> XRenderColor -> (XftColor -> IO ()) -> IO ()
forall a.
Display
-> Visual -> Pixel -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue Display
display Visual
visual Pixel
colormap (Pixel -> XRenderColor
fromARGB Pixel
col) ((XftColor -> IO ()) -> IO ()) -> (XftColor -> IO ()) -> IO ()
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 (NonEmpty XftFont -> [XftFont]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty XftFont
fnts) (Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi Position
x) (Position -> Int
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 = Pixel -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel -> Int) -> Pixel -> Int
forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.&. Pixel -> Int -> Pixel
forall a. Bits a => a -> Int -> a
shiftR Pixel
x Int
8
g :: Int
g = Pixel -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel -> Int) -> Pixel -> Int
forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.&. Pixel
x
b :: Int
b = Pixel -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel -> Int) -> Pixel -> Int
forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.&. Pixel -> Int -> Pixel
forall a. Bits a => a -> Int -> a
shiftL Pixel
x Int
8
a :: Int
a = Pixel -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel -> Int) -> Pixel -> Int
forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 Pixel -> Pixel -> Pixel
forall a. Bits a => a -> a -> a
.&. Pixel -> Int -> Pixel
forall a. Bits a => a -> Int -> a
shiftR Pixel
x Int
16
#endif