{-# 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 XConfig l -> String
forall (l :: * -> *). XConfig l -> String
focusedBorderColor else XConfig l -> String
forall (l :: * -> *). XConfig l -> String
normalBorderColor
        in (XConf -> (String, String)) -> X (String, String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> (String, String)) -> X (String, String))
-> (XConf -> (String, String)) -> X (String, String)
forall a b. (a -> b) -> a -> b
$ (, String
"black") (String -> (String, String))
-> (XConf -> String) -> XConf -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConfig Layout -> String
forall (l :: * -> *). XConfig l -> String
getColor (XConfig Layout -> String)
-> (XConf -> XConfig Layout) -> XConf -> String
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 = (a -> Bool -> X (String, String)) -> GSConfig a
forall a. (a -> Bool -> X (String, String)) -> GSConfig a
buildDefaultGSConfig a -> Bool -> X (String, String)
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
    rearrangedElements <- Rearranger a
rearranger String
searchString [(String, a)]
sortedElements
    return $ zip positions 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 = ((String, a) -> Bool) -> [(String, a)] -> [(String, a)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((String
searchString String -> String -> Bool
`isInfixOfI`) (String -> Bool) -> ((String, a) -> String) -> (String, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, a) -> String
forall a b. (a, b) -> a
fst) (TwoDState a -> [(String, a)]
forall a. TwoDState a -> [(String, a)]
td_elements TwoDState a
s)
    -- Sorts the elementmap
    sortedElements :: [(String, a)]
sortedElements = String -> [(String, a)] -> [(String, a)]
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 String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String -> String
upper String
haystack
    upper :: String -> String
upper = (Char -> Char) -> String -> String
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
searchString then [(String, a)]
sortedElements else [(String, a)]
elements
  where
    upper :: String -> String
upper = (Char -> Char) -> String -> String
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 = ( [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String
upper String
searchString)) (String -> [String]
forall a. [a] -> [[a]]
tails (String -> [String])
-> ((String, b) -> String) -> (String, b) -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
upper (String -> String)
-> ((String, b) -> String) -> (String, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, b) -> String
forall a b. (a, b) -> a
fst ((String, b) -> [String]) -> (String, b) -> [String]
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 = ((Int, (String, b)) -> (Int, String))
-> (Int, (String, b)) -> (Int, (String, b)) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Int
score, (String
str,b
_)) -> (Int
score, String
str))
    sortedElements :: [(String, a)]
sortedElements = ((Int, (String, a)) -> (String, a))
-> [(Int, (String, a))] -> [(String, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (String, a)) -> (String, a)
forall a b. (a, b) -> b
snd ([(Int, (String, a))] -> [(String, a)])
-> ([(Int, (String, a))] -> [(Int, (String, a))])
-> [(Int, (String, a))]
-> [(String, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (String, a)) -> (Int, (String, a)) -> Ordering)
-> [(Int, (String, a))] -> [(Int, (String, a))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int, (String, a)) -> (Int, (String, a)) -> Ordering
forall {b}. (Int, (String, b)) -> (Int, (String, b)) -> Ordering
compareScore ([(Int, (String, a))] -> [(String, a)])
-> [(Int, (String, a))] -> [(String, a)]
forall a b. (a -> b) -> a -> b
$ ((String, a) -> (Int, (String, a)))
-> [(String, a)] -> [(Int, (String, a))]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> (Int, (String, a))
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 -> b) -> TwoD a a -> TwoD a b)
-> (forall a b. a -> TwoD a b -> TwoD a a) -> Functor (TwoD a)
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
$cfmap :: forall a a b. (a -> b) -> TwoD a a -> TwoD a b
fmap :: forall a b. (a -> b) -> TwoD a a -> TwoD a b
$c<$ :: forall a a b. a -> TwoD a b -> TwoD a a
<$ :: forall a b. a -> TwoD a b -> TwoD a a
Functor, Functor (TwoD a)
Functor (TwoD a) =>
(forall a. a -> TwoD a a)
-> (forall 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 b. TwoD a a -> TwoD a b -> TwoD a b)
-> (forall a b. TwoD a a -> TwoD a b -> TwoD a a)
-> Applicative (TwoD a)
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
$cpure :: forall a a. a -> TwoD a a
pure :: forall a. a -> TwoD a a
$c<*> :: forall a a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
<*> :: forall a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
$cliftA2 :: forall a a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
liftA2 :: forall a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
$c*> :: forall a a b. TwoD a a -> TwoD a b -> TwoD a b
*> :: 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 a
<* :: forall a b. TwoD a a -> TwoD a b -> TwoD a a
Applicative, Applicative (TwoD a)
Applicative (TwoD a) =>
(forall a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b)
-> (forall a b. TwoD a a -> TwoD a b -> TwoD a b)
-> (forall a. a -> TwoD a a)
-> Monad (TwoD a)
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
$c>>= :: forall a a b. TwoD a 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 -> TwoD a b -> TwoD a b
>> :: forall a b. TwoD a a -> TwoD a b -> TwoD a b
$creturn :: forall a a. a -> TwoD a a
return :: forall a. a -> TwoD a a
Monad, MonadState (TwoDState a))

liftX ::  X a1 -> TwoD a a1
liftX :: forall a1 a. X a1 -> TwoD a a1
liftX = StateT (TwoDState a) X a1 -> TwoD a a1
forall a b. StateT (TwoDState a) X b -> TwoD a b
TwoD (StateT (TwoDState a) X a1 -> TwoD a a1)
-> (X a1 -> StateT (TwoDState a) X a1) -> X a1 -> TwoD a a1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X a1 -> StateT (TwoDState a) X a1
forall (m :: * -> *) a. Monad m => m a -> StateT (TwoDState a) m a
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 = (StateT (TwoDState a1) X a -> TwoDState a1 -> X a)
-> TwoDState a1 -> StateT (TwoDState a1) X a -> X a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (TwoDState a1) X a -> TwoDState a1 -> X a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT TwoDState a1
s (StateT (TwoDState a1) X a -> X a)
-> StateT (TwoDState a1) X a -> X a
forall a b. (a -> b) -> a -> b
$ TwoD a1 a -> StateT (TwoDState a1) X a
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
na -> a -> a
forall a. Num a => a -> a -> a
-a
x) | a
x <- [a
0..a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1] ]
      r :: [(a, a)]
r  = [(a, a)]
tr [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ ((a, a) -> (a, a)) -> [(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 [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ ((a, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a
forall a. Num a => a -> a
negate (a -> a) -> (a -> a) -> (a, a) -> (a, a)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> a
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 = [Item (Stream (a, a))] -> Stream (a, a)
forall l. IsList l => [Item l] -> l
fromList ([Item (Stream (a, a))] -> Stream (a, a))
-> [Item (Stream (a, a))] -> Stream (a, a)
forall a b. (a -> b) -> a -> b
$ (a -> [(a, a)]) -> [a] -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [(a, a)]
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 =
  (TwoDPosition -> Bool) -> [TwoDPosition] -> [TwoDPosition]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\(Integer
x',Integer
y') -> Integer -> Integer
forall a. Num a => a -> a
abs Integer
x' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
x Bool -> Bool -> Bool
&& Integer -> Integer
forall a. Num a => a -> a
abs Integer
y' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
y) ([TwoDPosition] -> [TwoDPosition])
-> (Stream TwoDPosition -> [TwoDPosition])
-> Stream TwoDPosition
-> [TwoDPosition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (TwoDPosition -> TwoDPosition) -> [TwoDPosition] -> [TwoDPosition]
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
x', Integer
y') -> (Integer
x' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
originX, Integer
y' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
originY)) ([TwoDPosition] -> [TwoDPosition])
-> (Stream TwoDPosition -> [TwoDPosition])
-> Stream TwoDPosition
-> [TwoDPosition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> Stream TwoDPosition -> [TwoDPosition]
forall a. Int -> Stream a -> [a]
takeS Int
1000 (Stream TwoDPosition -> [TwoDPosition])
-> Stream TwoDPosition -> [TwoDPosition]
forall a b. (a -> b) -> a -> b
$ Stream TwoDPosition
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 = ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
pos) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
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 =
  (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  gc <- IO GC -> X GC
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GC -> X GC) -> IO GC -> X GC
forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> IO GC
createGC Display
dpy Word64
win
  bordergc <- liftIO $ createGC dpy win
  liftIO $ do
    Just fgcolor <- initColor dpy fg
    Just bgcolor <- initColor dpy bg
    Just bordercolor <- initColor dpy bc
    setForeground dpy gc fgcolor
    setBackground dpy gc bgcolor
    setForeground dpy bordergc bordercolor
    fillRectangle dpy win gc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
    drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
  stext <- shrinkWhile (shrinkIt shrinkText)
           (\String
n -> do size <- IO Int -> X Int
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> X Int) -> IO Int -> X Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
font String
n
                     return $ size > fromInteger (cw-(2*cp)))
           text
  -- calculate the offset to vertically centre the text based on the ascender and descender
  (asc,desc) <- liftIO $ textExtentsXMF font stext
  let offset = ((Integer
ch Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position
asc Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
desc)) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
asc
  printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+offset)) stext
  liftIO $ freeGC dpy gc
  liftIO $ freeGC dpy bordergc

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

grayoutElements :: Int -> TwoD a ()
grayoutElements :: forall a. Int -> TwoD a ()
grayoutElements Int
skip =
    do
      s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
      updateElementsWithColorizer grayOnly $ drop skip (td_elementmap s)
    where grayOnly :: p -> p -> m (String, String)
grayOnly p
_ p
_ = (String, String) -> m (String, String)
forall a. a -> m a
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
      s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
      updateElementsWithColorizer (gs_colorizer (td_gsconfig s)) 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 = curpos,
                td_drawingWin = win,
                td_gsconfig = gsconfig,
                td_font = font,
                td_paneX = paneX,
                td_paneY = paneY} <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
    let cellwidth = GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellwidth GSConfig a
gsconfig
        cellheight = GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellheight GSConfig a
gsconfig
        paneX' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div (Integer
paneXInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
cellwidth) Integer
2
        paneY' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div (Integer
paneYInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
cellheight) Integer
2
        updateElement (pos :: TwoDPosition
pos@(Integer
x,Integer
y),(String
text, a
element)) = X () -> TwoD a ()
forall a1 a. X a1 -> TwoD a a1
liftX (X () -> TwoD a ()) -> X () -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ do
            colors <- a -> Bool -> X (String, String)
colorizer a
element (TwoDPosition
pos TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
== TwoDPosition
curpos)
            drawWinBox win font
                       colors
                       (gs_bordercolor gsconfig)
                       cellheight
                       cellwidth
                       text
                       (paneX'+x*cellwidth)
                       (paneY'+y*cellheight)
                       (gs_cellpadding gsconfig)
    mapM_ updateElement 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 Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
buttonRelease = do
        s@TwoDState{ td_paneX = px
                   , td_paneY = py
                   , td_gsconfig = GSConfig{ gs_cellheight = ch
                                           , gs_cellwidth = cw
                                           , gs_cancelOnEmptyClick = cancelOnEmptyClick
                                           }
                   } <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
        let gridX = (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
px Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
cw) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
cw
            gridY = (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
y Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
py Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
ch) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
ch
        case lookup (gridX,gridY) (td_elementmap s) of
             Just (String
_,a
el) -> Maybe a -> TwoD a (Maybe a)
forall a. a -> TwoD a a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
el)
             Maybe (String, a)
Nothing     -> if Bool
cancelOnEmptyClick
                            then Maybe a -> TwoD a (Maybe a)
forall a. a -> TwoD a a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 = TwoD a ()
forall a. TwoD a ()
updateAllElements TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
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 = (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a. (a -> a) -> a
fix ((TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a))
-> (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ \TwoD a (Maybe a)
me -> TwoD a (TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (TwoD a (TwoD a (Maybe a)) -> TwoD a (Maybe a))
-> TwoD a (TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ X (TwoD a (Maybe a)) -> TwoD a (TwoD a (Maybe a))
forall a1 a. X a1 -> TwoD a a1
liftX (X (TwoD a (Maybe a)) -> TwoD a (TwoD a (Maybe a)))
-> X (TwoD a (Maybe a)) -> TwoD a (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ (Display -> X (TwoD a (Maybe a))) -> X (TwoD a (Maybe a))
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (TwoD a (Maybe a))) -> X (TwoD a (Maybe a)))
-> (Display -> X (TwoD a (Maybe a))) -> X (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO (TwoD a (Maybe a)) -> X (TwoD a (Maybe a))
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TwoD a (Maybe a)) -> X (TwoD a (Maybe a)))
-> IO (TwoD a (Maybe a)) -> X (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO (TwoD a (Maybe a))) -> IO (TwoD a (Maybe a))
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (TwoD a (Maybe a))) -> IO (TwoD a (Maybe a)))
-> (XEventPtr -> IO (TwoD a (Maybe a))) -> IO (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
                             Display -> Word64 -> XEventPtr -> IO ()
maskEvent Display
d (Word64
exposureMask Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
keyPressMask Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
buttonReleaseMask) XEventPtr
e
                             ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
                             if ev_event_type ev == keyPress
                               then do
                                  (_, s) <- lookupString $ asKeyEvent e
                                  ks <- keycodeToKeysym d (ev_keycode ev) 0
                                  return $ do
                                      mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)
                                      keyhandler (ks, s, mask)
                               else
                                  return $ stdHandle ev 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') = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe ((Word64, String, KeyMask) -> a
dflt (Word64, String, KeyMask)
keyEvent) ((KeyMask, Word64) -> Map (KeyMask, Word64) a -> Maybe a
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
  s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
  return $ snd . snd <$> findInElementMap (td_curpos s) (td_elementmap s)

-- | Closes gridselect returning no element.
cancel :: TwoD a (Maybe a)
cancel :: forall a. TwoD a (Maybe a)
cancel = Maybe a -> TwoD a (Maybe a)
forall a. a -> TwoD a a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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
  s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
  let elmap = TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
      newSelectedEl = TwoDPosition
-> TwoDElementMap a -> Maybe (TwoDPosition, (String, a))
forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap TwoDPosition
newPos (TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)
      oldPos = TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s
  when (isJust newSelectedEl && newPos /= oldPos) $ do
    put s { td_curpos = newPos }
    updateElements (catMaybes [findInElementMap oldPos elmap, 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
  s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
  let (x,y) = td_curpos s
      newPos = (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
dx,Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
dy)
  setPos newPos

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

movePrev :: TwoD a ()
movePrev :: forall a. TwoD a ()
movePrev = do
  position <- (TwoDState a -> TwoDPosition) -> TwoD a TwoDPosition
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos
  elems <- gets td_elementmap
  let n = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
      m = case ((TwoDPosition, (String, a)) -> Bool)
-> TwoDElementMap a -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(TwoDPosition, (String, a))
p -> (TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a, b) -> a
fst (TwoDPosition, (String, a))
p TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
== TwoDPosition
position) TwoDElementMap a
elems of
               Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
               Just Int
0  -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
               Just Int
k  -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  whenJust m $ \Int
i ->
      TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
setPos ((TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a, b) -> a
fst ((TwoDPosition, (String, a)) -> TwoDPosition)
-> (TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a -> b) -> a -> b
$ TwoDElementMap a
elems TwoDElementMap a -> Int -> (TwoDPosition, (String, a))
forall a. HasCallStack => [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
          s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
          let oldSearchString = TwoDState a -> String
forall a. TwoDState a -> String
td_searchString TwoDState a
s
              newSearchString = String -> String
f String
oldSearchString
          when (newSearchString /= oldSearchString) $ do
            -- FIXME curpos might end up outside new bounds
            let s' = TwoDState a
s { td_searchString = newSearchString }
            m <- liftX $ generateElementmap s'
            let s'' = TwoDState a
s' { td_elementmap = m }
                oldLen = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TwoDElementMap a -> Int) -> TwoDElementMap a -> Int
forall a b. (a -> b) -> a -> b
$ TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
                newLen = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TwoDElementMap a -> Int) -> TwoDElementMap a -> Int
forall a b. (a -> b) -> a -> b
$ TwoDState a -> TwoDElementMap a
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.
            when (newLen < oldLen) $ grayoutElements newLen
            put s''
            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 = ((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Word64, String, KeyMask) -> TwoD a (Maybe a))
 -> TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Word64) (TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> (Word64, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
forall {a}. Map (KeyMask, Word64) (TwoD a (Maybe a))
navKeyMap (Word64, String, KeyMask) -> TwoD a (Maybe a)
forall {b} {a}. b -> TwoD a (Maybe a)
navDefaultHandler
  where navKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
navKeyMap = [((KeyMask, Word64), TwoD a (Maybe a))]
-> Map (KeyMask, Word64) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Word64
xK_Escape)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
cancel)
          ,((KeyMask
0,Word64
xK_Return)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
select)
          ,((KeyMask
0,Word64
xK_slash)      , TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a. TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Left)       , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_h)          , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Right)      , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_l)          , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Down)       , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_j)          , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Up)         , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_k)          , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_Tab)        , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_n)          , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
shiftMask,Word64
xK_Tab), TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Word64
xK_p)          , TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ]
        -- The navigation handler ignores unknown key symbols, therefore we const
        navDefaultHandler :: b -> TwoD a (Maybe a)
navDefaultHandler = TwoD a (Maybe a) -> b -> TwoD a (Maybe a)
forall a b. a -> b -> a
const TwoD a (Maybe a)
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 = ((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Word64, String, KeyMask) -> TwoD a (Maybe a))
 -> TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Word64) (TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> (Word64, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
forall {a}. Map (KeyMask, Word64) (TwoD a (Maybe a))
navNSearchKeyMap (Word64, String, KeyMask) -> TwoD a (Maybe a)
forall {a} {c} {a}. (a, String, c) -> TwoD a (Maybe a)
navNSearchDefaultHandler
  where navNSearchKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
navNSearchKeyMap = [((KeyMask, Word64), TwoD a (Maybe a))]
-> Map (KeyMask, Word64) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Word64
xK_Escape)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
cancel)
          ,((KeyMask
0,Word64
xK_Return)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
select)
          ,((KeyMask
0,Word64
xK_Left)       , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Right)      , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Down)       , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Up)         , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_Tab)        , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
shiftMask,Word64
xK_Tab), TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Word64
xK_BackSpace), (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (\String
s -> if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else String -> String
forall a. HasCallStack => [a] -> [a]
init String
s) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
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
          (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
          TwoD a (Maybe a)
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 = (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a. (a -> a) -> a
fix ((TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a))
-> (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ \TwoD a (Maybe a)
me ->
  let searchKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
searchKeyMap = [((KeyMask, Word64), TwoD a (Maybe a))]
-> Map (KeyMask, Word64) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Word64
xK_Escape)   , (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (String -> String -> String
forall a b. a -> b -> a
const String
"") TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
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), (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (\String
s -> if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else String -> String
forall a. HasCallStack => [a] -> [a]
init String
s) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
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
          (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
          TwoD a (Maybe a)
me
  in ((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Word64, String, KeyMask) -> TwoD a (Maybe a))
 -> TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Word64) (TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> (Word64, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
searchKeyMap (Word64, String, KeyMask) -> TwoD a (Maybe a)
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 = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div Integer
h Integer
60 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
6 :: Integer
        f :: a
f = ((Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
ha -> a -> a
forall a. Fractional a => a -> a -> a
/a
60) a -> a -> a
forall a. Num a => a -> a -> a
- Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
hi) :: Fractional a => a
        q :: a
q = a
v a -> a -> a
forall a. Num a => a -> a -> a
* (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
f)
        p :: a
p = a
v a -> a -> a
forall a. Num a => a -> a -> a
* (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
s)
        t :: a
t = a
v a -> a -> a
forall a. Num a => a -> a -> a
* (a
1a -> a -> a
forall a. Num a => a -> a -> a
-(a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
f)a -> a -> a
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
_ -> String -> (a, a, a)
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 = Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x)(Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
s) :: Integer
        (Double
r,Double
g,Double
b) = (Integer, Double, Double) -> (Double, Double, Double)
forall a. Fractional a => (Integer, a, a) -> (a, a, a)
hsv2rgb (Int -> Integer
seed Int
83 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
360,
                           Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
seed Int
191 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1000)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2500Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
0.4,
                           Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
seed Int
121 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1000)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2500Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
0.4)
    in if Bool
active
         then (String, String) -> X (String, String)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#faff69", String
"black")
         else (String, String) -> X (String, String)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Double -> String) -> [Double] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Word8 -> String
twodigitHex(Word8 -> String) -> (Double -> Word8) -> Double -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round :: Double -> Word8)(Double -> Word8) -> (Double -> Double) -> Double -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Double -> Double -> Double
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 = Query String -> Word64 -> X String
forall a. Query a -> Word64 -> X a
runQuery Query String
className Word64
w X String -> (String -> X (String, String)) -> X (String, String)
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Bool -> X (String, String))
-> Bool -> String -> X (String, String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Bool -> X (String, String)
forall a. HasColorizer a => a -> Bool -> X (String, String)
defaultColorizer Bool
active

twodigitHex :: Word8 -> String
twodigitHex :: Word8 -> String
twodigitHex = String -> Word8 -> String
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 classname <- Query String -> Word64 -> X String
forall a. Query a -> Word64 -> X a
runQuery Query String
className Word64
w
       if active
         then return (rgbToHex activeC, rgbToHex activeT)
         else return (rgbToHex $ mix startC endC
                  $ stringToRatio classname, rgbToHex inactiveT)
    where rgbToHex :: (Word8, Word8, Word8) -> String
          rgbToHex :: (Word8, Word8, Word8) -> String
rgbToHex (Word8
r, Word8
g, Word8
b) = Char
'#'Char -> String -> String
forall a. a -> [a] -> [a]
:Word8 -> String
twodigitHex Word8
r
                               String -> String -> String
forall a. [a] -> [a] -> [a]
++Word8 -> String
twodigitHex Word8
gString -> String -> String
forall 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 = (Word8 -> Word8 -> Word8
forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
r1 Word8
r2, Word8 -> Word8 -> Word8
forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
g1 Word8
g2, Word8 -> Word8 -> Word8
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 = Double -> b
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> b) -> Double -> b
forall a b. (a -> b) -> a -> b
$ (a -> Double
forall a b. (Integral a, Num b) => a -> b
fi a
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
r) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (a -> Double
forall a b. (Integral a, Num b) => a -> b
fi a
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
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 (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ (Int -> Char -> Int) -> Int -> String -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
t Char
c -> Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
31 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) Int
0 String
s
                  in (Double, StdGen) -> Double
forall a b. (a, b) -> a
fst ((Double, StdGen) -> Double) -> (Double, StdGen) -> Double
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> StdGen -> (Double, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
forall g. RandomGen g => (Double, Double) -> g -> (Double, 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
_ [] = Maybe a -> X (Maybe a)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
gridselect GSConfig a
gsconfig [(String, a)]
elements =
 (Display -> X (Maybe a)) -> X (Maybe a)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Maybe a)) -> X (Maybe a))
-> (Display -> X (Maybe a)) -> X (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    rootw <- (XConf -> Word64) -> X Word64
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Word64
theRoot
    scr <- gets $ screenRect . W.screenDetail . W.current . windowset
    win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
                    (rect_x scr) (rect_y scr) (rect_width scr) (rect_height scr)
    liftIO $ mapWindow dpy win
    liftIO $ selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask)
    status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
    void $ io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime
    font <- initXMF (gs_font gsconfig)
    let screenWidth = Dimension -> Integer
forall a. Integral a => a -> Integer
toInteger (Dimension -> Integer) -> Dimension -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_width Rectangle
scr
        screenHeight = Dimension -> Integer
forall a. Integral a => a -> Integer
toInteger (Dimension -> Integer) -> Dimension -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
scr
    selectedElement <- if status == grabSuccess then do
                            let restriction Integer
ss GSConfig a -> Integer
cs = (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
ssDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Integer -> Double
forall a. Num a => Integer -> a
fromInteger (GSConfig a -> Integer
cs GSConfig a
gsconfig)Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
1)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2 :: Double
                                restrictX = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
screenWidth GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellwidth
                                restrictY = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
screenHeight GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellheight
                                originPosX = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ (GSConfig a -> Double
forall a. GSConfig a -> Double
gs_originFractX GSConfig a
gsconfig Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
restrictX
                                originPosY = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ (GSConfig a -> Double
forall a. GSConfig a -> Double
gs_originFractY GSConfig a
gsconfig Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
restrictY
                                coords = Integer -> Integer -> Integer -> Integer -> [TwoDPosition]
diamondRestrict Integer
restrictX Integer
restrictY Integer
originPosX Integer
originPosY
                                s = TwoDState { td_curpos :: TwoDPosition
td_curpos = NonEmpty TwoDPosition -> TwoDPosition
forall a. NonEmpty a -> a
NE.head ([TwoDPosition] -> NonEmpty TwoDPosition
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 = [] }
                            m <- generateElementmap s
                            evalTwoD (updateAllElements >> gs_navigate gsconfig)
                                     (s { td_elementmap = m })
                      else
                          return Nothing
    liftIO $ do
      unmapWindow dpy win
      destroyWindow dpy win
      ungrabPointer dpy currentTime
      sync dpy False
    releaseXMF font
    return 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 X [(String, Word64)]
-> ([(String, Word64)] -> X (Maybe Word64)) -> X (Maybe Word64)
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GSConfig Word64 -> [(String, Word64)] -> X (Maybe Word64)
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
    mbWindow <- GSConfig Word64 -> X (Maybe Word64)
gridselectWindow GSConfig Word64
conf
    for_ mbWindow callback

windowMap :: X [(String,Window)]
windowMap :: X [(String, Word64)]
windowMap = do
    ws <- (XState
 -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
windowset
    mapM keyValuePair (W.allWindows ws)
 where keyValuePair :: Word64 -> X (String, Word64)
keyValuePair Word64
w = (, Word64
w) (String -> (String, Word64)) -> X String -> X (String, Word64)
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
  NamedWindow -> String
forall a. Show a => a -> String
show (NamedWindow -> String) -> X NamedWindow -> X String
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 = Integer
-> Integer
-> Integer
-> (a -> Bool -> X (String, String))
-> String
-> TwoD a (Maybe a)
-> Rearranger a
-> Double
-> Double
-> String
-> Bool
-> GSConfig a
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" TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation Rearranger a
forall a. Rearranger a
noRearranger (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
1Double -> Double -> Double
forall 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 ((Word64 -> X ()) -> GSConfig Word64 -> X ())
-> (Word64 -> X ()) -> GSConfig Word64 -> X ()
forall a b. (a -> b) -> a -> b
$ \Word64
w -> do
    (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
 -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows (Word64
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
bringWindow Word64
w)
    Word64 -> X ()
XMonad.focus Word64
w
    (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
 -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
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 ((Word64 -> X ()) -> GSConfig Word64 -> X ())
-> (Word64 -> X ()) -> GSConfig Word64 -> X ()
forall a b. (a -> b) -> a -> b
$ (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
 -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
  -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
 -> X ())
-> (Word64
    -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
    -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> Word64
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
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 = GSConfig String -> [(String, String)] -> X (Maybe String)
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig String
conf ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
lst [String]
lst) X (Maybe String) -> (Maybe String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> (String -> X ()) -> X ())
-> (String -> X ()) -> Maybe String -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe String -> (String -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust String -> X ()
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
    selectedActionM <- GSConfig (X ()) -> [(String, X ())] -> X (Maybe (X ()))
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig (X ())
conf [(String, X ())]
actions
    case selectedActionM of
        Just X ()
selectedAction -> X ()
selectedAction
        Maybe (X ())
Nothing -> () -> X ()
forall a. a -> X a
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
    -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
    -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
gridselectWorkspace GSConfig String
conf String
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
viewFunc = GSConfig String -> (String -> X ()) -> X ()
gridselectWorkspace' GSConfig String
conf ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
 -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
  -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
 -> X ())
-> (String
    -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
    -> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> String
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
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 = (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
 -> X ())
-> X ()
forall a.
(StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
 -> X a)
-> X a
withWindowSet ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
  -> X ())
 -> X ())
-> (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
    -> X ())
-> X ()
forall a b. (a -> b) -> a -> b
$ \StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws -> do
    let wss :: [String]
wss = (Workspace String (Layout Word64) Word64 -> String)
-> [Workspace String (Layout Word64) Word64] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Workspace String (Layout Word64) Word64 -> String
forall i l a. Workspace i l a -> i
W.tag ([Workspace String (Layout Word64) Word64] -> [String])
-> [Workspace String (Layout Word64) Word64] -> [String]
forall a b. (a -> b) -> a -> b
$ StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> [Workspace String (Layout Word64) Word64]
forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws [Workspace String (Layout Word64) Word64]
-> [Workspace String (Layout Word64) Word64]
-> [Workspace String (Layout Word64) Word64]
forall a. [a] -> [a] -> [a]
++ (Screen String (Layout Word64) Word64 ScreenId ScreenDetail
 -> Workspace String (Layout Word64) Word64)
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
-> [Workspace String (Layout Word64) Word64]
forall a b. (a -> b) -> [a] -> [b]
map Screen String (Layout Word64) Word64 ScreenId ScreenDetail
-> Workspace String (Layout Word64) Word64
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> Screen String (Layout Word64) Word64 ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws Screen String (Layout Word64) Word64 ScreenId ScreenDetail
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws)
    GSConfig String -> [(String, String)] -> X (Maybe String)
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig String
conf ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
wss [String]
wss) X (Maybe String) -> (Maybe String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> (String -> X ()) -> X ())
-> (String -> X ()) -> Maybe String -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe String -> (String -> X ()) -> X ()
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
_ = [(String, a)] -> X [(String, a)]
forall a. a -> X a
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                       = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
        r String
s  [(String, a)]
xs | String
s String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> String
forall a b. (a, b) -> a
fst [(String, a)]
xs = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
                | Bool
otherwise           = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, a)] -> m [(String, a)])
-> [(String, a)] -> m [(String, a)]
forall a b. (a -> b) -> a -> b
$ [(String, a)]
xs [(String, a)] -> [(String, a)] -> [(String, a)]
forall a. [a] -> [a] -> [a]
++ [(String
s, String -> a
f String
s)]
    in String -> [(String, a)] -> X [(String, a)]
forall {m :: * -> *}.
Monad m =>
String -> [(String, a)] -> m [(String, a)]
r