{-# 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 qualified Data.List.NonEmpty as NE
import Graphics.X11.Xrender
import Graphics.X11.Xft
#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 { forall a. 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!)
                           , forall a. TSConfig a -> Pixel
ts_background :: Pixel -- ^ background color filling the entire screen.

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

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

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

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

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

                           , forall a.
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 { ts_hidechildren :: Bool
ts_hidechildren = Bool
True
                   , ts_background :: Pixel
ts_background   = Pixel
0xc0c0c0c0
                   , ts_font :: WorkspaceId
ts_font         = WorkspaceId
"xft:Sans-16"
                   , ts_node :: (Pixel, Pixel)
ts_node         = (Pixel
0xff000000, Pixel
0xff50d0db)
                   , ts_nodealt :: (Pixel, Pixel)
ts_nodealt      = (Pixel
0xff000000, Pixel
0xff10b8d6)
                   , ts_highlight :: (Pixel, Pixel)
ts_highlight    = (Pixel
0xffffffff, Pixel
0xffff0000)
                   , ts_extra :: Pixel
ts_extra        = Pixel
0xff000000
                   , ts_node_width :: Int
ts_node_width   = Int
200
                   , ts_node_height :: Int
ts_node_height  = Int
30
                   , ts_originX :: Int
ts_originX      = Int
0
                   , ts_originY :: Int
ts_originY      = Int
0
                   , ts_indent :: Int
ts_indent       = Int
80
                   , ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate     = forall a. Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
defaultNavigation
                   }

-- | 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 :: forall a. Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
defaultNavigation = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ ((KeyMask
0, Pixel
xK_Escape), forall a. TreeSelect a (Maybe a)
cancel)
    , ((KeyMask
0, Pixel
xK_Return), forall a. TreeSelect a (Maybe a)
select)
    , ((KeyMask
0, Pixel
xK_space),  forall a. TreeSelect a (Maybe a)
select)
    , ((KeyMask
0, Pixel
xK_Up),     forall a. TreeSelect a (Maybe a)
movePrev)
    , ((KeyMask
0, Pixel
xK_Down),   forall a. TreeSelect a (Maybe a)
moveNext)
    , ((KeyMask
0, Pixel
xK_Left),   forall a. TreeSelect a (Maybe a)
moveParent)
    , ((KeyMask
0, Pixel
xK_Right),  forall a. TreeSelect a (Maybe a)
moveChild)
    , ((KeyMask
0, Pixel
xK_k),      forall a. TreeSelect a (Maybe a)
movePrev)
    , ((KeyMask
0, Pixel
xK_j),      forall a. TreeSelect a (Maybe a)
moveNext)
    , ((KeyMask
0, Pixel
xK_h),      forall a. TreeSelect a (Maybe a)
moveParent)
    , ((KeyMask
0, Pixel
xK_l),      forall a. TreeSelect a (Maybe a)
moveChild)
    , ((KeyMask
0, Pixel
xK_o),      forall a. TreeSelect a (Maybe a)
moveHistBack)
    , ((KeyMask
0, Pixel
xK_i),      forall a. TreeSelect a (Maybe a)
moveHistForward)
    ]

-- | Default configuration.
--
-- Using nice alternating blue nodes
tsDefaultConfig :: TSConfig a
tsDefaultConfig :: forall a. TSConfig a
tsDefaultConfig = forall a. Default a => a
def
{-# DEPRECATED tsDefaultConfig "Use def (from Data.Default, and re-exported by XMonad.Actions.TreeSelect) instead." #-}

-- | Tree Node With a name and extra text
data TSNode a = TSNode { forall a. TSNode a -> WorkspaceId
tsn_name  :: String
                       , forall a. TSNode a -> WorkspaceId
tsn_extra :: String -- ^ extra text, displayed next to the node name
                       , forall a. 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 { 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) -- ^ size of 'tz_window'
                         , 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]]) -- ^ history zipper, navigated with 'moveHistBack' and 'moveHistForward'
                         }

-- | State monad transformer using 'TSState'
newtype TreeSelect a b = TreeSelect { forall a b.
TreeSelect a b -> ReaderT (TSConfig a) (StateT (TSState a) X) b
runTreeSelect :: ReaderT (TSConfig a) (StateT (TSState a) X) b }
    deriving (forall {a}. Applicative (TreeSelect a)
forall a. a -> TreeSelect a a
forall a a. a -> TreeSelect a a
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> TreeSelect a a
$creturn :: forall a a. a -> TreeSelect a a
>> :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$c>> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
>>= :: forall a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
$c>>= :: forall a a b.
TreeSelect a a -> (a -> TreeSelect a b) -> TreeSelect a b
Monad, forall {a}. Functor (TreeSelect a)
forall a. a -> TreeSelect a a
forall a a. a -> TreeSelect a a
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
forall a a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
forall a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
forall a a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
$c<* :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a a
*> :: forall a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
$c*> :: forall a a b. TreeSelect a a -> TreeSelect a b -> TreeSelect a b
liftA2 :: forall a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
$cliftA2 :: forall a a b c.
(a -> b -> c) -> TreeSelect a a -> TreeSelect a b -> TreeSelect a c
<*> :: forall a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
$c<*> :: forall a a b.
TreeSelect a (a -> b) -> TreeSelect a a -> TreeSelect a b
pure :: forall a. a -> TreeSelect a a
$cpure :: forall a a. a -> TreeSelect a a
Applicative, forall a b. a -> TreeSelect a b -> TreeSelect a a
forall a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
forall a a b. a -> TreeSelect a b -> TreeSelect a a
forall a a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TreeSelect a b -> TreeSelect a a
$c<$ :: forall a a b. a -> TreeSelect a b -> TreeSelect a a
fmap :: forall a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
$cfmap :: forall a a b. (a -> b) -> TreeSelect a a -> TreeSelect a b
Functor, MonadState (TSState a),  MonadReader (TSConfig a), forall a. Monad (TreeSelect a)
forall a. IO a -> TreeSelect a a
forall a a. IO a -> TreeSelect a a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> TreeSelect a a
$cliftIO :: forall a a. IO a -> TreeSelect a a
MonadIO)

-- | Lift the 'X' action into the 'XMonad.Actions.TreeSelect.TreeSelect' monad
liftX :: X a -> TreeSelect b a
liftX :: forall a b. X a -> TreeSelect b a
liftX = forall a b.
ReaderT (TSConfig a) (StateT (TSState a) X) b -> TreeSelect a b
TreeSelect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | 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 :: forall a. TSConfig a -> Forest (TSNode a) -> X (Maybe a)
treeselect TSConfig a
c Forest (TSNode a)
t = forall a.
TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
treeselectAt TSConfig a
c (forall a. Forest a -> TreeZipper a
fromForest Forest (TSNode a)
t) []

-- | 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 :: forall a.
TSConfig a
-> TreeZipper (TSNode a) -> [[WorkspaceId]] -> X (Maybe a)
treeselectAt conf :: TSConfig a
conf@TSConfig{Bool
Int
WorkspaceId
Pixel
(Pixel, Pixel)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: Int
ts_originY :: Int
ts_originX :: Int
ts_node_height :: Int
ts_node_width :: Int
ts_extra :: Pixel
ts_highlight :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
ts_font :: WorkspaceId
ts_background :: Pixel
ts_hidechildren :: Bool
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_node_width :: forall a. TSConfig a -> Int
ts_extra :: forall a. TSConfig a -> Pixel
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} TreeZipper (TSNode a)
zipper [[WorkspaceId]]
hist = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
display -> do
    -- create a window on the currently focused screen
    Pixel
rootw <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Pixel
theRoot
    Rectangle{Position
Dimension
rect_x :: Rectangle -> Position
rect_y :: Rectangle -> Position
rect_width :: Rectangle -> Dimension
rect_height :: Rectangle -> Dimension
rect_height :: Dimension
rect_width :: Dimension
rect_y :: Position
rect_x :: Position
..} <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset

    Just VisualInfo
vinfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Dimension -> CInt -> CInt -> IO (Maybe VisualInfo)
matchVisualInfo Display
display (Display -> Dimension
defaultScreen Display
display) CInt
32 CInt
4

    Pixel
colormap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Visual -> CInt -> IO Pixel
createColormap Display
display Pixel
rootw (VisualInfo -> Visual
visualInfo_visual VisualInfo
vinfo) CInt
allocNone

    Pixel
win <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
attributes -> do
        Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
        Ptr SetWindowAttributes -> Pixel -> IO ()
set_colormap Ptr SetWindowAttributes
attributes Pixel
colormap
        Ptr SetWindowAttributes -> Pixel -> IO ()
set_background_pixel Ptr SetWindowAttributes
attributes Pixel
ts_background
        Ptr SetWindowAttributes -> Pixel -> IO ()
set_border_pixel Ptr SetWindowAttributes
attributes Pixel
0
        Pixel
w <- Display
-> Pixel
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> Pixel
-> Ptr SetWindowAttributes
-> IO Pixel
createWindow Display
display Pixel
rootw Position
rect_x Position
rect_y Dimension
rect_width Dimension
rect_height CInt
0 (VisualInfo -> CInt
visualInfo_depth VisualInfo
vinfo) CInt
inputOutput (VisualInfo -> Visual
visualInfo_visual VisualInfo
vinfo) (Pixel
cWColormap forall a. Bits a => a -> a -> a
.|. Pixel
cWBorderPixel forall a. Bits a => a -> a -> a
.|. Pixel
cWBackPixel) Ptr SetWindowAttributes
attributes
        Display -> Pixel -> ClassHint -> IO ()
setClassHint Display
display Pixel
w (WorkspaceId -> WorkspaceId -> ClassHint
ClassHint WorkspaceId
"xmonad-tree_select" WorkspaceId
"xmonad")
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel
w

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- 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 forall a. Bits a => a -> a -> a
.|. Pixel
keyPressMask 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Bool -> CInt -> CInt -> Pixel -> IO CInt
grabKeyboard Display
display Pixel
win Bool
True CInt
grabModeAsync CInt
grabModeAsync Pixel
currentTime

    Maybe a
r <- if CInt
status forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess
        then do
            -- load the XMF font
            GC
gc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> IO GC
createGC Display
display Pixel
win
            XMonadFont
xfont <- WorkspaceId -> X XMonadFont
initXMF WorkspaceId
ts_font

            -- run the treeselect Monad
            Maybe a
ret <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a b.
TreeSelect a b -> ReaderT (TSConfig a) (StateT (TSState a) X) b
runTreeSelect (forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate)) TSConfig a
conf)
                TSState{ tss_tree :: TreeZipper (TSNode a)
tss_tree     = TreeZipper (TSNode a)
zipper
                       , tss_window :: Pixel
tss_window   = Pixel
win
                       , tss_display :: Display
tss_display  = Display
display
                       , tss_xfont :: XMonadFont
tss_xfont    = XMonadFont
xfont
                       , tss_size :: (Int, Int)
tss_size     = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
rect_width, forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
rect_height)
                       , tss_gc :: GC
tss_gc       = GC
gc
                       , tss_visual :: Visual
tss_visual   = VisualInfo -> Visual
visualInfo_visual VisualInfo
vinfo
                       , tss_colormap :: Pixel
tss_colormap = Pixel
colormap
                       , tss_history :: ([[WorkspaceId]], [[WorkspaceId]])
tss_history = ([], [[WorkspaceId]]
hist)
                       }

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

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

    -- destroy the window
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Display -> Pixel -> IO ()
unmapWindow Display
display Pixel
win
        Display -> Pixel -> IO ()
destroyWindow Display
display Pixel
win
        Display -> Pixel -> IO ()
freeColormap Display
display Pixel
colormap
        -- 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
    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 WorkspaceId
-> Forest WorkspaceId
-> (WorkspaceId -> WindowSet -> WindowSet)
-> X ()
treeselectWorkspace TSConfig WorkspaceId
c Forest WorkspaceId
xs WorkspaceId -> WindowSet -> WindowSet
f = do
    -- get all defined workspaces
    -- They have to be set with 'toWorkspaces'!
    [Workspace WorkspaceId (Layout Pixel) Pixel]
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)

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

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

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

-- | 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 WorkspaceId -> [WorkspaceId]
toWorkspaces = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest WorkspaceId -> Forest (WorkspaceId, WorkspaceId)
mkPaths

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

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

-- | 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 :: forall a. TSConfig (X a) -> Forest (TSNode (X a)) -> X ()
treeselectAction TSConfig (X a)
c Forest (TSNode (X a))
xs = forall a. TSConfig a -> Forest (TSNode a) -> X (Maybe a)
treeselect TSConfig (X a)
c Forest (TSNode (X a))
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just X a
a  -> forall (f :: * -> *) a. Functor f => f a -> f ()
void X a
a
    Maybe (X a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

forMForest :: (Functor m, Applicative m, Monad m) => [Tree a] -> (a -> m b) -> m [Tree b]
forMForest :: forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
[Tree a] -> (a -> m b) -> m [Tree b]
forMForest [Tree a]
x a -> m b
g = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
(a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
g) [Tree a]
x

mapMTree :: (Functor m, Applicative m, Monad m) => (a -> m b) -> Tree a -> m (Tree b)
mapMTree :: forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
(a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
f (Node a
x [Tree a]
xs) = forall a. a -> [Tree a] -> Tree a
Node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a b.
(Functor m, Applicative m, Monad m) =>
(a -> m b) -> Tree a -> m (Tree b)
mapMTree a -> m b
f) [Tree a]
xs


-- | Quit returning the currently selected node
select :: TreeSelect a (Maybe a)
select :: forall a. TreeSelect a (Maybe a)
select = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. TSNode a -> a
tsn_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TreeZipper a -> a
cursor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TSState a -> TreeZipper (TSNode a)
tss_tree))

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

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

-- | Move the cursor to its parent node
moveParent :: TreeSelect a (Maybe a)
moveParent :: forall a. TreeSelect a (Maybe a)
moveParent = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
parent forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate

-- | Move the cursor one level down, highlighting its first child-node
moveChild :: TreeSelect a (Maybe a)
moveChild :: forall a. TreeSelect a (Maybe a)
moveChild = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
children forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate

-- | Move the cursor to the next child-node
moveNext :: TreeSelect a (Maybe a)
moveNext :: forall a. TreeSelect a (Maybe a)
moveNext = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
nextChild forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate

-- | Move the cursor to the previous child-node
movePrev :: TreeSelect a (Maybe a)
movePrev :: forall a. TreeSelect a (Maybe a)
movePrev = forall a.
(TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a)))
-> TreeSelect a ()
moveWith forall a. TreeZipper a -> Maybe (TreeZipper a)
previousChild forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a ()
redraw forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TreeSelect a (Maybe a)
navigate

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

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

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

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

-- | wait for keys and run navigation
navigate :: TreeSelect a (Maybe a)
navigate :: forall a. TreeSelect a (Maybe a)
navigate = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Display
tss_display forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Display
d -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
    Display -> Pixel -> XEventPtr -> IO ()
maskEvent Display
d (Pixel
exposureMask forall a. Bits a => a -> a -> a
.|. Pixel
keyPressMask forall a. Bits a => a -> a -> a
.|. Pixel
buttonReleaseMask forall a. Bits a => a -> a -> a
.|. Pixel
buttonPressMask) XEventPtr
e

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

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

-- | Request a full redraw
redraw :: TreeSelect a ()
redraw :: forall a. TreeSelect a ()
redraw = do
    Pixel
win <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Pixel
tss_window
    Display
dpy <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Display
tss_display

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

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

drawLayers :: Int -- ^ indentation level
           -> Int -- ^ height
           -> [(Forest (TSNode a), TSNode a, Forest (TSNode a))] -- ^ node layers (from top to bottom!)
           -> TreeSelect a Int
drawLayers :: forall a.
Int
-> Int
-> [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
-> TreeSelect a Int
drawLayers Int
_ Int
yl [] = forall (m :: * -> *) a. Monad m => a -> m a
return Int
yl
drawLayers Int
xl Int
yl ((Forest (TSNode a)
bs, TSNode a
c, Forest (TSNode a)
as):[(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs) = do
    TSConfig{Bool
Int
WorkspaceId
Pixel
(Pixel, Pixel)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: Int
ts_originY :: Int
ts_originX :: Int
ts_node_height :: Int
ts_node_width :: Int
ts_extra :: Pixel
ts_highlight :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
ts_font :: WorkspaceId
ts_background :: Pixel
ts_hidechildren :: Bool
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_node_width :: forall a. TSConfig a -> Int
ts_extra :: forall a. TSConfig a -> Pixel
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask

    let nodeColor :: a -> (Pixel, Pixel)
nodeColor a
y = if forall a. Integral a => a -> Bool
odd a
y then (Pixel, Pixel)
ts_node else (Pixel, Pixel)
ts_nodealt

    -- draw nodes above
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
yl ..] (forall a. [a] -> [a]
reverse Forest (TSNode a)
bs)) forall a b. (a -> b) -> a -> b
$ \(Int
y, Node TSNode a
n Forest (TSNode a)
_) ->
        forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
y TSNode a
n (forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
y)
        -- 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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
bs
    forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
current_level TSNode a
c forall a b. (a -> b) -> a -> b
$
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Forest (TSNode a), TSNode a, Forest (TSNode a))]
xs then (Pixel, Pixel)
ts_highlight
                   else forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
current_level

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

    -- draw nodes below
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
l2 ..] Forest (TSNode a)
as) forall a b. (a -> b) -> a -> b
$ \(Int
y, Node TSNode a
n Forest (TSNode a)
_) ->
        forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
xl Int
y TSNode a
n (forall {a}. Integral a => a -> (Pixel, Pixel)
nodeColor Int
y)
        -- TODO: draw rest? if not ts_hidechildren
        -- drawLayers (xl + 1) (y + 1) ns
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l2 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest (TSNode a)
as)


-- | 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 :: forall a.
Int -> Int -> TSNode a -> (Pixel, Pixel) -> TreeSelect a ()
drawNode Int
ix Int
iy TSNode{a
WorkspaceId
tsn_value :: a
tsn_extra :: WorkspaceId
tsn_name :: WorkspaceId
tsn_value :: forall a. TSNode a -> a
tsn_extra :: forall a. TSNode a -> WorkspaceId
tsn_name :: forall a. TSNode a -> WorkspaceId
..} (Pixel, Pixel)
col = do
    TSConfig{Bool
Int
WorkspaceId
Pixel
(Pixel, Pixel)
Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_navigate :: Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: Int
ts_originY :: Int
ts_originX :: Int
ts_node_height :: Int
ts_node_width :: Int
ts_extra :: Pixel
ts_highlight :: (Pixel, Pixel)
ts_nodealt :: (Pixel, Pixel)
ts_node :: (Pixel, Pixel)
ts_font :: WorkspaceId
ts_background :: Pixel
ts_hidechildren :: Bool
ts_navigate :: forall a.
TSConfig a -> Map (KeyMask, Pixel) (TreeSelect a (Maybe a))
ts_indent :: forall a. TSConfig a -> Int
ts_originY :: forall a. TSConfig a -> Int
ts_originX :: forall a. TSConfig a -> Int
ts_node_height :: forall a. TSConfig a -> Int
ts_node_width :: forall a. TSConfig a -> Int
ts_extra :: forall a. TSConfig a -> Pixel
ts_highlight :: forall a. TSConfig a -> (Pixel, Pixel)
ts_nodealt :: forall a. TSConfig a -> (Pixel, Pixel)
ts_node :: forall a. TSConfig a -> (Pixel, Pixel)
ts_font :: forall a. TSConfig a -> WorkspaceId
ts_background :: forall a. TSConfig a -> Pixel
ts_hidechildren :: forall a. TSConfig a -> Bool
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Pixel
window       <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Pixel
tss_window
    Display
display      <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Display
tss_display
    XMonadFont
font         <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> XMonadFont
tss_xfont
    GC
gc           <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> GC
tss_gc
    Pixel
colormap <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Pixel
tss_colormap
    Visual
visual   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TSState a -> Visual
tss_visual
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pixel
-> Display
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> (Pixel, Pixel)
-> WorkspaceId
-> Pixel
-> WorkspaceId
-> Int
-> Int
-> Int
-> Int
-> IO ()
drawWinBox Pixel
window Display
display Visual
visual Pixel
colormap GC
gc XMonadFont
font (Pixel, Pixel)
col WorkspaceId
tsn_name Pixel
ts_extra WorkspaceId
tsn_extra
        (Int
ix forall a. Num a => a -> a -> a
* Int
ts_indent forall a. Num a => a -> a -> a
+ Int
ts_originX) (Int
iy forall a. Num a => a -> a -> a
* Int
ts_node_height forall a. Num a => a -> a -> a
+ Int
ts_originY)
        Int
ts_node_width Int
ts_node_height

    -- 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)
-> 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
    -- 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)

    -- dreaw 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
fg
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
x forall a. Num a => a -> a -> a
+ Int
8)
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
y forall a. Num a => a -> a -> a
+ Int
h forall a. Num a => a -> a -> a
- Int
8)
        WorkspaceId
text

    -- dreaw extra text
    Display
-> Pixel
-> Visual
-> Pixel
-> GC
-> XMonadFont
-> Pixel
-> Position
-> Position
-> WorkspaceId
-> IO ()
drawStringXMF Display
display Pixel
win Visual
visual Pixel
colormap GC
gc XMonadFont
font Pixel
fg2
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
x forall a. Num a => a -> a -> a
+ Int
w forall a. Num a => a -> a -> a
+ Int
8)
        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
y forall a. Num a => a -> a -> a
+ Int
h forall a. Num a => a -> a -> a
- Int
8)
        WorkspaceId
text2

-- | 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
-> WorkspaceId
-> IO ()
drawStringXMF Display
display Pixel
window Visual
visual Pixel
colormap GC
gc XMonadFont
font Pixel
col Position
x Position
y WorkspaceId
text = case XMonadFont
font of
    Core FontStruct
fnt -> do
        Display -> GC -> Pixel -> IO ()
setForeground Display
display GC
gc Pixel
col
        Display -> GC -> Pixel -> IO ()
setFont Display
display GC
gc forall a b. (a -> b) -> a -> b
$ FontStruct -> Pixel
fontFromFontStruct FontStruct
fnt
        Display
-> Pixel -> GC -> Position -> Position -> WorkspaceId -> IO ()
drawImageString Display
display Pixel
window GC
gc Position
x Position
y WorkspaceId
text
    Utf8 FontSet
fnt -> do
        Display -> GC -> Pixel -> IO ()
setForeground Display
display GC
gc Pixel
col
        Display
-> Pixel
-> FontSet
-> GC
-> Position
-> Position
-> WorkspaceId
-> IO ()
wcDrawImageString Display
display Pixel
window FontSet
fnt GC
gc Position
x Position
y WorkspaceId
text
#ifdef XFT
    Xft NonEmpty XftFont
fnts -> do
        forall a.
Display -> Pixel -> Visual -> Pixel -> (XftDraw -> IO a) -> IO a
withXftDraw Display
display Pixel
window Visual
visual Pixel
colormap forall a b. (a -> b) -> a -> b
$
            \XftDraw
ft_draw -> forall a.
Display
-> Visual -> Pixel -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue Display
display Visual
visual Pixel
colormap (Pixel -> XRenderColor
fromARGB Pixel
col) forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_X11_xft(0, 3, 4)
            \XftColor
ft_color -> XftDraw
-> XftColor -> [XftFont] -> Int -> Int -> WorkspaceId -> IO ()
xftDrawStringFallback XftDraw
ft_draw XftColor
ft_color (forall a. NonEmpty a -> [a]
NE.toList NonEmpty XftFont
fnts) (forall a b. (Integral a, Num b) => a -> b
fi Position
x) (forall a b. (Integral a, Num b) => a -> b
fi Position
y) WorkspaceId
text
#else
            \ft_color -> xftDrawString ft_draw ft_color (NE.head fnts) x y text
#endif

-- | 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)
    Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
r Int
g Int
b Int
a
#else
    -- swapped green/blue as a workaround for the faulty Storable instance in X11-xft < 0.3.3
    XRenderColor r b g a
#endif
  where
    r :: Int
r = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> Int -> a
shiftR Pixel
x Int
8
    g :: Int
g = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. Pixel
x
    b :: Int
b = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> Int -> a
shiftL Pixel
x Int
8
    a :: Int
a = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Pixel
0xff00 forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> Int -> a
shiftR Pixel
x Int
16
#endif