{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.TreeSelect
-- Description :  Display workspaces or actions in a tree-like format.
-- Copyright   :  (c) Tom Smeets <tom.tsmeets@gmail.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Tom Smeets <tom.tsmeets@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
--
-- TreeSelect displays your workspaces or actions in a Tree-like format.
-- You can select the desired workspace/action with the cursor or hjkl keys.
--
-- This module is fully configurable and very useful if you like to have a
-- lot of workspaces.
--
-- Only the nodes up to the currently selected are displayed.
-- This will be configurable in the near future by changing 'ts_hidechildren' to @False@, this is not yet implemented.
--
-- <<https://wiki.haskell.org/wikiupload/thumb/0/0b/Treeselect-Workspace.png/800px-Treeselect-Workspace.png>>
--
-----------------------------------------------------------------------------
module XMonad.Actions.TreeSelect
    (
      -- * Usage
      -- $usage
      treeselectWorkspace
    , toWorkspaces
    , treeselectAction

      -- * Configuring
      -- $config
    , Pixel
      -- $pixel

    , TSConfig(..)
    , tsDefaultConfig
    , def

      -- * Navigation
      -- $navigation
    , defaultNavigation
    , select
    , cancel
    , moveParent
    , moveChild
    , moveNext
    , movePrev
    , moveHistBack
    , moveHistForward
    , moveTo

      -- * Advanced usage
      -- $advusage
    , 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 Graphics.X11.Xft
import Graphics.X11.Xrender
#endif

-- $usage
--
-- These imports are used in the following example
--
-- > import Data.Tree
-- > import XMonad.Actions.TreeSelect
-- > import XMonad.Hooks.WorkspaceHistory
-- > import qualified XMonad.StackSet as W
--
-- For selecting Workspaces, you need to define them in a tree structure using 'Data.Tree.Node' instead of just a standard list
--
-- Here is an example workspace-tree
--
-- > myWorkspaces :: Forest String
-- > myWorkspaces = [ Node "Browser" [] -- a workspace for your browser
-- >                , Node "Home"       -- for everyday activity's
-- >                    [ Node "1" []   --  with 4 extra sub-workspaces, for even more activity's
-- >                    , Node "2" []
-- >                    , Node "3" []
-- >                    , Node "4" []
-- >                    ]
-- >                , Node "Programming" -- for all your programming needs
-- >                    [ Node "Haskell" []
-- >                    , Node "Docs"    [] -- documentation
-- >                    ]
-- >                ]
--
-- Then add it to your 'XMonad.Core.workspaces' using the 'toWorkspaces' function.
--
-- Optionally, if you add 'workspaceHistoryHook' to your 'logHook' you can use the \'o\' and \'i\' keys to select from previously-visited workspaces
--
-- > xmonad $ def { ...
-- >              , workspaces = toWorkspaces myWorkspaces
-- >              , logHook = workspaceHistoryHook
-- >              }
--
-- After that you still need to bind buttons to 'treeselectWorkspace' to start selecting a workspaces and moving windows
--
-- you could bind @Mod-f@ to switch workspace
--
-- >  , ((modMask, xK_f), treeselectWorkspace myTreeConf myWorkspaces W.greedyView)
--
-- and bind @Mod-Shift-f@ to moving the focused windows to a workspace
--
-- >  , ((modMask .|. shiftMask, xK_f), treeselectWorkspace myTreeConf myWorkspaces W.shift)

-- $config
-- The selection menu is very configurable, you can change the font, all colors and the sizes of the boxes.
--
-- The default config defined as 'def'
--
-- > def = TSConfig { ts_hidechildren = True
-- >                , ts_background   = 0xc0c0c0c0
-- >                , ts_font         = "xft:Sans-16"
-- >                , ts_node         = (0xff000000, 0xff50d0db)
-- >                , ts_nodealt      = (0xff000000, 0xff10b8d6)
-- >                , ts_highlight    = (0xffffffff, 0xffff0000)
-- >                , ts_extra        = 0xff000000
-- >                , ts_node_width   = 200
-- >                , ts_node_height  = 30
-- >                , ts_originX      = 0
-- >                , ts_originY      = 0
-- >                , ts_indent       = 80
-- >                , ts_navigate     = defaultNavigation
-- >                }

-- $pixel
--
-- The 'Pixel' Color format is in the form of @0xaarrggbb@
--
-- Note that transparency is only supported if you have a window compositor running like <https://github.com/chjj/compton compton>
--
-- Some Examples:
--
-- @
-- white       = 0xffffffff
-- black       = 0xff000000
-- red         = 0xffff0000
-- green       = 0xff00ff00
-- blue        = 0xff0000ff
-- transparent = 0x00000000
-- @

-- $navigation
--
-- Keybindings for navigations can also be modified
--
-- This is the definition of 'defaultNavigation'
--
-- > defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a))
-- > defaultNavigation = M.fromList
-- >     [ ((0, xK_Escape), cancel)
-- >     , ((0, xK_Return), select)
-- >     , ((0, xK_space),  select)
-- >     , ((0, xK_Up),     movePrev)
-- >     , ((0, xK_Down),   moveNext)
-- >     , ((0, xK_Left),   moveParent)
-- >     , ((0, xK_Right),  moveChild)
-- >     , ((0, xK_k),      movePrev)
-- >     , ((0, xK_j),      moveNext)
-- >     , ((0, xK_h),      moveParent)
-- >     , ((0, xK_l),      moveChild)
-- >     , ((0, xK_o),      moveHistBack)
-- >     , ((0, xK_i),      moveHistForward)
-- >     ]

-- $advusage
-- This module can also be used to select any other action

-- | Extensive configuration for displaying the tree.
--
-- This class also has a 'Default' instance
data TSConfig a = TSConfig { TSConfig a -> Bool
ts_hidechildren :: Bool -- ^ when enabled, only the parents (and their first children) of the current node will be shown (This feature is not yet implemented!)
                           , TSConfig a -> Pixel
ts_background :: Pixel -- ^ background color filling the entire screen.

                           , TSConfig a -> String
ts_font :: String -- ^ XMF font for drawing the node name extra text

                           , TSConfig a -> (Pixel, Pixel)
ts_node      :: (Pixel, Pixel) -- ^ node foreground (text) and background color when not selected
                           , TSConfig a -> (Pixel, Pixel)
ts_nodealt   :: (Pixel, Pixel) -- ^ every other node will use this color instead of 'ts_node'
                           , TSConfig a -> (Pixel, Pixel)
ts_highlight :: (Pixel, Pixel) -- ^ node foreground (text) and background color when selected

                           , TSConfig a -> Pixel
ts_extra :: Pixel -- ^ extra text color

                           , TSConfig a -> Int
ts_node_width   :: Int -- ^ node width in pixels
                           , TSConfig a -> Int
ts_node_height  :: Int -- ^ node height in pixels
                           , TSConfig a -> Int
ts_originX :: Int -- ^ tree X position on the screen in pixels
                           , TSConfig a -> Int
ts_originY :: Int -- ^ tree Y position on the screen in pixels

                           , TSConfig a -> Int
ts_indent :: Int -- ^ indentation amount for each level in pixels

                           , TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a)) -- ^ key bindings for navigating the tree
                           }

instance Default (TSConfig a) where
    def :: TSConfig a
def = TSConfig :: forall a.
Bool
-> Pixel
-> String
-> (Pixel, Pixel)
-> (Pixel, Pixel)
-> (Pixel, Pixel)
-> Pixel
-> Int
-> Int
-> Int
-> Int
-> Int
-> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
-> TSConfig a
TSConfig { ts_hidechildren :: Bool
ts_hidechildren = Bool
True
                   , ts_background :: Pixel
ts_background   = Pixel
0xc0c0c0c0
                   , ts_font :: String
ts_font         = String
"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
                   }

-- | Default navigation
--
-- * navigation using either arrow key or vi style hjkl
-- * Return or Space to confirm
-- * Escape or Backspace to cancel to
defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a))
defaultNavigation :: 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)
    ]

-- | Default configuration.
--
-- Using nice alternating blue nodes
tsDefaultConfig :: TSConfig a
tsDefaultConfig :: 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." #-}

-- | Tree Node With a name and extra text
data TSNode a = TSNode { TSNode a -> String
tsn_name  :: String
                       , TSNode a -> String
tsn_extra :: String -- ^ extra text, displayed next to the node name
                       , TSNode a -> a
tsn_value :: a      -- ^ value to return when this node is selected
                       }

-- | State used by TreeSelect.
--
-- Contains all needed information such as the window, font and a zipper over the tree.
data TSState a = TSState { TSState a -> TreeZipper (TSNode a)
tss_tree     :: TreeZipper (TSNode a)
                         , TSState a -> Pixel
tss_window   :: Window
                         , TSState a -> Display
tss_display  :: Display
                         , TSState a -> (Int, Int)
tss_size     :: (Int, Int) -- ^ size of 'tz_window'
                         , TSState a -> XMonadFont
tss_xfont    :: XMonadFont
                         , TSState a -> GC
tss_gc       :: GC
                         , TSState a -> Visual
tss_visual   :: Visual
                         , TSState a -> Pixel
tss_colormap :: Colormap
                         , TSState a -> ([[String]], [[String]])
tss_history  :: ([[String]], [[String]]) -- ^ history zipper, navigated with 'moveHistBack' and 'moveHistForward'
                         }

-- | State monad transformer using 'TSState'
newtype TreeSelect a b = TreeSelect { TreeSelect a b -> ReaderT (TSConfig a) (StateT (TSState a) X) b
runTreeSelect :: ReaderT (TSConfig a) (StateT (TSState a) X) b }
    deriving (Applicative (TreeSelect a)
a -> TreeSelect a 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)
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
TreeSelect a a -> TreeSelect a b -> TreeSelect a b
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 :: a -> TreeSelect a a
$creturn :: forall a a. a -> TreeSelect a a
>> :: TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$c>> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect 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
$cp1Monad :: forall a. Applicative (TreeSelect a)
Monad, Functor (TreeSelect a)
a -> TreeSelect a 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)
TreeSelect a a -> TreeSelect a b -> TreeSelect a b
TreeSelect a a -> TreeSelect a b -> TreeSelect a a
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
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
<* :: TreeSelect a a -> TreeSelect a b -> TreeSelect a a
$c<* :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
*> :: TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$c*> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
liftA2 :: (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
<*> :: 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 :: a -> TreeSelect a a
$cpure :: forall a a. a -> TreeSelect a a
$cp1Applicative :: forall a. Functor (TreeSelect a)
Applicative, a -> TreeSelect a b -> TreeSelect a a
(a -> b) -> TreeSelect a a -> TreeSelect a b
(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
<$ :: a -> TreeSelect a b -> TreeSelect a a
$c<$ :: forall a a b. a -> TreeSelect a b -> TreeSelect a a
fmap :: (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), Monad (TreeSelect a)
Monad (TreeSelect a)
-> (forall a. IO a -> TreeSelect a a) -> MonadIO (TreeSelect a)
IO a -> TreeSelect a 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 :: IO a -> TreeSelect a a
$cliftIO :: forall a a. IO a -> TreeSelect a a
$cp1MonadIO :: forall a. Monad (TreeSelect a)
MonadIO)

-- | Lift the 'X' action into the 'XMonad.Actions.TreeSelect.TreeSelect' monad
liftX :: X a -> TreeSelect b a
liftX :: 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 (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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Run Treeselect with a given config and tree.
-- This can be used for selectiong anything
--
-- * for switching workspaces and moving windows use 'treeselectWorkspace'
-- * for selecting actions use 'treeselectAction'
treeselect :: TSConfig a         -- ^ config file
           -> Forest (TSNode a)  -- ^ a list of 'Data.Tree.Tree's to select from.
           -> X (Maybe a)
treeselect :: TSConfig a -> Forest (TSNode a) -> X (Maybe a)
treeselect TSConfig a
c Forest (TSNode a)
t = TSConfig a -> TreeZipper (TSNode a) -> [[String]] -> X (Maybe a)
forall a.
TSConfig a -> TreeZipper (TSNode a) -> [[String]] -> X (Maybe a)
treeselectAt TSConfig a
c (Forest (TSNode a) -> TreeZipper (TSNode a)
forall a. Forest a -> TreeZipper a
fromForest Forest (TSNode a)
t) []

-- | Same as 'treeselect' but ad a specific starting position
treeselectAt :: TSConfig a         -- ^ config file
             -> TreeZipper (TSNode a)  -- ^ tree structure with a cursor position (starting node)
             -> [[String]] -- ^ list of paths that can be navigated with 'moveHistBack' and 'moveHistForward' (bound to the 'o' and 'i' keys)
             -> X (Maybe a)
treeselectAt :: TSConfig a -> TreeZipper (TSNode a) -> [[String]] -> X (Maybe a)
treeselectAt conf :: TSConfig a
conf@TSConfig{Bool
Int
String
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 :: String
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 -> String
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} TreeZipper (TSNode a)
zipper [[String]]
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
    -- create a window on the currently focused screen
    Pixel
rootw <- (XConf -> Pixel) -> X Pixel
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
..} <- (XState -> Rectangle) -> X Rectangle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Rectangle) -> X Rectangle)
-> (XState -> Rectangle) -> X Rectangle
forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (XState -> ScreenDetail) -> XState -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
 -> ScreenDetail)
-> (XState
    -> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
-> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> (XState
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
windowset

    Just VisualInfo
vinfo <- IO (Maybe VisualInfo) -> X (Maybe VisualInfo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe VisualInfo) -> X (Maybe VisualInfo))
-> IO (Maybe VisualInfo) -> X (Maybe VisualInfo)
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 <- IO Pixel -> X Pixel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Pixel -> X Pixel) -> IO Pixel -> X Pixel
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 <- IO Pixel -> X Pixel
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Pixel -> X Pixel) -> IO Pixel -> X Pixel
forall a b. (a -> b) -> a -> b
$ (Ptr SetWindowAttributes -> IO Pixel) -> IO Pixel
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Pixel) -> IO Pixel)
-> (Ptr SetWindowAttributes -> IO Pixel) -> IO Pixel
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 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
        Display -> Pixel -> ClassHint -> IO ()
setClassHint Display
display Pixel
w (String -> String -> ClassHint
ClassHint String
"xmonad-tree_select" String
"xmonad")
        Pixel -> IO Pixel
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel
w

    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
        -- TODO: move below?
        -- make the window visible
        Display -> Pixel -> IO ()
mapWindow Display
display Pixel
win

        -- listen to key and mouse button events
        Display -> Pixel -> Pixel -> IO ()
selectInput Display
display Pixel
win (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)

        -- TODO: enable mouse select?
        -- and mouse button 1
        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

    -- grab the keyboard
    CInt
status <- IO CInt -> X CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> X CInt) -> IO CInt -> X CInt
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 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess
        then do
            -- load the XMF font
            GC
gc <- IO GC -> X GC
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GC -> X GC) -> IO GC -> X GC
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO GC
createGC Display
display Pixel
win
            XMonadFont
xfont <- String -> X XMonadFont
initXMF String
ts_font

            -- run the treeselect Monad
            Maybe a
ret <- StateT (TSState a) X (Maybe a) -> TSState a -> X (Maybe a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT (TSConfig a) (StateT (TSState a) X) (Maybe a)
-> TSConfig a -> StateT (TSState a) X (Maybe a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (TreeSelect a (Maybe a)
-> ReaderT (TSConfig a) (StateT (TSState a) X) (Maybe a)
forall a b.
TreeSelect a b -> ReaderT (TSConfig a) (StateT (TSState a) X) b
runTreeSelect (TreeSelect a ()
forall a. TreeSelect a ()
redraw TreeSelect a () -> TreeSelect a (Maybe a) -> TreeSelect a (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate)) TSConfig a
conf)
                TSState :: forall a.
TreeZipper (TSNode a)
-> Pixel
-> Display
-> (Int, Int)
-> XMonadFont
-> GC
-> Visual
-> Pixel
-> ([[String]], [[String]])
-> TSState a
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     = (Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
rect_width, Dimension -> Int
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 :: ([[String]], [[String]])
tss_history = ([], [[String]]
hist)
                       }

            -- release the XMF font
            XMonadFont -> X ()
releaseXMF XMonadFont
xfont
            IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC Display
display GC
gc
            Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
ret

        else Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

    -- destroy the window
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
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
        -- Flush the output buffer and wait for all the events to be processed
        -- TODO: is this needed?
        Display -> Bool -> IO ()
sync Display
display Bool
False
    Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r

-- | Select a workspace and execute a \"view\" function from "XMonad.StackSet" on it.
treeselectWorkspace :: TSConfig WorkspaceId
                    -> Forest String -- ^ your tree of workspace-names
                    -> (WorkspaceId -> WindowSet -> WindowSet) -- ^ the \"view\" function.
                                                               -- Instances can be 'W.greedyView' for switching to a workspace
                                                               -- and/or 'W.shift' for moving the focused window to a selected workspace.
                                                               --
                                                               -- These actions can also be combined by doing
                                                               --
                                                               -- > \i -> W.greedyView i . W.shift i
                    -> X ()
treeselectWorkspace :: TSConfig String
-> Forest String
-> (String
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> X ()
treeselectWorkspace TSConfig String
c Forest String
xs String
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
f = do
    -- get all defined workspaces
    -- They have to be set with 'toWorkspaces'!
    [Workspace String (Layout Pixel) Pixel]
ws <- (XState -> [Workspace String (Layout Pixel) Pixel])
-> X [Workspace String (Layout Pixel) Pixel]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
-> [Workspace String (Layout Pixel) Pixel]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces (StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
 -> [Workspace String (Layout Pixel) Pixel])
-> (XState
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> [Workspace String (Layout Pixel) Pixel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
windowset)

    -- check the 'XConfig.workspaces'
    if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Workspace String (Layout Pixel) Pixel -> String)
-> [Workspace String (Layout Pixel) Pixel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Workspace String (Layout Pixel) Pixel -> String
forall i l a. Workspace i l a -> i
tag [Workspace String (Layout Pixel) Pixel]
ws) (Forest String -> [String]
toWorkspaces Forest String
xs)
      then do
        -- convert the 'Forest WorkspaceId' to 'Forest (TSNode WorkspaceId)'
        [Tree (TSNode String)]
wsf <- [Tree (String, String)]
-> ((String, String) -> X (TSNode String))
-> X [Tree (TSNode String)]
forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
[Tree a] -> (a -> m b) -> m [Tree b]
forMForest (Forest String -> [Tree (String, String)]
mkPaths Forest String
xs) (((String, String) -> X (TSNode String))
 -> X [Tree (TSNode String)])
-> ((String, String) -> X (TSNode String))
-> X [Tree (TSNode String)]
forall a b. (a -> b) -> a -> b
$ \(String
n, String
i) -> X (TSNode String)
-> (Workspace String (Layout Pixel) Pixel -> X (TSNode String))
-> Maybe (Workspace String (Layout Pixel) Pixel)
-> X (TSNode String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TSNode String -> X (TSNode String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> String -> TSNode String
forall a. String -> String -> a -> TSNode a
TSNode String
n String
"Does not exist!" String
"")) (String
-> Workspace String (Layout Pixel) Pixel -> X (TSNode String)
forall a l. String -> Workspace a l Pixel -> X (TSNode a)
mkNode String
n) ((Workspace String (Layout Pixel) Pixel -> Bool)
-> [Workspace String (Layout Pixel) Pixel]
-> Maybe (Workspace String (Layout Pixel) Pixel)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Workspace String (Layout Pixel) Pixel
w -> String
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Workspace String (Layout Pixel) Pixel -> String
forall i l a. Workspace i l a -> i
tag Workspace String (Layout Pixel) Pixel
w) [Workspace String (Layout Pixel) Pixel]
ws)

        -- get the current workspace path
        String
me <- (XState -> String) -> X String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Workspace String (Layout Pixel) Pixel -> String
forall i l a. Workspace i l a -> i
W.tag (Workspace String (Layout Pixel) Pixel -> String)
-> (XState -> Workspace String (Layout Pixel) Pixel)
-> XState
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
-> Workspace String (Layout Pixel) Pixel
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Workspace String (Layout Pixel) Pixel)
-> (XState
    -> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> Workspace String (Layout Pixel) Pixel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
-> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
 -> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> (XState
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Pixel) Pixel ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
windowset)
        [String]
hist <- X [String]
workspaceHistory
        TSConfig String
-> TreeZipper (TSNode String) -> [[String]] -> X (Maybe String)
forall a.
TSConfig a -> TreeZipper (TSNode a) -> [[String]] -> X (Maybe a)
treeselectAt TSConfig String
c (Maybe (TreeZipper (TSNode String)) -> TreeZipper (TSNode String)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (TreeZipper (TSNode String)) -> TreeZipper (TSNode String))
-> Maybe (TreeZipper (TSNode String)) -> TreeZipper (TSNode String)
forall a b. (a -> b) -> a -> b
$ (TSNode String -> String)
-> [String]
-> TreeZipper (TSNode String)
-> Maybe (TreeZipper (TSNode String))
forall b a.
Eq b =>
(a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a)
followPath TSNode String -> String
forall a. TSNode a -> String
tsn_name (String -> [String]
splitPath String
me) (TreeZipper (TSNode String) -> Maybe (TreeZipper (TSNode String)))
-> TreeZipper (TSNode String) -> Maybe (TreeZipper (TSNode String))
forall a b. (a -> b) -> a -> b
$ [Tree (TSNode String)] -> TreeZipper (TSNode String)
forall a. Forest a -> TreeZipper a
fromForest [Tree (TSNode String)]
wsf) ((String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
splitPath [String]
hist) X (Maybe String) -> (Maybe String -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X () -> (String -> X ()) -> Maybe String -> X ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
 -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
  -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
 -> X ())
-> (String
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
    -> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail)
-> String
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
-> StackSet String (Layout Pixel) Pixel ScreenId ScreenDetail
f)

      else IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
        -- error!
        let msg :: String
msg = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ String
"Please add:"
                            , String
"    workspaces = toWorkspaces myWorkspaces"
                            , String
"to your XMonad config!"
                            , String
""
                            , String
"XConfig.workspaces: "
                            ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Workspace String (Layout Pixel) Pixel -> String)
-> [Workspace String (Layout Pixel) Pixel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Workspace String (Layout Pixel) Pixel -> String
forall i l a. Workspace i l a -> i
tag [Workspace String (Layout Pixel) Pixel]
ws
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
xmessage String
msg
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    mkNode :: String -> Workspace a l Pixel -> X (TSNode a)
mkNode String
n Workspace a l Pixel
w = do
        -- find the focused window's name on this workspace
        String
name <- X String
-> (Stack Pixel -> X String) -> Maybe (Stack Pixel) -> X String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> X String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"") ((NamedWindow -> String) -> X NamedWindow -> X String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedWindow -> String
forall a. Show a => a -> String
show (X NamedWindow -> X String)
-> (Stack Pixel -> X NamedWindow) -> Stack Pixel -> X String
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 String)
-> Maybe (Stack Pixel) -> X String
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
        TSNode a -> X (TSNode a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TSNode a -> X (TSNode a)) -> TSNode a -> X (TSNode a)
forall a b. (a -> b) -> a -> b
$ String -> String -> a -> TSNode a
forall a. String -> String -> a -> TSNode a
TSNode String
n String
name (Workspace a l Pixel -> a
forall i l a. Workspace i l a -> i
tag Workspace a l Pixel
w)

-- | Convert the workspace-tree to a flat list of paths such that XMonad can use them
--
-- The Nodes will be separated by a dot (\'.\') character
toWorkspaces :: Forest String -> [WorkspaceId]
toWorkspaces :: Forest String -> [String]
toWorkspaces = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> b
snd ([(String, String)] -> [String])
-> (Forest String -> [(String, String)])
-> Forest String
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (String, String) -> [(String, String)])
-> [Tree (String, String)] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree (String, String) -> [(String, String)]
forall a. Tree a -> [a]
flatten ([Tree (String, String)] -> [(String, String)])
-> (Forest String -> [Tree (String, String)])
-> Forest String
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest String -> [Tree (String, String)]
mkPaths

mkPaths :: Forest String -> Forest (String, WorkspaceId)
mkPaths :: Forest String -> [Tree (String, String)]
mkPaths = (Tree String -> Tree (String, String))
-> Forest String -> [Tree (String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node String
n Forest String
ns) -> (String, String)
-> [Tree (String, String)] -> Tree (String, String)
forall a. a -> Forest a -> Tree a
Node (String
n, String
n) ((Tree String -> Tree (String, String))
-> Forest String -> [Tree (String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Tree String -> Tree (String, String)
f String
n) Forest String
ns))
  where
    f :: String -> Tree String -> Tree (String, String)
f String
pth (Node String
x Forest String
xs) = let pth' :: String
pth' = String
pth String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
x
                         in (String, String)
-> [Tree (String, String)] -> Tree (String, String)
forall a. a -> Forest a -> Tree a
Node (String
x, String
pth') ((Tree String -> Tree (String, String))
-> Forest String -> [Tree (String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Tree String -> Tree (String, String)
f String
pth') Forest String
xs)

splitPath :: WorkspaceId -> [String]
splitPath :: String -> [String]
splitPath String
i = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
i of
    (String
x,   []) -> [String
x]
    (String
x, Char
_:String
xs) -> String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitPath String
xs

-- | Select from a Tree of 'X' actions
--
-- <<https://wiki.haskell.org/wikiupload/thumb/9/9b/Treeselect-Action.png/800px-Treeselect-Action.png>>
--
-- Each of these actions have to be specified inside a 'TSNode'
--
-- Example
--
-- > treeselectAction myTreeConf
-- >    [ Node (TSNode "Hello"    "displays hello"      (spawn "xmessage hello!")) []
-- >    , Node (TSNode "Shutdown" "Poweroff the system" (spawn "shutdown")) []
-- >    , Node (TSNode "Brightness" "Sets screen brightness using xbacklight" (return ()))
-- >        [ Node (TSNode "Bright" "FULL POWER!!"            (spawn "xbacklight -set 100")) []
-- >        , Node (TSNode "Normal" "Normal Brightness (50%)" (spawn "xbacklight -set 50"))  []
-- >        , Node (TSNode "Dim"    "Quite dark"              (spawn "xbacklight -set 10"))  []
-- >        ]
-- >    ]
treeselectAction :: TSConfig (X a) -> Forest (TSNode (X a)) -> X ()
treeselectAction :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()

forMForest :: (Functor m, Applicative m, Monad m) => [Tree a] -> (a -> m b) -> m [Tree b]
forMForest :: [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)
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 :: (a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
f (Node a
x Forest a
xs) = b -> Forest b -> Tree b
forall a. a -> Forest a -> Tree a
Node (b -> Forest b -> Tree b) -> m b -> m (Forest b -> Tree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x m (Forest b -> Tree b) -> m (Forest b) -> m (Tree b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  (Tree a -> m (Tree b)) -> Forest a -> m (Forest b)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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) Forest a
xs


-- | Quit returning the currently selected node
select :: TreeSelect a (Maybe a)
select :: 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))

-- | Quit without returning anything
cancel :: TreeSelect a (Maybe a)
cancel :: TreeSelect a (Maybe a)
cancel = Maybe a -> TreeSelect a (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- TODO: redraw only what is necessary.
-- Examples: redrawAboveCursor, redrawBelowCursor and redrawCursor

-- | Move the cursor to its parent node
moveParent :: TreeSelect a (Maybe a)
moveParent :: 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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Move the cursor one level down, highlighting its first child-node
moveChild :: TreeSelect a (Maybe a)
moveChild :: 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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Move the cursor to the next child-node
moveNext :: TreeSelect a (Maybe a)
moveNext :: 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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Move the cursor to the previous child-node
movePrev :: TreeSelect a (Maybe a)
movePrev :: 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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Move backwards in history
moveHistBack :: TreeSelect a (Maybe a)
moveHistBack :: TreeSelect a (Maybe a)
moveHistBack = do
    TSState a
s <- TreeSelect a (TSState a)
forall s (m :: * -> *). MonadState s m => m s
get
    case TSState a -> ([[String]], [[String]])
forall a. TSState a -> ([[String]], [[String]])
tss_history TSState a
s of
        ([[String]]
xs, [String]
a:[String]
y:[[String]]
ys) -> do
            TSState a -> TreeSelect a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{tss_history :: ([[String]], [[String]])
tss_history = ([String]
a[String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:[[String]]
xs, [String]
y[String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:[[String]]
ys)}
            [String] -> TreeSelect a (Maybe a)
forall a. [String] -> TreeSelect a (Maybe a)
moveTo [String]
y
        ([[String]], [[String]])
_ -> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Move forward in history
moveHistForward :: TreeSelect a (Maybe a)
moveHistForward :: TreeSelect a (Maybe a)
moveHistForward = do
    TSState a
s <- TreeSelect a (TSState a)
forall s (m :: * -> *). MonadState s m => m s
get
    case TSState a -> ([[String]], [[String]])
forall a. TSState a -> ([[String]], [[String]])
tss_history TSState a
s of
        ([String]
x:[[String]]
xs, [[String]]
ys) -> do
            TSState a -> TreeSelect a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TSState a
s{tss_history :: ([[String]], [[String]])
tss_history = ([[String]]
xs, [String]
x[String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:[[String]]
ys)}
            [String] -> TreeSelect a (Maybe a)
forall a. [String] -> TreeSelect a (Maybe a)
moveTo [String]
x
        ([[String]], [[String]])
_ -> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Move to a specific node
moveTo :: [String] -- ^ path, always starting from the top
       -> TreeSelect a (Maybe a)
moveTo :: [String] -> TreeSelect a (Maybe a)
moveTo [String]
i = (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith ((TSNode a -> String)
-> [String]
-> TreeZipper (TSNode a)
-> Maybe (TreeZipper (TSNode a))
forall b a.
Eq b =>
(a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a)
followPath TSNode a -> String
forall a. TSNode a -> String
tsn_name [String]
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Apply a transformation on the internal 'XMonad.Util.TreeZipper.TreeZipper'.
moveWith :: (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))) -> TreeSelect a ()
moveWith :: (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
f = do
    TSState a
s <- TreeSelect a (TSState a)
forall s (m :: * -> *). MonadState s m => m s
get
    case TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))
f (TSState a -> TreeZipper (TSNode a)
forall a. TSState a -> TreeZipper (TSNode a)
tss_tree TSState a
s) of
        -- TODO: redraw cursor only?
        Just TreeZipper (TSNode a)
t -> TSState a -> TreeSelect a ()
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 -> () -> TreeSelect a ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | wait for keys and run navigation
navigate :: TreeSelect a (Maybe a)
navigate :: 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 (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 (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

    Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e

    if | Event -> Dimension
ev_event_type Event
ev Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress -> do
           (Maybe Pixel
ks, String
_) <- XKeyEventPtr -> IO (Maybe Pixel, String)
lookupString (XKeyEventPtr -> IO (Maybe Pixel, String))
-> XKeyEventPtr -> IO (Maybe Pixel, String)
forall a b. (a -> b) -> a -> b
$ XEventPtr -> XKeyEventPtr
asKeyEvent XEventPtr
e
           TreeSelect a (Maybe a) -> IO (TreeSelect a (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeSelect a (Maybe a) -> IO (TreeSelect a (Maybe a)))
-> TreeSelect a (Maybe a) -> IO (TreeSelect a (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
               KeyMask
mask <- X KeyMask -> TreeSelect a KeyMask
forall a b. X a -> TreeSelect b a
liftX (X KeyMask -> TreeSelect a KeyMask)
-> X KeyMask -> TreeSelect a KeyMask
forall a b. (a -> b) -> a -> b
$ KeyMask -> X KeyMask
cleanMask (Event -> KeyMask
ev_state Event
ev)
               Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
f <- (TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a)))
-> TreeSelect a (Map (KeyMask, Pixel) (TreeSelect a (Maybe a)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate
               TreeSelect a (Maybe a)
-> Maybe (TreeSelect a (Maybe a)) -> TreeSelect a (Maybe a)
forall a. a -> Maybe a -> a
fromMaybe TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate (Maybe (TreeSelect a (Maybe a)) -> TreeSelect a (Maybe a))
-> Maybe (TreeSelect a (Maybe a)) -> TreeSelect a (Maybe a)
forall a b. (a -> b) -> a -> b
$ (KeyMask, Pixel)
-> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
-> Maybe (TreeSelect a (Maybe a))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
mask, Pixel -> Maybe Pixel -> Pixel
forall a. a -> Maybe a -> a
fromMaybe Pixel
xK_VoidSymbol Maybe Pixel
ks) Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
f
       | Event -> Dimension
ev_event_type Event
ev Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress -> do
           -- See XMonad.Prompt Note [Allow ButtonEvents]
           Display -> CInt -> Pixel -> IO ()
allowEvents Display
d CInt
replayPointer Pixel
currentTime
           TreeSelect a (Maybe a) -> IO (TreeSelect a (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate
       | Bool
otherwise -> TreeSelect a (Maybe a) -> IO (TreeSelect a (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return TreeSelect a (Maybe a)
forall a. TreeSelect a (Maybe a)
navigate

-- | Request a full redraw
redraw :: TreeSelect a ()
redraw :: TreeSelect a ()
redraw = do
    Pixel
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
    Display
dpy <- (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

    -- clear window
    -- TODO: not always needed!
    IO () -> TreeSelect a ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeSelect a ()) -> IO () -> TreeSelect a ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO ()
clearWindow Display
dpy Pixel
win

    TreeZipper (TSNode a)
t <- (TSState a -> TreeZipper (TSNode a))
-> TreeSelect a (TreeZipper (TSNode a))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TSState a -> TreeZipper (TSNode a)
forall a. TSState a -> TreeZipper (TSNode a)
tss_tree
    Int
_ <- Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
forall a.
Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers Int
0 Int
0 ([(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
forall a. [a] -> [a]
reverse ([(Forest (TSNode a), TSNode a, Forest (TSNode a))]
 -> [(Forest (TSNode a), TSNode a, Forest (TSNode a))])
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
forall a b. (a -> b) -> a -> b
$ (TreeZipper (TSNode a) -> Forest (TSNode a)
forall a. TreeZipper a -> Forest a
tz_before TreeZipper (TSNode a)
t, TreeZipper (TSNode a) -> TSNode a
forall a. TreeZipper a -> a
cursor TreeZipper (TSNode a)
t, TreeZipper (TSNode a) -> Forest (TSNode a)
forall a. TreeZipper a -> Forest a
tz_after TreeZipper (TSNode a)
t) (Forest (TSNode a), TSNode a, Forest (TSNode a))
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
forall a. a -> [a] -> [a]
: TreeZipper (TSNode a)
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
forall a. TreeZipper a -> [(Forest a, a, Forest a)]
tz_parents TreeZipper (TSNode a)
t)
    () -> TreeSelect a ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

drawLayers :: Int -- ^ indentation level
           -> Int -- ^ height
           -> [(Forest (TSNode a), TSNode a, Forest (TSNode a))] -- ^ node layers (from top to bottom!)
           -> TreeSelect a Int
drawLayers :: Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers Int
_ Int
yl [] = Int -> TreeSelect a Int
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
String
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 :: String
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 -> String
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} <- TreeSelect a (TSConfig a)
forall r (m :: * -> *). MonadReader r m => m r
ask

    let nodeColor :: a -> (Pixel, Pixel)
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

    -- draw nodes above
    [(Int, Tree (TSNode a))]
-> ((Int, Tree (TSNode a)) -> TreeSelect a ()) -> TreeSelect a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> Forest (TSNode a) -> [(Int, Tree (TSNode a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
yl ..] (Forest (TSNode a) -> Forest (TSNode a)
forall a. [a] -> [a]
reverse Forest (TSNode a)
bs)) (((Int, Tree (TSNode a)) -> TreeSelect a ()) -> TreeSelect a ())
-> ((Int, Tree (TSNode a)) -> TreeSelect a ()) -> TreeSelect a ()
forall a b. (a -> b) -> a -> b
$ \(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)
        -- drawLayers (xl + 1) (y + 1) ns
        -- TODO: draw rest? if not ts_hidechildren
        -- drawLayers (xl + 1) (y + 1) ns

    -- draw the current / parent node
    -- if this is the last (currently focused) we use the 'ts_highlight' color
    let current_level :: Int
current_level = Int
yl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Forest (TSNode a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
bs
    Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
current_level TSNode a
c ((Pixel, Pixel) -> TreeSelect a ())
-> (Pixel, Pixel) -> TreeSelect a ()
forall a b. (a -> b) -> a -> b
$
        if [(Forest (TSNode a), TSNode a, Forest (TSNode a))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs then (Pixel, Pixel)
ts_highlight
                   else Int -> (Pixel, Pixel)
forall a. Integral a => a -> (Pixel, Pixel)
nodeColor Int
current_level

    Int
l2 <- Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
forall a.
Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers (Int
xl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
current_level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs

    -- draw nodes below
    [(Int, Tree (TSNode a))]
-> ((Int, Tree (TSNode a)) -> TreeSelect a ()) -> TreeSelect a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> Forest (TSNode a) -> [(Int, Tree (TSNode a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
l2 ..] Forest (TSNode a)
as) (((Int, Tree (TSNode a)) -> TreeSelect a ()) -> TreeSelect a ())
-> ((Int, Tree (TSNode a)) -> TreeSelect a ()) -> TreeSelect a ()
forall a b. (a -> b) -> a -> b
$ \(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)
        -- TODO: draw rest? if not ts_hidechildren
        -- drawLayers (xl + 1) (y + 1) ns
    Int -> TreeSelect a Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Forest (TSNode a) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
as)


-- | Draw a node at a given indentation and height level
drawNode :: Int -- ^ indentation level (not in pixels)
         -> Int -- ^ height level (not in pixels)
         -> TSNode a -- ^ node to draw
         -> (Pixel, Pixel) -- ^ node foreground (font) and background color
         -> TreeSelect a ()
drawNode :: Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
ix Int
iy TSNode{a
String
tsn_value :: a
tsn_extra :: String
tsn_name :: String
tsn_value :: forall a. TSNode a -> a
tsn_extra :: forall a. TSNode a -> String
tsn_name :: forall a. TSNode a -> String
..} (Pixel, Pixel)
col = do
    TSConfig{Bool
Int
String
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 :: String
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 -> String
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} <- TreeSelect a (TSConfig a)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Pixel
window       <- (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
    Display
display      <- (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
    XMonadFont
font         <- (TSState a -> XMonadFont) -> TreeSelect a XMonadFont
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TSState a -> XMonadFont
forall a. TSState a -> XMonadFont
tss_xfont
    GC
gc           <- (TSState a -> GC) -> TreeSelect a GC
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TSState a -> GC
forall a. TSState a -> GC
tss_gc
    Pixel
colormap <- (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_colormap
    Visual
visual   <- (TSState a -> Visual) -> TreeSelect a Visual
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TSState a -> Visual
forall a. TSState a -> Visual
tss_visual
    IO () -> TreeSelect a ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeSelect a ()) -> IO () -> TreeSelect a ()
forall a b. (a -> b) -> a -> b
$ Pixel
-> Display
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> (Pixel, Pixel)
-> String
-> Pixel
-> String
-> Int
-> Int
-> Int
-> Int
-> IO ()
drawWinBox Pixel
window Display
display Visual
visual Pixel
colormap GC
gc XMonadFont
font (Pixel, Pixel)
col String
tsn_name Pixel
ts_extra String
tsn_extra
        (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ts_indent Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ts_originX) (Int
iy Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ts_node_height Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ts_originY)
        Int
ts_node_width Int
ts_node_height

    -- TODO: draw extra text (transparent background? or ts_background)
    -- drawWinBox window fnt col2 nodeH (scW-x) (mes) (x+nodeW) y 8

-- | Draw a simple box with text
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)
-> String
-> Pixel
-> String
-> Int
-> Int
-> Int
-> Int
-> IO ()
drawWinBox Pixel
win Display
display Visual
visual Pixel
colormap GC
gc XMonadFont
font (Pixel
fg, Pixel
bg) String
text Pixel
fg2 String
text2 Int
x Int
y Int
w Int
h = do
    -- draw box
    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)

    -- dreaw text
    Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> String
-> 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)
        String
text

    -- dreaw extra text
    Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> String
-> 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)
        String
text2

-- | Modified version of 'XMonad.Util.Font.printStringXMF' that uses 'Pixel' as color format
drawStringXMF :: Display -> Drawable -> Visual -> Colormap -> GC
              -> XMonadFont -- ^ XMF Font
              -> Pixel -- ^ font color
              -> Position   -- ^ x-position
              -> Position   -- ^ y-position
              -> String -- ^ string text
              -> IO ()
drawStringXMF :: Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> String
-> IO ()
drawStringXMF Display
display Pixel
window Visual
visual Pixel
colormap GC
gc XMonadFont
font Pixel
col Position
x Position
y String
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 -> String -> IO ()
drawImageString Display
display Pixel
window GC
gc Position
x Position
y String
text
    Utf8 FontSet
fnt -> do
        Display -> GC -> Pixel -> IO ()
setForeground Display
display GC
gc Pixel
col
        Display
-> Pixel
-> FontSet
-> GC
-> Position
-> Position
-> String
-> IO ()
wcDrawImageString Display
display Pixel
window FontSet
fnt GC
gc Position
x Position
y String
text
#ifdef XFT
    Xft XftFont
fnt -> 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
$
            \XftColor
ft_color -> XftDraw
-> XftColor -> XftFont -> Position -> Position -> String -> IO ()
forall a1 a2.
(Integral a1, Integral a2) =>
XftDraw -> XftColor -> XftFont -> a1 -> a2 -> String -> IO ()
xftDrawString XftDraw
ft_draw XftColor
ft_color XftFont
fnt Position
x Position
y String
text

-- | Convert 'Pixel' to 'XRenderColor'
--
-- Note that it uses short to represent its components
fromARGB :: Pixel -> XRenderColor
fromARGB :: Pixel -> XRenderColor
fromARGB Pixel
x =
#if MIN_VERSION_X11_xft(0, 3, 3)
    XRenderColor r g b a
#else
    -- swapped green/blue as a workaround for the faulty Storable instance in X11-xft < 0.3.3
    Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
r Int
b Int
g Int
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