{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.GridSelect
-- Description :  Display items in a 2D grid and select from it with the keyboard or the mouse.
-- Copyright   :  Clemens Fruhwirth <clemens@endorphin.org>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Clemens Fruhwirth <clemens@endorphin.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- GridSelect displays items(e.g. the opened windows) in a 2D grid and lets
-- the user select from it with the cursor/hjkl keys or the mouse.
--
-----------------------------------------------------------------------------

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

    -- ** Customizing
    -- *** Using a common GSConfig
    -- $commonGSConfig

    -- *** Custom keybindings
    -- $keybindings

    -- * Configuration
    GSConfig(..),
    def,
    TwoDPosition,
    buildDefaultGSConfig,

    -- * Variations on 'gridselect'
    gridselect,
    gridselectWindow,
    withSelectedWindow,
    bringSelected,
    goToSelected,
    gridselectWorkspace,
    gridselectWorkspace',
    spawnSelected,
    runSelectedAction,

    -- * Colorizers
    HasColorizer(defaultColorizer),
    fromClassName,
    stringColorizer,
    colorRangeFromClassName,
    stringToRatio,

    -- * Navigation Mode assembly
    TwoD,
    makeXEventhandler,
    shadowWithKeymap,

    -- * Built-in Navigation Mode
    defaultNavigation,
    substringSearch,
    navNSearch,

    -- * Navigation Components
    setPos,
    move,
    moveNext, movePrev,
    select,
    cancel,
    transformSearchString,

    -- * Rearrangers
    -- $rearrangers
    Rearranger,
    noRearranger,
    searchStringRearrangerGenerator,

    -- * Screenshots
    -- $screenshots

    -- * Types
    TwoDState,
    ) where
import Control.Arrow ((***))
import Data.Bits
import Data.Ord (comparing)
import Control.Monad.State
import Data.List as L
import qualified Data.Map as M
import XMonad hiding (liftX)
import XMonad.Prelude
import XMonad.Util.Font
import XMonad.Prompt (mkUnmanagedWindow)
import XMonad.StackSet as W
import XMonad.Layout.Decoration
import XMonad.Util.NamedWindows
import XMonad.Actions.WindowBringer (bringWindow)
import Text.Printf
import System.Random (mkStdGen, randomR)
import Data.Word (Word8)
import qualified Data.List.NonEmpty as NE

-- $usage
--
-- You can use this module with the following in your @xmonad.hs@:
--
-- >    import XMonad.Actions.GridSelect
--
-- Then add a keybinding, e.g.
--
-- >    , ((modm, xK_g), goToSelected def)
--
-- This module also supports displaying arbitrary information in a grid and letting
-- the user select from it. E.g. to spawn an application from a given list, you
-- can use the following:
--
-- >   , ((modm, xK_s), spawnSelected def ["xterm","gmplayer","gvim"])

-- $commonGSConfig
--
-- It is possible to bind a @gsconfig@ at top-level in your configuration. Like so:
--
-- > -- the top of your config
-- > {-# LANGUAGE NoMonomorphismRestriction #-}
-- > import XMonad
-- > ...
-- > gsconfig1 = def { gs_cellheight = 30, gs_cellwidth = 100 }
--
-- An example where 'buildDefaultGSConfig' is used instead of 'def'
-- in order to specify a custom colorizer is @gsconfig2@ (found in
-- "XMonad.Actions.GridSelect#Colorizers"):
--
-- > gsconfig2 colorizer = (buildDefaultGSConfig colorizer) { gs_cellheight = 30, gs_cellwidth = 100 }
--
-- > -- | A green monochrome colorizer based on window class
-- > greenColorizer = colorRangeFromClassName
-- >                      black            -- lowest inactive bg
-- >                      (0x70,0xFF,0x70) -- highest inactive bg
-- >                      black            -- active bg
-- >                      white            -- inactive fg
-- >                      white            -- active fg
-- >   where black = minBound
-- >         white = maxBound
--
-- Then you can bind to:
--
-- >     ,((modm, xK_g), goToSelected $ gsconfig2 myWinColorizer)
-- >     ,((modm, xK_p), spawnSelected (gsconfig2 defaultColorizer) ["xterm","gvim"])

-- $keybindings
--
-- You can build you own navigation mode and submodes by combining the
-- exported action ingredients and assembling them using 'makeXEventhandler' and 'shadowWithKeymap'.
--
-- > myNavigation :: TwoD a (Maybe a)
-- > myNavigation = makeXEventhandler $ shadowWithKeymap navKeyMap navDefaultHandler
-- >  where navKeyMap = M.fromList [
-- >           ((0,xK_Escape), cancel)
-- >          ,((0,xK_Return), select)
-- >          ,((0,xK_slash) , substringSearch myNavigation)
-- >          ,((0,xK_Left)  , move (-1,0)  >> myNavigation)
-- >          ,((0,xK_h)     , move (-1,0)  >> myNavigation)
-- >          ,((0,xK_Right) , move (1,0)   >> myNavigation)
-- >          ,((0,xK_l)     , move (1,0)   >> myNavigation)
-- >          ,((0,xK_Down)  , move (0,1)   >> myNavigation)
-- >          ,((0,xK_j)     , move (0,1)   >> myNavigation)
-- >          ,((0,xK_Up)    , move (0,-1)  >> myNavigation)
-- >          ,((0,xK_y)     , move (-1,-1) >> myNavigation)
-- >          ,((0,xK_i)     , move (1,-1)  >> myNavigation)
-- >          ,((0,xK_n)     , move (-1,1)  >> myNavigation)
-- >          ,((0,xK_m)     , move (1,-1)  >> myNavigation)
-- >          ,((0,xK_space) , setPos (0,0) >> myNavigation)
-- >          ]
-- >        -- The navigation handler ignores unknown key symbols
-- >        navDefaultHandler = const myNavigation
--
-- You can then define @gsconfig3@ which may be used in exactly the same manner as @gsconfig1@:
--
-- > gsconfig3 = def
-- >    { gs_cellheight = 30
-- >    , gs_cellwidth = 100
-- >    , gs_navigate = myNavigation
-- >    }

-- $screenshots
--
-- Selecting a workspace:
--
-- <<http://haskell.org/wikiupload/a/a9/Xmonad-gridselect-workspace.png>>
--
-- Selecting a window by title:
--
-- <<http://haskell.org/wikiupload/3/35/Xmonad-gridselect-window-aavogt.png>>

-- | The 'Default' instance gives a basic configuration for 'gridselect', with
-- the colorizer chosen based on the type.
--
-- If you want to replace the 'gs_colorizer' field, use 'buildDefaultGSConfig'
-- instead of 'def' to avoid ambiguous type variables.
data GSConfig a = GSConfig {
      forall a. GSConfig a -> Integer
gs_cellheight :: Integer,
      forall a. GSConfig a -> Integer
gs_cellwidth :: Integer,
      forall a. GSConfig a -> Integer
gs_cellpadding :: Integer,
      forall a. GSConfig a -> a -> Bool -> X (String, String)
gs_colorizer :: a -> Bool -> X (String, String),
      forall a. GSConfig a -> String
gs_font :: String,
      forall a. GSConfig a -> TwoD a (Maybe a)
gs_navigate :: TwoD a (Maybe a),
      -- ^ Customize key bindings for a GridSelect
      forall a. GSConfig a -> Rearranger a
gs_rearranger :: Rearranger a,
      forall a. GSConfig a -> Double
gs_originFractX :: Double,
      forall a. GSConfig a -> Double
gs_originFractY :: Double,
      forall a. GSConfig a -> String
gs_bordercolor :: String,
      forall a. GSConfig a -> Bool
gs_cancelOnEmptyClick :: Bool
      -- ^ When True, click on empty space will cancel GridSelect
}

-- | That is 'fromClassName' if you are selecting a 'Window', or
-- 'defaultColorizer' if you are selecting a 'String'. The catch-all instance
-- @HasColorizer a@ uses the 'focusedBorderColor' and 'normalBorderColor'
-- colors.
class HasColorizer a where
    defaultColorizer :: a -> Bool -> X (String, String)

instance HasColorizer Window where
    defaultColorizer :: Word64 -> Bool -> X (String, String)
defaultColorizer = Word64 -> Bool -> X (String, String)
fromClassName

instance HasColorizer String where
    defaultColorizer :: String -> Bool -> X (String, String)
defaultColorizer = String -> Bool -> X (String, String)
stringColorizer

instance {-# OVERLAPPABLE #-} HasColorizer a where
    defaultColorizer :: a -> Bool -> X (String, String)
defaultColorizer a
_ Bool
isFg =
        let getColor :: XConfig l -> String
getColor = if Bool
isFg then forall (l :: * -> *). XConfig l -> String
focusedBorderColor else forall (l :: * -> *). XConfig l -> String
normalBorderColor
        in forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ (, String
"black") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *). XConfig l -> String
getColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config

instance HasColorizer a => Default (GSConfig a) where
    def :: GSConfig a
def = forall a. (a -> Bool -> X (String, String)) -> GSConfig a
buildDefaultGSConfig forall a. HasColorizer a => a -> Bool -> X (String, String)
defaultColorizer

type TwoDPosition = (Integer, Integer)

type TwoDElementMap a = [(TwoDPosition,(String,a))]

data TwoDState a = TwoDState { forall a. TwoDState a -> TwoDPosition
td_curpos :: TwoDPosition
                             , forall a. TwoDState a -> [TwoDPosition]
td_availSlots :: [TwoDPosition]
                             , forall a. TwoDState a -> [(String, a)]
td_elements :: [(String,a)]
                             , forall a. TwoDState a -> GSConfig a
td_gsconfig :: GSConfig a
                             , forall a. TwoDState a -> XMonadFont
td_font :: XMonadFont
                             , forall a. TwoDState a -> Integer
td_paneX :: Integer
                             , forall a. TwoDState a -> Integer
td_paneY :: Integer
                             , forall a. TwoDState a -> Word64
td_drawingWin :: Window
                             , forall a. TwoDState a -> String
td_searchString :: String
                             , forall a. TwoDState a -> TwoDElementMap a
td_elementmap :: TwoDElementMap a
                             }

generateElementmap :: TwoDState a -> X (TwoDElementMap a)
generateElementmap :: forall a. TwoDState a -> X (TwoDElementMap a)
generateElementmap TwoDState a
s = do
    [(String, a)]
rearrangedElements <- Rearranger a
rearranger String
searchString [(String, a)]
sortedElements
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [TwoDPosition]
positions [(String, a)]
rearrangedElements
  where
    TwoDState {td_availSlots :: forall a. TwoDState a -> [TwoDPosition]
td_availSlots = [TwoDPosition]
positions,
               td_gsconfig :: forall a. TwoDState a -> GSConfig a
td_gsconfig = GSConfig a
gsconfig,
               td_searchString :: forall a. TwoDState a -> String
td_searchString = String
searchString} = TwoDState a
s
    GSConfig {gs_rearranger :: forall a. GSConfig a -> Rearranger a
gs_rearranger = Rearranger a
rearranger} = GSConfig a
gsconfig
    -- Filter out any elements that don't contain the searchString (case insensitive)
    filteredElements :: [(String, a)]
filteredElements = forall a. (a -> Bool) -> [a] -> [a]
L.filter ((String
searchString String -> String -> Bool
`isInfixOfI`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall a. TwoDState a -> [(String, a)]
td_elements TwoDState a
s)
    -- Sorts the elementmap
    sortedElements :: [(String, a)]
sortedElements = forall a. String -> [(String, a)] -> [(String, a)]
orderElementmap String
searchString [(String, a)]
filteredElements
    -- Case Insensitive version of isInfixOf
    String
needle isInfixOfI :: String -> String -> Bool
`isInfixOfI` String
haystack = String -> String
upper String
needle forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String -> String
upper String
haystack
    upper :: String -> String
upper = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper


-- | We enforce an ordering such that we will always get the same result. If the
-- elements position changes from call to call of gridselect, then the shown
-- positions will also change when you search for the same string. This is
-- especially the case when using gridselect for showing and switching between
-- workspaces, as workspaces are usually shown in order of last visited.  The
-- chosen ordering is "how deep in the haystack the needle is" (number of
-- characters from the beginning of the string and the needle).
orderElementmap :: String  -> [(String,a)] -> [(String,a)]
orderElementmap :: forall a. String -> [(String, a)] -> [(String, a)]
orderElementmap String
searchString [(String, a)]
elements = if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
searchString then [(String, a)]
sortedElements else [(String, a)]
elements
  where
    upper :: String -> String
upper = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper
    -- Calculates a (score, element) tuple where the score is the depth of the (case insensitive) needle.
    calcScore :: (String, b) -> (Int, (String, b))
calcScore (String, b)
element = ( forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String
upper String
searchString)) (forall a. [a] -> [[a]]
tails forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
upper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (String, b)
element)
                        , (String, b)
element)
    -- Use the score and then the string as the parameters for comparing, making
    -- it consistent even when two strings that score the same, as it will then be
    -- sorted by the strings, making it consistent.
    compareScore :: (Int, (String, b)) -> (Int, (String, b)) -> Ordering
compareScore = forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Int
score, (String
str,b
_)) -> (Int
score, String
str))
    sortedElements :: [(String, a)]
sortedElements = 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 a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {b}. (Int, (String, b)) -> (Int, (String, b)) -> Ordering
compareScore forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (String, b) -> (Int, (String, b))
calcScore [(String, a)]
elements


newtype TwoD a b = TwoD { forall a b. TwoD a b -> StateT (TwoDState a) X b
unTwoD :: StateT (TwoDState a) X b }
    deriving (forall a b. a -> TwoD a b -> TwoD a a
forall a b. (a -> b) -> TwoD a a -> TwoD a b
forall a a b. a -> TwoD a b -> TwoD a a
forall a a b. (a -> b) -> TwoD a a -> TwoD 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 -> TwoD a b -> TwoD a a
$c<$ :: forall a a b. a -> TwoD a b -> TwoD a a
fmap :: forall a b. (a -> b) -> TwoD a a -> TwoD a b
$cfmap :: forall a a b. (a -> b) -> TwoD a a -> TwoD a b
Functor, forall a. Functor (TwoD a)
forall a. a -> TwoD a a
forall a a. a -> TwoD a a
forall a b. TwoD a a -> TwoD a b -> TwoD a a
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
forall a a b. TwoD a a -> TwoD a b -> TwoD a a
forall a a b. TwoD a a -> TwoD a b -> TwoD a b
forall a a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
forall a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
forall a a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD 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. TwoD a a -> TwoD a b -> TwoD a a
$c<* :: forall a a b. TwoD a a -> TwoD a b -> TwoD a a
*> :: forall a b. TwoD a a -> TwoD a b -> TwoD a b
$c*> :: forall a a b. TwoD a a -> TwoD a b -> TwoD a b
liftA2 :: forall a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
$cliftA2 :: forall a a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
<*> :: forall a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
$c<*> :: forall a a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
pure :: forall a. a -> TwoD a a
$cpure :: forall a a. a -> TwoD a a
Applicative, forall a. Applicative (TwoD a)
forall a. a -> TwoD a a
forall a a. a -> TwoD a a
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
forall a a b. TwoD a a -> TwoD a b -> TwoD a b
forall a a b. TwoD a a -> (a -> TwoD a b) -> TwoD 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 -> TwoD a a
$creturn :: forall a a. a -> TwoD a a
>> :: forall a b. TwoD a a -> TwoD a b -> TwoD a b
$c>> :: forall a a b. TwoD a a -> TwoD a b -> TwoD a b
>>= :: forall a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
$c>>= :: forall a a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
Monad, MonadState (TwoDState a))

liftX ::  X a1 -> TwoD a a1
liftX :: forall a1 a. X a1 -> TwoD a a1
liftX = forall a b. StateT (TwoDState a) X b -> TwoD a b
TwoD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

evalTwoD ::  TwoD a1 a -> TwoDState a1 -> X a
evalTwoD :: forall a1 a. TwoD a1 a -> TwoDState a1 -> X a
evalTwoD TwoD a1 a
m TwoDState a1
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT TwoDState a1
s forall a b. (a -> b) -> a -> b
$ forall a b. TwoD a b -> StateT (TwoDState a) X b
unTwoD TwoD a1 a
m

diamondLayer :: (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer :: forall a. (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer a
0 = [(a
0,a
0)]
diamondLayer a
n =
  -- tr = top right
  --  r = ur ++ 90 degree clock-wise rotation of ur
  let tr :: [(a, a)]
tr = [ (a
x,a
nforall a. Num a => a -> a -> a
-a
x) | a
x <- [a
0..a
nforall a. Num a => a -> a -> a
-a
1] ]
      r :: [(a, a)]
r  = [(a, a)]
tr forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\(a
x,a
y) -> (a
y,-a
x)) [(a, a)]
tr
  in [(a, a)]
r forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a
negate forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. Num a => a -> a
negate) [(a, a)]
r

diamond :: (Enum a, Num a, Eq a) => Stream (a, a)
diamond :: forall a. (Enum a, Num a, Eq a) => Stream (a, a)
diamond = forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer [a
0..]

diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [(Integer, Integer)]
diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [TwoDPosition]
diamondRestrict Integer
x Integer
y Integer
originX Integer
originY =
  forall a. (a -> Bool) -> [a] -> [a]
L.filter (\(Integer
x',Integer
y') -> forall a. Num a => a -> a
abs Integer
x' forall a. Ord a => a -> a -> Bool
<= Integer
x Bool -> Bool -> Bool
&& forall a. Num a => a -> a
abs Integer
y' forall a. Ord a => a -> a -> Bool
<= Integer
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
x', Integer
y') -> (Integer
x' forall a. Num a => a -> a -> a
+ forall a. Num a => Integer -> a
fromInteger Integer
originX, Integer
y' forall a. Num a => a -> a -> a
+ forall a. Num a => Integer -> a
fromInteger Integer
originY)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a. Int -> Stream a -> [a]
takeS Int
1000 forall a b. (a -> b) -> a -> b
$ forall a. (Enum a, Num a, Eq a) => Stream (a, a)
diamond

findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)
findInElementMap :: forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap a
pos = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== a
pos) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

drawWinBox :: Window -> XMonadFont -> (String, String) -> String -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()
drawWinBox :: Word64
-> XMonadFont
-> (String, String)
-> String
-> Integer
-> Integer
-> String
-> Integer
-> Integer
-> Integer
-> X ()
drawWinBox Word64
win XMonadFont
font (String
fg,String
bg) String
bc Integer
ch Integer
cw String
text Integer
x Integer
y Integer
cp =
  forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  GC
gc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> IO GC
createGC Display
dpy Word64
win
  GC
bordergc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> IO GC
createGC Display
dpy Word64
win
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Just Word64
fgcolor <- Display -> String -> IO (Maybe Word64)
initColor Display
dpy String
fg
    Just Word64
bgcolor <- Display -> String -> IO (Maybe Word64)
initColor Display
dpy String
bg
    Just Word64
bordercolor <- Display -> String -> IO (Maybe Word64)
initColor Display
dpy String
bc
    Display -> GC -> Word64 -> IO ()
setForeground Display
dpy GC
gc Word64
fgcolor
    Display -> GC -> Word64 -> IO ()
setBackground Display
dpy GC
gc Word64
bgcolor
    Display -> GC -> Word64 -> IO ()
setForeground Display
dpy GC
bordergc Word64
bordercolor
    Display
-> Word64
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
dpy Word64
win GC
gc (forall a. Num a => Integer -> a
fromInteger Integer
x) (forall a. Num a => Integer -> a
fromInteger Integer
y) (forall a. Num a => Integer -> a
fromInteger Integer
cw) (forall a. Num a => Integer -> a
fromInteger Integer
ch)
    Display
-> Word64
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
drawRectangle Display
dpy Word64
win GC
bordergc (forall a. Num a => Integer -> a
fromInteger Integer
x) (forall a. Num a => Integer -> a
fromInteger Integer
y) (forall a. Num a => Integer -> a
fromInteger Integer
cw) (forall a. Num a => Integer -> a
fromInteger Integer
ch)
  String
stext <- (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile (forall s. Shrinker s => s -> String -> [String]
shrinkIt DefaultShrinker
shrinkText)
           (\String
n -> do Int
size <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
font String
n
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
size forall a. Ord a => a -> a -> Bool
> forall a. Num a => Integer -> a
fromInteger (Integer
cwforall a. Num a => a -> a -> a
-(Integer
2forall a. Num a => a -> a -> a
*Integer
cp)))
           String
text
  -- calculate the offset to vertically centre the text based on the ascender and descender
  (Position
asc,Position
desc) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
font String
stext
  let offset :: Integer
offset = ((Integer
ch forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position
asc forall a. Num a => a -> a -> a
+ Position
desc)) forall a. Integral a => a -> a -> a
`div` Integer
2) forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
asc
  forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Word64
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
dpy Word64
win XMonadFont
font GC
gc String
bg String
fg (forall a. Num a => Integer -> a
fromInteger (Integer
xforall a. Num a => a -> a -> a
+Integer
cp)) (forall a. Num a => Integer -> a
fromInteger (Integer
yforall a. Num a => a -> a -> a
+Integer
offset)) String
stext
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC Display
dpy GC
gc
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC Display
dpy GC
bordergc

updateAllElements :: TwoD a ()
updateAllElements :: forall a. TwoD a ()
updateAllElements =
    do
      TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
      forall a. TwoDElementMap a -> TwoD a ()
updateElements (forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)

grayoutElements :: Int -> TwoD a ()
grayoutElements :: forall a. Int -> TwoD a ()
grayoutElements Int
skip =
    do
      TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
      forall a.
(a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer forall {m :: * -> *} {p} {p}.
Monad m =>
p -> p -> m (String, String)
grayOnly forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
skip (forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)
    where grayOnly :: p -> p -> m (String, String)
grayOnly p
_ p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#808080", String
"#808080")

updateElements :: TwoDElementMap a -> TwoD a ()
updateElements :: forall a. TwoDElementMap a -> TwoD a ()
updateElements TwoDElementMap a
elementmap = do
      TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
      forall a.
(a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer (forall a. GSConfig a -> a -> Bool -> X (String, String)
gs_colorizer (forall a. TwoDState a -> GSConfig a
td_gsconfig TwoDState a
s)) TwoDElementMap a
elementmap

updateElementsWithColorizer :: (a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer :: forall a.
(a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer a -> Bool -> X (String, String)
colorizer TwoDElementMap a
elementmap = do
    TwoDState { td_curpos :: forall a. TwoDState a -> TwoDPosition
td_curpos = TwoDPosition
curpos,
                td_drawingWin :: forall a. TwoDState a -> Word64
td_drawingWin = Word64
win,
                td_gsconfig :: forall a. TwoDState a -> GSConfig a
td_gsconfig = GSConfig a
gsconfig,
                td_font :: forall a. TwoDState a -> XMonadFont
td_font = XMonadFont
font,
                td_paneX :: forall a. TwoDState a -> Integer
td_paneX = Integer
paneX,
                td_paneY :: forall a. TwoDState a -> Integer
td_paneY = Integer
paneY} <- forall s (m :: * -> *). MonadState s m => m s
get
    let cellwidth :: Integer
cellwidth = forall a. GSConfig a -> Integer
gs_cellwidth GSConfig a
gsconfig
        cellheight :: Integer
cellheight = forall a. GSConfig a -> Integer
gs_cellheight GSConfig a
gsconfig
        paneX' :: Integer
paneX' = forall a. Integral a => a -> a -> a
div (Integer
paneXforall a. Num a => a -> a -> a
-Integer
cellwidth) Integer
2
        paneY' :: Integer
paneY' = forall a. Integral a => a -> a -> a
div (Integer
paneYforall a. Num a => a -> a -> a
-Integer
cellheight) Integer
2
        updateElement :: (TwoDPosition, (String, a)) -> TwoD a ()
updateElement (pos :: TwoDPosition
pos@(Integer
x,Integer
y),(String
text, a
element)) = forall a1 a. X a1 -> TwoD a a1
liftX forall a b. (a -> b) -> a -> b
$ do
            (String, String)
colors <- a -> Bool -> X (String, String)
colorizer a
element (TwoDPosition
pos forall a. Eq a => a -> a -> Bool
== TwoDPosition
curpos)
            Word64
-> XMonadFont
-> (String, String)
-> String
-> Integer
-> Integer
-> String
-> Integer
-> Integer
-> Integer
-> X ()
drawWinBox Word64
win XMonadFont
font
                       (String, String)
colors
                       (forall a. GSConfig a -> String
gs_bordercolor GSConfig a
gsconfig)
                       Integer
cellheight
                       Integer
cellwidth
                       String
text
                       (Integer
paneX'forall a. Num a => a -> a -> a
+Integer
xforall a. Num a => a -> a -> a
*Integer
cellwidth)
                       (Integer
paneY'forall a. Num a => a -> a -> a
+Integer
yforall a. Num a => a -> a -> a
*Integer
cellheight)
                       (forall a. GSConfig a -> Integer
gs_cellpadding GSConfig a
gsconfig)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. (TwoDPosition, (String, a)) -> TwoD a ()
updateElement TwoDElementMap a
elementmap

stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
stdHandle :: forall a. Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
stdHandle ButtonEvent{ ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_x :: Event -> CInt
ev_x = CInt
x, ev_y :: Event -> CInt
ev_y = CInt
y } TwoD a (Maybe a)
contEventloop
    | Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
buttonRelease = do
        s :: TwoDState a
s@TwoDState{ td_paneX :: forall a. TwoDState a -> Integer
td_paneX = Integer
px
                   , td_paneY :: forall a. TwoDState a -> Integer
td_paneY = Integer
py
                   , td_gsconfig :: forall a. TwoDState a -> GSConfig a
td_gsconfig = GSConfig{ gs_cellheight :: forall a. GSConfig a -> Integer
gs_cellheight = Integer
ch
                                           , gs_cellwidth :: forall a. GSConfig a -> Integer
gs_cellwidth = Integer
cw
                                           , gs_cancelOnEmptyClick :: forall a. GSConfig a -> Bool
gs_cancelOnEmptyClick = Bool
cancelOnEmptyClick
                                           }
                   } <- forall s (m :: * -> *). MonadState s m => m s
get
        let gridX :: Integer
gridX = (forall a b. (Integral a, Num b) => a -> b
fi CInt
x forall a. Num a => a -> a -> a
- (Integer
px forall a. Num a => a -> a -> a
- Integer
cw) forall a. Integral a => a -> a -> a
`div` Integer
2) forall a. Integral a => a -> a -> a
`div` Integer
cw
            gridY :: Integer
gridY = (forall a b. (Integral a, Num b) => a -> b
fi CInt
y forall a. Num a => a -> a -> a
- (Integer
py forall a. Num a => a -> a -> a
- Integer
ch) forall a. Integral a => a -> a -> a
`div` Integer
2) forall a. Integral a => a -> a -> a
`div` Integer
ch
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Integer
gridX,Integer
gridY) (forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s) of
             Just (String
_,a
el) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
el)
             Maybe (String, a)
Nothing     -> if Bool
cancelOnEmptyClick
                            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                            else TwoD a (Maybe a)
contEventloop
    | Bool
otherwise = TwoD a (Maybe a)
contEventloop

stdHandle ExposeEvent{} TwoD a (Maybe a)
contEventloop = forall a. TwoD a ()
updateAllElements forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
contEventloop

stdHandle Event
_ TwoD a (Maybe a)
contEventloop = TwoD a (Maybe a)
contEventloop

-- | Embeds a key handler into the X event handler that dispatches key
-- events to the key handler, while non-key event go to the standard
-- handler.
makeXEventhandler :: ((KeySym, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler :: forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (Word64, String, KeyMask) -> TwoD a (Maybe a)
keyhandler = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \TwoD a (Maybe a)
me -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a1 a. X a1 -> TwoD a a1
liftX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
                             Display -> Word64 -> XEventPtr -> IO ()
maskEvent Display
d (Word64
exposureMask forall a. Bits a => a -> a -> a
.|. Word64
keyPressMask forall a. Bits a => a -> a -> a
.|. Word64
buttonReleaseMask) 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
                               then do
                                  (Maybe Word64
_, String
s) <- XKeyEventPtr -> IO (Maybe Word64, String)
lookupString forall a b. (a -> b) -> a -> b
$ XEventPtr -> XKeyEventPtr
asKeyEvent XEventPtr
e
                                  Word64
ks <- Display -> Word8 -> CInt -> IO Word64
keycodeToKeysym Display
d (Event -> Word8
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 a1 a. X a1 -> TwoD a a1
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)
                                      (Word64, String, KeyMask) -> TwoD a (Maybe a)
keyhandler (Word64
ks, String
s, KeyMask
mask)
                               else
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
stdHandle Event
ev TwoD a (Maybe a)
me

-- | When the map contains (KeySym,KeyMask) tuple for the given event,
-- the associated action in the map associated shadows the default key
-- handler
shadowWithKeymap :: M.Map (KeyMask, KeySym) a -> ((KeySym, String, KeyMask) -> a) -> (KeySym, String, KeyMask) -> a
shadowWithKeymap :: forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) a
keymap (Word64, String, KeyMask) -> a
dflt keyEvent :: (Word64, String, KeyMask)
keyEvent@(Word64
ks,String
_,KeyMask
m') = forall a. a -> Maybe a -> a
fromMaybe ((Word64, String, KeyMask) -> a
dflt (Word64, String, KeyMask)
keyEvent) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
m',Word64
ks) Map (KeyMask, Word64) a
keymap)

-- Helper functions to use for key handler functions

-- | Closes gridselect returning the element under the cursor
select :: TwoD a (Maybe a)
select :: forall a. TwoD a (Maybe a)
select = do
  TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap (forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s) (forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)

-- | Closes gridselect returning no element.
cancel :: TwoD a (Maybe a)
cancel :: forall a. TwoD a (Maybe a)
cancel = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Sets the absolute position of the cursor.
setPos :: (Integer, Integer) -> TwoD a ()
setPos :: forall a. TwoDPosition -> TwoD a ()
setPos TwoDPosition
newPos = do
  TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
  let elmap :: TwoDElementMap a
elmap = forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
      newSelectedEl :: Maybe (TwoDPosition, (String, a))
newSelectedEl = forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap TwoDPosition
newPos (forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)
      oldPos :: TwoDPosition
oldPos = forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (TwoDPosition, (String, a))
newSelectedEl Bool -> Bool -> Bool
&& TwoDPosition
newPos forall a. Eq a => a -> a -> Bool
/= TwoDPosition
oldPos) forall a b. (a -> b) -> a -> b
$ do
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TwoDState a
s { td_curpos :: TwoDPosition
td_curpos = TwoDPosition
newPos }
    forall a. TwoDElementMap a -> TwoD a ()
updateElements (forall a. [Maybe a] -> [a]
catMaybes [forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap TwoDPosition
oldPos TwoDElementMap a
elmap, Maybe (TwoDPosition, (String, a))
newSelectedEl])

-- | Moves the cursor by the offsets specified
move :: (Integer, Integer) -> TwoD a ()
move :: forall a. TwoDPosition -> TwoD a ()
move (Integer
dx,Integer
dy) = do
  TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
  let (Integer
x,Integer
y) = forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s
      newPos :: TwoDPosition
newPos = (Integer
xforall a. Num a => a -> a -> a
+Integer
dx,Integer
yforall a. Num a => a -> a -> a
+Integer
dy)
  forall a. TwoDPosition -> TwoD a ()
setPos TwoDPosition
newPos

moveNext :: TwoD a ()
moveNext :: forall a. TwoD a ()
moveNext = do
  TwoDPosition
position <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TwoDState a -> TwoDPosition
td_curpos
  TwoDElementMap a
elems <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TwoDState a -> TwoDElementMap a
td_elementmap
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
      m :: Maybe Int
m = case forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(TwoDPosition, (String, a))
p -> forall a b. (a, b) -> a
fst (TwoDPosition, (String, a))
p forall a. Eq a => a -> a -> Bool
== TwoDPosition
position) TwoDElementMap a
elems of
               Maybe Int
Nothing -> forall a. Maybe a
Nothing
               Just Int
k | Int
k forall a. Eq a => a -> a -> Bool
== Int
nforall a. Num a => a -> a -> a
-Int
1 -> forall a. a -> Maybe a
Just Int
0
                      | Bool
otherwise -> forall a. a -> Maybe a
Just (Int
kforall a. Num a => a -> a -> a
+Int
1)
  forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
m forall a b. (a -> b) -> a -> b
$ \Int
i ->
      forall a. TwoDPosition -> TwoD a ()
setPos (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ TwoDElementMap a
elems forall a. [a] -> Int -> a
!! Int
i)

movePrev :: TwoD a ()
movePrev :: forall a. TwoD a ()
movePrev = do
  TwoDPosition
position <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TwoDState a -> TwoDPosition
td_curpos
  TwoDElementMap a
elems <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. TwoDState a -> TwoDElementMap a
td_elementmap
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
      m :: Maybe Int
m = case forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(TwoDPosition, (String, a))
p -> forall a b. (a, b) -> a
fst (TwoDPosition, (String, a))
p forall a. Eq a => a -> a -> Bool
== TwoDPosition
position) TwoDElementMap a
elems of
               Maybe Int
Nothing -> forall a. Maybe a
Nothing
               Just Int
0  -> forall a. a -> Maybe a
Just (Int
nforall a. Num a => a -> a -> a
-Int
1)
               Just Int
k  -> forall a. a -> Maybe a
Just (Int
kforall a. Num a => a -> a -> a
-Int
1)
  forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
m forall a b. (a -> b) -> a -> b
$ \Int
i ->
      forall a. TwoDPosition -> TwoD a ()
setPos (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ TwoDElementMap a
elems forall a. [a] -> Int -> a
!! Int
i)

-- | Apply a transformation function the current search string
transformSearchString :: (String -> String) -> TwoD a ()
transformSearchString :: forall a. (String -> String) -> TwoD a ()
transformSearchString String -> String
f = do
          TwoDState a
s <- forall s (m :: * -> *). MonadState s m => m s
get
          let oldSearchString :: String
oldSearchString = forall a. TwoDState a -> String
td_searchString TwoDState a
s
              newSearchString :: String
newSearchString = String -> String
f String
oldSearchString
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
newSearchString forall a. Eq a => a -> a -> Bool
/= String
oldSearchString) forall a b. (a -> b) -> a -> b
$ do
            -- FIXME curpos might end up outside new bounds
            let s' :: TwoDState a
s' = TwoDState a
s { td_searchString :: String
td_searchString = String
newSearchString }
            TwoDElementMap a
m <- forall a1 a. X a1 -> TwoD a a1
liftX forall a b. (a -> b) -> a -> b
$ forall a. TwoDState a -> X (TwoDElementMap a)
generateElementmap TwoDState a
s'
            let s'' :: TwoDState a
s'' = TwoDState a
s' { td_elementmap :: TwoDElementMap a
td_elementmap = TwoDElementMap a
m }
                oldLen :: Int
oldLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
                newLen :: Int
newLen = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s''
            -- All the elements in the previous element map should be
            -- grayed out, except for those which will be covered by
            -- elements in the new element map.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newLen forall a. Ord a => a -> a -> Bool
< Int
oldLen) forall a b. (a -> b) -> a -> b
$ forall a. Int -> TwoD a ()
grayoutElements Int
newLen
            forall s (m :: * -> *). MonadState s m => s -> m ()
put TwoDState a
s''
            forall a. TwoD a ()
updateAllElements

-- | By default gridselect used the defaultNavigation action, which
-- binds left,right,up,down and vi-style h,l,j,k navigation. Return
-- quits gridselect, returning the selected element, while Escape
-- cancels the selection. Slash enters the substring search mode. In
-- substring search mode, every string-associated keystroke is
-- added to a search string, which narrows down the object
-- selection. Substring search mode comes back to regular navigation
-- via Return, while Escape cancels the search. If you want that
-- navigation style, add 'defaultNavigation' as 'gs_navigate' to your
-- 'GSConfig' object. This is done by 'buildDefaultGSConfig' automatically.
defaultNavigation :: TwoD a (Maybe a)
defaultNavigation :: forall a. TwoD a (Maybe a)
defaultNavigation = forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler forall a b. (a -> b) -> a -> b
$ forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap forall {a}. Map (KeyMask, Word64) (TwoD a (Maybe a))
navKeyMap forall {b} {a}. b -> TwoD a (Maybe a)
navDefaultHandler
  where navKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
navKeyMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Word64
xK_Escape)     , forall a. TwoD a (Maybe a)
cancel)
          ,((KeyMask
0,Word64
xK_Return)     , forall a. TwoD a (Maybe a)
select)
          ,((KeyMask
0,Word64
xK_slash)      , forall a. TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Left)       , forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_h)          , forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Right)      , forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_l)          , forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Down)       , forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_j)          , forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Up)         , forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_k)          , forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Tab)        , forall a. TwoD a ()
moveNext forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_n)          , forall a. TwoD a ()
moveNext forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
shiftMask,Word64
xK_Tab), forall a. TwoD a ()
movePrev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_p)          , forall a. TwoD a ()
movePrev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
defaultNavigation)
          ]
        -- The navigation handler ignores unknown key symbols, therefore we const
        navDefaultHandler :: b -> TwoD a (Maybe a)
navDefaultHandler = forall a b. a -> b -> a
const forall a. TwoD a (Maybe a)
defaultNavigation

-- | This navigation style combines navigation and search into one mode at the cost of losing vi style
-- navigation. With this style, there is no substring search submode,
-- but every typed character is added to the substring search.
navNSearch :: TwoD a (Maybe a)
navNSearch :: forall a. TwoD a (Maybe a)
navNSearch = forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler forall a b. (a -> b) -> a -> b
$ forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap forall {a}. Map (KeyMask, Word64) (TwoD a (Maybe a))
navNSearchKeyMap forall {a} {c} {a}. (a, String, c) -> TwoD a (Maybe a)
navNSearchDefaultHandler
  where navNSearchKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
navNSearchKeyMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Word64
xK_Escape)     , forall a. TwoD a (Maybe a)
cancel)
          ,((KeyMask
0,Word64
xK_Return)     , forall a. TwoD a (Maybe a)
select)
          ,((KeyMask
0,Word64
xK_Left)       , forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Right)      , forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Down)       , forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Up)         , forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Tab)        , forall a. TwoD a ()
moveNext forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
shiftMask,Word64
xK_Tab), forall a. TwoD a ()
movePrev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_BackSpace), forall a. (String -> String) -> TwoD a ()
transformSearchString (\String
s -> if String
s forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else forall a. [a] -> [a]
init String
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. TwoD a (Maybe a)
navNSearch)
          ]
        -- The navigation handler ignores unknown key symbols, therefore we const
        navNSearchDefaultHandler :: (a, String, c) -> TwoD a (Maybe a)
navNSearchDefaultHandler (a
_,String
s,c
_) = do
          forall a. (String -> String) -> TwoD a ()
transformSearchString (forall a. [a] -> [a] -> [a]
++ String
s)
          forall a. TwoD a (Maybe a)
navNSearch

-- | Navigation submode used for substring search. It returns to the
-- first argument navigation style when the user hits Return.
substringSearch :: TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch :: forall a. TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch TwoD a (Maybe a)
returnNavigation = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \TwoD a (Maybe a)
me ->
  let searchKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
searchKeyMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Word64
xK_Escape)   , forall a. (String -> String) -> TwoD a ()
transformSearchString (forall a b. a -> b -> a
const String
"") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
returnNavigation)
          ,((KeyMask
0,Word64
xK_Return)   , TwoD a (Maybe a)
returnNavigation)
          ,((KeyMask
0,Word64
xK_BackSpace), forall a. (String -> String) -> TwoD a ()
transformSearchString (\String
s -> if String
s forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else forall a. [a] -> [a]
init String
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
me)
          ]
      searchDefaultHandler :: (a, String, c) -> TwoD a (Maybe a)
searchDefaultHandler (a
_,String
s,c
_) = do
          forall a. (String -> String) -> TwoD a ()
transformSearchString (forall a. [a] -> [a] -> [a]
++ String
s)
          TwoD a (Maybe a)
me
  in forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler forall a b. (a -> b) -> a -> b
$ forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
searchKeyMap forall {a} {c}. (a, String, c) -> TwoD a (Maybe a)
searchDefaultHandler


-- FIXME probably move that into Utils?
-- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space
hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a)
hsv2rgb :: forall a. Fractional a => (Integer, a, a) -> (a, a, a)
hsv2rgb (Integer
h,a
s,a
v) =
    let hi :: Integer
hi = forall a. Integral a => a -> a -> a
div Integer
h Integer
60 forall a. Integral a => a -> a -> a
`mod` Integer
6 :: Integer
        f :: a
f = ((forall a. Num a => Integer -> a
fromInteger Integer
hforall a. Fractional a => a -> a -> a
/a
60) forall a. Num a => a -> a -> a
- forall a. Num a => Integer -> a
fromInteger Integer
hi) :: Fractional a => a
        q :: a
q = a
v forall a. Num a => a -> a -> a
* (a
1forall a. Num a => a -> a -> a
-a
f)
        p :: a
p = a
v forall a. Num a => a -> a -> a
* (a
1forall a. Num a => a -> a -> a
-a
s)
        t :: a
t = a
v forall a. Num a => a -> a -> a
* (a
1forall a. Num a => a -> a -> a
-(a
1forall a. Num a => a -> a -> a
-a
f)forall a. Num a => a -> a -> a
*a
s)
    in case Integer
hi of
         Integer
0 -> (a
v,a
t,a
p)
         Integer
1 -> (a
q,a
v,a
p)
         Integer
2 -> (a
p,a
v,a
t)
         Integer
3 -> (a
p,a
q,a
v)
         Integer
4 -> (a
t,a
p,a
v)
         Integer
5 -> (a
v,a
p,a
q)
         Integer
_ -> forall a. HasCallStack => String -> a
error String
"The world is ending. x mod a >= a."

-- | Default colorizer for Strings
stringColorizer :: String -> Bool -> X (String, String)
stringColorizer :: String -> Bool -> X (String, String)
stringColorizer String
s Bool
active =
    let seed :: Int -> Integer
seed Int
x = forall a. Integral a => a -> Integer
toInteger (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
*Int
x)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Enum a => a -> Int
fromEnum) String
s) :: Integer
        (Double
r,Double
g,Double
b) = forall a. Fractional a => (Integer, a, a) -> (a, a, a)
hsv2rgb (Int -> Integer
seed Int
83 forall a. Integral a => a -> a -> a
`mod` Integer
360,
                           forall a. Num a => Integer -> a
fromInteger (Int -> Integer
seed Int
191 forall a. Integral a => a -> a -> a
`mod` Integer
1000)forall a. Fractional a => a -> a -> a
/Double
2500forall a. Num a => a -> a -> a
+Double
0.4,
                           forall a. Num a => Integer -> a
fromInteger (Int -> Integer
seed Int
121 forall a. Integral a => a -> a -> a
`mod` Integer
1000)forall a. Fractional a => a -> a -> a
/Double
2500forall a. Num a => a -> a -> a
+Double
0.4)
    in if Bool
active
         then forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#faff69", String
"black")
         else forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Word8 -> String
twodigitHexforall b c a. (b -> c) -> (a -> b) -> a -> c
.(forall a b. (RealFrac a, Integral b) => a -> b
round :: Double -> Word8)forall b c a. (b -> c) -> (a -> b) -> a -> c
.(forall a. Num a => a -> a -> a
*Double
256)) [Double
r, Double
g, Double
b], String
"white")

-- | Colorize a window depending on it's className.
fromClassName :: Window -> Bool -> X (String, String)
fromClassName :: Word64 -> Bool -> X (String, String)
fromClassName Word64
w Bool
active = forall a. Query a -> Word64 -> X a
runQuery Query String
className Word64
w forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. HasColorizer a => a -> Bool -> X (String, String)
defaultColorizer Bool
active

twodigitHex :: Word8 -> String
twodigitHex :: Word8 -> String
twodigitHex = forall r. PrintfType r => String -> r
printf String
"%02x"

-- | A colorizer that picks a color inside a range,
-- and depending on the window's class.
colorRangeFromClassName :: (Word8, Word8, Word8) -- ^ Beginning of the color range
                        -> (Word8, Word8, Word8) -- ^ End of the color range
                        -> (Word8, Word8, Word8) -- ^ Background of the active window
                        -> (Word8, Word8, Word8) -- ^ Inactive text color
                        -> (Word8, Word8, Word8) -- ^ Active text color
                        -> Window -> Bool -> X (String, String)
colorRangeFromClassName :: (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> Word64
-> Bool
-> X (String, String)
colorRangeFromClassName (Word8, Word8, Word8)
startC (Word8, Word8, Word8)
endC (Word8, Word8, Word8)
activeC (Word8, Word8, Word8)
inactiveT (Word8, Word8, Word8)
activeT Word64
w Bool
active =
    do String
classname <- forall a. Query a -> Word64 -> X a
runQuery Query String
className Word64
w
       if Bool
active
         then forall (m :: * -> *) a. Monad m => a -> m a
return ((Word8, Word8, Word8) -> String
rgbToHex (Word8, Word8, Word8)
activeC, (Word8, Word8, Word8) -> String
rgbToHex (Word8, Word8, Word8)
activeT)
         else forall (m :: * -> *) a. Monad m => a -> m a
return ((Word8, Word8, Word8) -> String
rgbToHex forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8)
-> (Word8, Word8, Word8) -> Double -> (Word8, Word8, Word8)
mix (Word8, Word8, Word8)
startC (Word8, Word8, Word8)
endC
                  forall a b. (a -> b) -> a -> b
$ String -> Double
stringToRatio String
classname, (Word8, Word8, Word8) -> String
rgbToHex (Word8, Word8, Word8)
inactiveT)
    where rgbToHex :: (Word8, Word8, Word8) -> String
          rgbToHex :: (Word8, Word8, Word8) -> String
rgbToHex (Word8
r, Word8
g, Word8
b) = Char
'#'forall a. a -> [a] -> [a]
:Word8 -> String
twodigitHex Word8
r
                               forall a. [a] -> [a] -> [a]
++Word8 -> String
twodigitHex Word8
gforall a. [a] -> [a] -> [a]
++Word8 -> String
twodigitHex Word8
b

-- | Creates a mix of two colors according to a ratio
-- (1 -> first color, 0 -> second color).
mix :: (Word8, Word8, Word8) -> (Word8, Word8, Word8)
        -> Double -> (Word8, Word8, Word8)
mix :: (Word8, Word8, Word8)
-> (Word8, Word8, Word8) -> Double -> (Word8, Word8, Word8)
mix (Word8
r1, Word8
g1, Word8
b1) (Word8
r2, Word8
g2, Word8
b2) Double
r = (forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
r1 Word8
r2, forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
g1 Word8
g2, forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
b1 Word8
b2)
    where  mix' :: a -> a -> b
mix' a
a a
b = forall a b. (RealFrac a, Integral b) => a -> b
truncate forall a b. (a -> b) -> a -> b
$ (forall a b. (Integral a, Num b) => a -> b
fi a
a forall a. Num a => a -> a -> a
* Double
r) forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fi a
b forall a. Num a => a -> a -> a
* (Double
1 forall a. Num a => a -> a -> a
- Double
r))

-- | Generates a Double from a string, trying to
-- achieve a random distribution.
-- We create a random seed from the hash of all characters
-- in the string, and use it to generate a ratio between 0 and 1
stringToRatio :: String -> Double
stringToRatio :: String -> Double
stringToRatio String
"" = Double
0
stringToRatio String
s = let gen :: StdGen
gen = Int -> StdGen
mkStdGen forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
t Char
c -> Int
t forall a. Num a => a -> a -> a
* Int
31 forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum Char
c) Int
0 String
s
                  in forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Double
0, Double
1) StdGen
gen

-- | Brings up a 2D grid of elements in the center of the screen, and one can
-- select an element with cursors keys. The selected element is returned.
gridselect :: GSConfig a -> [(String,a)] -> X (Maybe a)
gridselect :: forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig a
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
gridselect GSConfig a
gsconfig [(String, a)]
elements =
 forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Word64
rootw <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Word64
theRoot
    Rectangle
scr <- 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
    Word64
win <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display
-> Screen
-> Word64
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Word64
mkUnmanagedWindow Display
dpy (Display -> Screen
defaultScreenOfDisplay Display
dpy) Word64
rootw
                    (Rectangle -> Position
rect_x Rectangle
scr) (Rectangle -> Position
rect_y Rectangle
scr) (Rectangle -> Dimension
rect_width Rectangle
scr) (Rectangle -> Dimension
rect_height Rectangle
scr)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> IO ()
mapWindow Display
dpy Word64
win
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> Word64 -> IO ()
selectInput Display
dpy Word64
win (Word64
exposureMask forall a. Bits a => a -> a -> a
.|. Word64
keyPressMask forall a. Bits a => a -> a -> a
.|. Word64
buttonReleaseMask)
    CInt
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> Bool -> CInt -> CInt -> Word64 -> IO CInt
grabKeyboard Display
dpy Word64
win Bool
True CInt
grabModeAsync CInt
grabModeAsync Word64
currentTime
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> Word64
-> Bool
-> Word64
-> CInt
-> CInt
-> Word64
-> Word64
-> Word64
-> IO CInt
grabPointer Display
dpy Word64
win Bool
True Word64
buttonReleaseMask CInt
grabModeAsync CInt
grabModeAsync Word64
none Word64
none Word64
currentTime
    XMonadFont
font <- String -> X XMonadFont
initXMF (forall a. GSConfig a -> String
gs_font GSConfig a
gsconfig)
    let screenWidth :: Integer
screenWidth = forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_width Rectangle
scr
        screenHeight :: Integer
screenHeight = forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
scr
    Maybe a
selectedElement <- if CInt
status forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess then do
                            let restriction :: Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
ss GSConfig a -> Integer
cs = (forall a. Num a => Integer -> a
fromInteger Integer
ssforall a. Fractional a => a -> a -> a
/forall a. Num a => Integer -> a
fromInteger (GSConfig a -> Integer
cs GSConfig a
gsconfig)forall a. Num a => a -> a -> a
-Double
1)forall a. Fractional a => a -> a -> a
/Double
2 :: Double
                                restrictX :: Integer
restrictX = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
screenWidth forall a. GSConfig a -> Integer
gs_cellwidth
                                restrictY :: Integer
restrictY = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
screenHeight forall a. GSConfig a -> Integer
gs_cellheight
                                originPosX :: Integer
originPosX = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (forall a. GSConfig a -> Double
gs_originFractX GSConfig a
gsconfig forall a. Num a => a -> a -> a
- (Double
1forall a. Fractional a => a -> a -> a
/Double
2)) forall a. Num a => a -> a -> a
* Double
2 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
restrictX
                                originPosY :: Integer
originPosY = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (forall a. GSConfig a -> Double
gs_originFractY GSConfig a
gsconfig forall a. Num a => a -> a -> a
- (Double
1forall a. Fractional a => a -> a -> a
/Double
2)) forall a. Num a => a -> a -> a
* Double
2 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
restrictY
                                coords :: [TwoDPosition]
coords = Integer -> Integer -> Integer -> Integer -> [TwoDPosition]
diamondRestrict Integer
restrictX Integer
restrictY Integer
originPosX Integer
originPosY
                                s :: TwoDState a
s = TwoDState { td_curpos :: TwoDPosition
td_curpos = forall a. NonEmpty a -> a
NE.head (forall a. HasCallStack => [a] -> NonEmpty a
notEmpty [TwoDPosition]
coords),
                                                td_availSlots :: [TwoDPosition]
td_availSlots = [TwoDPosition]
coords,
                                                td_elements :: [(String, a)]
td_elements = [(String, a)]
elements,
                                                td_gsconfig :: GSConfig a
td_gsconfig = GSConfig a
gsconfig,
                                                td_font :: XMonadFont
td_font = XMonadFont
font,
                                                td_paneX :: Integer
td_paneX = Integer
screenWidth,
                                                td_paneY :: Integer
td_paneY = Integer
screenHeight,
                                                td_drawingWin :: Word64
td_drawingWin = Word64
win,
                                                td_searchString :: String
td_searchString = String
"",
                                                td_elementmap :: TwoDElementMap a
td_elementmap = [] }
                            TwoDElementMap a
m <- forall a. TwoDState a -> X (TwoDElementMap a)
generateElementmap TwoDState a
s
                            forall a1 a. TwoD a1 a -> TwoDState a1 -> X a
evalTwoD (forall a. TwoD a ()
updateAllElements forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. GSConfig a -> TwoD a (Maybe a)
gs_navigate GSConfig a
gsconfig)
                                     (TwoDState a
s { td_elementmap :: TwoDElementMap a
td_elementmap = TwoDElementMap a
m })
                      else
                          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Display -> Word64 -> IO ()
unmapWindow Display
dpy Word64
win
      Display -> Word64 -> IO ()
destroyWindow Display
dpy Word64
win
      Display -> Word64 -> IO ()
ungrabPointer Display
dpy Word64
currentTime
      Display -> Bool -> IO ()
sync Display
dpy Bool
False
    XMonadFont -> X ()
releaseXMF XMonadFont
font
    forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
selectedElement

-- | Like `gridSelect' but with the current windows and their titles as elements
gridselectWindow :: GSConfig Window -> X (Maybe Window)
gridselectWindow :: GSConfig Word64 -> X (Maybe Word64)
gridselectWindow GSConfig Word64
gsconf = X [(String, Word64)]
windowMap forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig Word64
gsconf

-- | Brings up a 2D grid of windows in the center of the screen, and one can
-- select a window with cursors keys. The selected window is then passed to
-- a callback function.
withSelectedWindow :: (Window -> X ()) -> GSConfig Window -> X ()
withSelectedWindow :: (Word64 -> X ()) -> GSConfig Word64 -> X ()
withSelectedWindow Word64 -> X ()
callback GSConfig Word64
conf = do
    Maybe Word64
mbWindow <- GSConfig Word64 -> X (Maybe Word64)
gridselectWindow GSConfig Word64
conf
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Word64
mbWindow Word64 -> X ()
callback

windowMap :: X [(String,Window)]
windowMap :: X [(String, Word64)]
windowMap = do
    WindowSet
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Word64 -> X (String, Word64)
keyValuePair (forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
ws)
 where keyValuePair :: Word64 -> X (String, Word64)
keyValuePair Word64
w = (, Word64
w) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> X String
decorateName' Word64
w

decorateName' :: Window -> X String
decorateName' :: Word64 -> X String
decorateName' Word64
w = do
  forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> X NamedWindow
getName Word64
w

-- | Builds a default gs config from a colorizer function.
buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a
buildDefaultGSConfig :: forall a. (a -> Bool -> X (String, String)) -> GSConfig a
buildDefaultGSConfig a -> Bool -> X (String, String)
col = forall a.
Integer
-> Integer
-> Integer
-> (a -> Bool -> X (String, String))
-> String
-> TwoD a (Maybe a)
-> Rearranger a
-> Double
-> Double
-> String
-> Bool
-> GSConfig a
GSConfig Integer
50 Integer
130 Integer
10 a -> Bool -> X (String, String)
col String
"xft:Sans-8" forall a. TwoD a (Maybe a)
defaultNavigation forall a. Rearranger a
noRearranger (Double
1forall a. Fractional a => a -> a -> a
/Double
2) (Double
1forall a. Fractional a => a -> a -> a
/Double
2) String
"white" Bool
True

-- | Brings selected window to the current workspace.
bringSelected :: GSConfig Window -> X ()
bringSelected :: GSConfig Word64 -> X ()
bringSelected = (Word64 -> X ()) -> GSConfig Word64 -> X ()
withSelectedWindow forall a b. (a -> b) -> a -> b
$ \Word64
w -> do
    (WindowSet -> WindowSet) -> X ()
windows (Word64 -> WindowSet -> WindowSet
bringWindow Word64
w)
    Word64 -> X ()
XMonad.focus Word64
w
    (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.shiftMaster

-- | Switches to selected window's workspace and focuses that window.
goToSelected :: GSConfig Window -> X ()
goToSelected :: GSConfig Word64 -> X ()
goToSelected = (Word64 -> X ()) -> GSConfig Word64 -> X ()
withSelectedWindow forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a i l sd.
(Eq s, Eq a, Eq i) =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.focusWindow

-- | Select an application to spawn from a given list
spawnSelected :: GSConfig String -> [String] -> X ()
spawnSelected :: GSConfig String -> [String] -> X ()
spawnSelected GSConfig String
conf [String]
lst = forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig String
conf (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
lst [String]
lst) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust forall (m :: * -> *). MonadIO m => String -> m ()
spawn

-- | Select an action and run it in the X monad
runSelectedAction :: GSConfig (X ()) -> [(String, X ())] -> X ()
runSelectedAction :: GSConfig (X ()) -> [(String, X ())] -> X ()
runSelectedAction GSConfig (X ())
conf [(String, X ())]
actions = do
    Maybe (X ())
selectedActionM <- forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig (X ())
conf [(String, X ())]
actions
    case Maybe (X ())
selectedActionM of
        Just X ()
selectedAction -> X ()
selectedAction
        Maybe (X ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Select a workspace and view it using the given function
-- (normally 'W.view' or 'W.greedyView')
--
-- Another option is to shift the current window to the selected workspace:
--
-- > gridselectWorkspace (\ws -> W.greedyView ws . W.shift ws)
gridselectWorkspace :: GSConfig WorkspaceId ->
                          (WorkspaceId -> WindowSet -> WindowSet) -> X ()
gridselectWorkspace :: GSConfig String -> (String -> WindowSet -> WindowSet) -> X ()
gridselectWorkspace GSConfig String
conf String -> WindowSet -> WindowSet
viewFunc = GSConfig String -> (String -> X ()) -> X ()
gridselectWorkspace' GSConfig String
conf ((WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> WindowSet -> WindowSet
viewFunc)

-- | Select a workspace and run an arbitrary action on it.
gridselectWorkspace' :: GSConfig WorkspaceId -> (WorkspaceId -> X ()) -> X ()
gridselectWorkspace' :: GSConfig String -> (String -> X ()) -> X ()
gridselectWorkspace' GSConfig String
conf String -> X ()
func = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> do
    let wss :: [String]
wss = forall a b. (a -> b) -> [a] -> [b]
map forall i l a. Workspace i l a -> i
W.tag forall a b. (a -> b) -> a -> b
$ forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden WindowSet
ws forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws forall a. a -> [a] -> [a]
: forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible WindowSet
ws)
    forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig String
conf (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
wss [String]
wss) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust String -> X ()
func

-- $rearrangers
--
-- Rearrangers allow for arbitrary post-filter rearranging of the grid
-- elements.
--
-- For example, to be able to switch to a new dynamic workspace by typing
-- in its name, you can use the following keybinding action:
--
-- > import XMonad.Actions.DynamicWorkspaces (addWorkspace)
-- >
-- > gridselectWorkspace' def
-- >                          { gs_navigate   = navNSearch
-- >                          , gs_rearranger = searchStringRearrangerGenerator id
-- >                          }
-- >                      addWorkspace

-- | A function taking the search string and a list of elements, and
-- returning a potentially rearranged list of elements.
type Rearranger a = String -> [(String, a)] -> X [(String, a)]

-- | A rearranger that leaves the elements unmodified.
noRearranger :: Rearranger a
noRearranger :: forall a. Rearranger a
noRearranger String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return

-- | A generator for rearrangers that append a single element based on the
-- search string, if doing so would not be redundant (empty string or value
-- already present).
searchStringRearrangerGenerator :: (String -> a) -> Rearranger a
searchStringRearrangerGenerator :: forall a. (String -> a) -> Rearranger a
searchStringRearrangerGenerator String -> a
f =
    let r :: String -> [(String, a)] -> m [(String, a)]
r String
"" [(String, a)]
xs                       = forall (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
        r String
s  [(String, a)]
xs | String
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, a)]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
                | Bool
otherwise           = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, a)]
xs forall a. [a] -> [a] -> [a]
++ [(String
s, String -> a
f String
s)]
    in forall {m :: * -> *}.
Monad m =>
String -> [(String, a)] -> m [(String, a)]
r