{-# 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)

-- $usage
--
-- You can use this module with the following in your @~\/.xmonad\/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 $ spawnSelected defaultColorizer)

-- $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),
      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
}

-- | 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 :: Window -> Bool -> X (String, String)
defaultColorizer = Window -> 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 -> Window
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
    TwoDElementMap a -> X (TwoDElementMap a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TwoDElementMap a -> X (TwoDElementMap a))
-> TwoDElementMap a -> X (TwoDElementMap a)
forall a b. (a -> b) -> a -> b
$ [TwoDPosition] -> [(String, a)] -> TwoDElementMap a
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 = ((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 (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 (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
<$ :: 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, 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
<* :: 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, 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
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 = 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 (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 (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) => [(a, a)]
diamond :: forall a. (Enum a, Num a, Eq a) => [(a, a)]
diamond = (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])
-> ([TwoDPosition] -> [TwoDPosition])
-> [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])
-> ([TwoDPosition] -> [TwoDPosition])
-> [TwoDPosition]
-> [TwoDPosition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> [TwoDPosition] -> [TwoDPosition]
forall a. Int -> [a] -> [a]
take Int
1000 ([TwoDPosition] -> [TwoDPosition])
-> [TwoDPosition] -> [TwoDPosition]
forall a b. (a -> b) -> a -> b
$ [TwoDPosition]
forall a. (Enum a, Num a, Eq a) => [(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 :: Window
-> XMonadFont
-> (String, String)
-> String
-> Integer
-> Integer
-> String
-> Integer
-> Integer
-> Integer
-> X ()
drawWinBox Window
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
gc <- IO GC -> X GC
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GC -> X GC) -> IO GC -> X GC
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO GC
createGC Display
dpy Window
win
  GC
bordergc <- IO GC -> X GC
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GC -> X GC) -> IO GC -> X GC
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO GC
createGC Display
dpy Window
win
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Just Window
fgcolor <- Display -> String -> IO (Maybe Window)
initColor Display
dpy String
fg
    Just Window
bgcolor <- Display -> String -> IO (Maybe Window)
initColor Display
dpy String
bg
    Just Window
bordercolor <- Display -> String -> IO (Maybe Window)
initColor Display
dpy String
bc
    Display -> GC -> Window -> IO ()
setForeground Display
dpy GC
gc Window
fgcolor
    Display -> GC -> Window -> IO ()
setBackground Display
dpy GC
gc Window
bgcolor
    Display -> GC -> Window -> IO ()
setForeground Display
dpy GC
bordergc Window
bordercolor
    Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
dpy Window
win GC
gc (Integer -> Position
forall a. Num a => Integer -> a
fromInteger Integer
x) (Integer -> Position
forall a. Num a => Integer -> a
fromInteger Integer
y) (Integer -> Dimension
forall a. Num a => Integer -> a
fromInteger Integer
cw) (Integer -> Dimension
forall a. Num a => Integer -> a
fromInteger Integer
ch)
    Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
drawRectangle Display
dpy Window
win GC
bordergc (Integer -> Position
forall a. Num a => Integer -> a
fromInteger Integer
x) (Integer -> Position
forall a. Num a => Integer -> a
fromInteger Integer
y) (Integer -> Dimension
forall a. Num a => Integer -> a
fromInteger Integer
cw) (Integer -> Dimension
forall a. Num a => Integer -> a
fromInteger Integer
ch)
  String
stext <- (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile (DefaultShrinker -> String -> [String]
forall s. Shrinker s => s -> String -> [String]
shrinkIt DefaultShrinker
shrinkText)
           (\String
n -> do Int
size <- IO Int -> X Int
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
                     Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> X Bool) -> Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer
cwInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-(Integer
2Integer -> Integer -> Integer
forall 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) <- IO (Position, Position) -> X (Position, Position)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Position, Position) -> X (Position, Position))
-> IO (Position, Position) -> X (Position, Position)
forall a b. (a -> b) -> a -> b
$ XMonadFont -> String -> IO (Position, Position)
forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
font String
stext
  let offset :: Integer
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
  Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> X ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
dpy Window
win XMonadFont
font GC
gc String
bg String
fg (Integer -> Position
forall a. Num a => Integer -> a
fromInteger (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
cp)) (Integer -> Position
forall a. Num a => Integer -> a
fromInteger (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
offset)) String
stext
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC Display
dpy GC
gc
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC Display
dpy GC
bordergc

updateAllElements :: TwoD a ()
updateAllElements :: forall a. TwoD a ()
updateAllElements =
    do
      TwoDState a
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
      TwoDElementMap a -> TwoD a ()
forall a. TwoDElementMap a -> TwoD a ()
updateElements (TwoDState a -> TwoDElementMap a
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 <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
      (a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
forall a.
(a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer a -> Bool -> X (String, String)
forall {m :: * -> *} {p} {p}.
Monad m =>
p -> p -> m (String, String)
grayOnly (TwoDElementMap a -> TwoD a ()) -> TwoDElementMap a -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ Int -> TwoDElementMap a -> TwoDElementMap a
forall a. Int -> [a] -> [a]
drop Int
skip (TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)
    where grayOnly :: p -> p -> m (String, String)
grayOnly p
_ p
_ = (String, String) -> m (String, String)
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 <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
      (a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
forall a.
(a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer (GSConfig a -> a -> Bool -> X (String, String)
forall a. GSConfig a -> a -> Bool -> X (String, String)
gs_colorizer (TwoDState a -> GSConfig a
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 -> Window
td_drawingWin = Window
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} <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
    let cellwidth :: Integer
cellwidth = GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellwidth GSConfig a
gsconfig
        cellheight :: Integer
cellheight = GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellheight GSConfig a
gsconfig
        paneX' :: Integer
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
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 :: (TwoDPosition, (String, a)) -> TwoD a ()
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
            (String, String)
colors <- a -> Bool -> X (String, String)
colorizer a
element (TwoDPosition
pos TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
== TwoDPosition
curpos)
            Window
-> XMonadFont
-> (String, String)
-> String
-> Integer
-> Integer
-> String
-> Integer
-> Integer
-> Integer
-> X ()
drawWinBox Window
win XMonadFont
font
                       (String, String)
colors
                       (GSConfig a -> String
forall a. GSConfig a -> String
gs_bordercolor GSConfig a
gsconfig)
                       Integer
cellheight
                       Integer
cellwidth
                       String
text
                       (Integer
paneX'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
cellwidth)
                       (Integer
paneY'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
cellheight)
                       (GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellpadding GSConfig a
gsconfig)
    ((TwoDPosition, (String, a)) -> TwoD a ())
-> TwoDElementMap a -> TwoD a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TwoDPosition, (String, a)) -> TwoD a ()
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 Dimension -> Dimension -> Bool
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 Integer
ch Integer
cw Integer
_ a -> Bool -> X (String, String)
_ String
_ TwoD a (Maybe a)
_ Rearranger a
_ Double
_ Double
_ String
_) } <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
        let gridX :: Integer
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 :: Integer
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 TwoDPosition -> [(TwoDPosition, (String, a))] -> Maybe (String, a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Integer
gridX,Integer
gridY) (TwoDState a -> [(TwoDPosition, (String, a))]
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s) of
             Just (String
_,a
el) -> Maybe a -> TwoD a (Maybe 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 -> 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 (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.
((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (Window, 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 (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 -> Window -> XEventPtr -> IO ()
maskEvent Display
d (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
keyPressMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonReleaseMask) XEventPtr
e
                             Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
                             if Event -> Dimension
ev_event_type Event
ev Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress
                               then do
                                  (Maybe Window
_, String
s) <- XKeyEventPtr -> IO (Maybe Window, String)
lookupString (XKeyEventPtr -> IO (Maybe Window, String))
-> XKeyEventPtr -> IO (Maybe Window, String)
forall a b. (a -> b) -> a -> b
$ XEventPtr -> XKeyEventPtr
asKeyEvent XEventPtr
e
                                  Window
ks <- Display -> Word8 -> CInt -> IO Window
keycodeToKeysym Display
d (Event -> Word8
ev_keycode Event
ev) CInt
0
                                  TwoD a (Maybe a) -> IO (TwoD a (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TwoD a (Maybe a) -> IO (TwoD a (Maybe a)))
-> TwoD a (Maybe a) -> IO (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
                                      KeyMask
mask <- X KeyMask -> TwoD a KeyMask
forall a1 a. X a1 -> TwoD a a1
liftX (X KeyMask -> TwoD a KeyMask) -> X KeyMask -> TwoD a KeyMask
forall a b. (a -> b) -> a -> b
$ X (KeyMask -> KeyMask)
cleanKeyMask X (KeyMask -> KeyMask) -> X KeyMask -> X KeyMask
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMask -> X KeyMask
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event -> KeyMask
ev_state Event
ev)
                                      (Window, String, KeyMask) -> TwoD a (Maybe a)
keyhandler (Window
ks, String
s, KeyMask
mask)
                               else
                                  TwoD a (Maybe a) -> IO (TwoD a (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TwoD a (Maybe a) -> IO (TwoD a (Maybe a)))
-> TwoD a (Maybe a) -> IO (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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, Window) a
-> ((Window, String, KeyMask) -> a)
-> (Window, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Window) a
keymap (Window, String, KeyMask) -> a
dflt keyEvent :: (Window, String, KeyMask)
keyEvent@(Window
ks,String
_,KeyMask
m') = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe ((Window, String, KeyMask) -> a
dflt (Window, String, KeyMask)
keyEvent) ((KeyMask, Window) -> Map (KeyMask, Window) a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
m',Window
ks) Map (KeyMask, Window) 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 <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe a -> TwoD a (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> TwoD a (Maybe a)) -> Maybe a -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ (String, a) -> a
forall a b. (a, b) -> b
snd ((String, a) -> a)
-> ((TwoDPosition, (String, a)) -> (String, a))
-> (TwoDPosition, (String, a))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TwoDPosition, (String, a)) -> (String, a)
forall a b. (a, b) -> b
snd ((TwoDPosition, (String, a)) -> a)
-> Maybe (TwoDPosition, (String, a)) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwoDPosition
-> [(TwoDPosition, (String, a))]
-> Maybe (TwoDPosition, (String, a))
forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap (TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s) (TwoDState a -> [(TwoDPosition, (String, a))]
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 = Maybe a -> TwoD a (Maybe 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
  TwoDState a
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
  let elmap :: TwoDElementMap a
elmap = TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
      newSelectedEl :: Maybe (TwoDPosition, (String, a))
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 :: TwoDPosition
oldPos = TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s
  Bool -> TwoD a () -> TwoD a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (TwoDPosition, (String, a)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TwoDPosition, (String, a))
newSelectedEl Bool -> Bool -> Bool
&& TwoDPosition
newPos TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
/= TwoDPosition
oldPos) (TwoD a () -> TwoD a ()) -> TwoD a () -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ do
    TwoDState a -> TwoD a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TwoDState a
s { td_curpos :: TwoDPosition
td_curpos = TwoDPosition
newPos }
    TwoDElementMap a -> TwoD a ()
forall a. TwoDElementMap a -> TwoD a ()
updateElements ([Maybe (TwoDPosition, (String, a))] -> TwoDElementMap a
forall a. [Maybe a] -> [a]
catMaybes [TwoDPosition
-> TwoDElementMap a -> Maybe (TwoDPosition, (String, a))
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 <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
  let (Integer
x,Integer
y) = TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s
      newPos :: TwoDPosition
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)
  TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
setPos TwoDPosition
newPos

moveNext :: TwoD a ()
moveNext :: forall a. TwoD a ()
moveNext = do
  TwoDPosition
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
  TwoDElementMap a
elems <- (TwoDState a -> TwoDElementMap a) -> TwoD a (TwoDElementMap a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap
  let n :: Int
n = TwoDElementMap a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
      m :: Maybe Int
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)
  Maybe Int -> (Int -> TwoD a ()) -> TwoD a ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
m ((Int -> TwoD a ()) -> TwoD a ())
-> (Int -> TwoD a ()) -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ \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. [a] -> Int -> a
!! Int
i)

movePrev :: TwoD a ()
movePrev :: forall a. TwoD a ()
movePrev = do
  TwoDPosition
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
  TwoDElementMap a
elems <- (TwoDState a -> TwoDElementMap a) -> TwoD a (TwoDElementMap a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap
  let n :: Int
n = TwoDElementMap a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
      m :: Maybe Int
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)
  Maybe Int -> (Int -> TwoD a ()) -> TwoD a ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
m ((Int -> TwoD a ()) -> TwoD a ())
-> (Int -> TwoD a ()) -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ \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. [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 <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
          let oldSearchString :: String
oldSearchString = TwoDState a -> String
forall a. TwoDState a -> String
td_searchString TwoDState a
s
              newSearchString :: String
newSearchString = String -> String
f String
oldSearchString
          Bool -> TwoD a () -> TwoD a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
newSearchString String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
oldSearchString) (TwoD a () -> TwoD a ()) -> TwoD a () -> TwoD a ()
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 <- X (TwoDElementMap a) -> TwoD a (TwoDElementMap a)
forall a1 a. X a1 -> TwoD a a1
liftX (X (TwoDElementMap a) -> TwoD a (TwoDElementMap a))
-> X (TwoDElementMap a) -> TwoD a (TwoDElementMap a)
forall a b. (a -> b) -> a -> b
$ TwoDState a -> X (TwoDElementMap a)
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 = TwoDElementMap 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 :: Int
newLen = TwoDElementMap 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.
            Bool -> TwoD a () -> TwoD a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
newLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
oldLen) (TwoD a () -> TwoD a ()) -> TwoD a () -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ Int -> TwoD a ()
forall a. Int -> TwoD a ()
grayoutElements Int
newLen
            TwoDState a -> TwoD a ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TwoDState a
s''
            TwoD a ()
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 = ((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Window, String, KeyMask) -> TwoD a (Maybe a))
 -> TwoD a (Maybe a))
-> ((Window, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Window) (TwoD a (Maybe a))
-> ((Window, String, KeyMask) -> TwoD a (Maybe a))
-> (Window, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Window) a
-> ((Window, String, KeyMask) -> a)
-> (Window, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Window) (TwoD a (Maybe a))
forall {a}. Map (KeyMask, Window) (TwoD a (Maybe a))
navKeyMap (Window, String, KeyMask) -> TwoD a (Maybe a)
forall {b} {a}. b -> TwoD a (Maybe a)
navDefaultHandler
  where navKeyMap :: Map (KeyMask, Window) (TwoD a (Maybe a))
navKeyMap = [((KeyMask, Window), TwoD a (Maybe a))]
-> Map (KeyMask, Window) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Window
xK_Escape)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
cancel)
          ,((KeyMask
0,Window
xK_Return)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
select)
          ,((KeyMask
0,Window
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,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
          ,((KeyMask
0,Window
xK_Tab)        , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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,Window
xK_n)          , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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,Window
xK_Tab), TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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,Window
xK_p)          , TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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 = ((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Window, String, KeyMask) -> TwoD a (Maybe a))
 -> TwoD a (Maybe a))
-> ((Window, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Window) (TwoD a (Maybe a))
-> ((Window, String, KeyMask) -> TwoD a (Maybe a))
-> (Window, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Window) a
-> ((Window, String, KeyMask) -> a)
-> (Window, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Window) (TwoD a (Maybe a))
forall {a}. Map (KeyMask, Window) (TwoD a (Maybe a))
navNSearchKeyMap (Window, String, KeyMask) -> TwoD a (Maybe a)
forall {a} {c} {a}. (a, String, c) -> TwoD a (Maybe a)
navNSearchDefaultHandler
  where navNSearchKeyMap :: Map (KeyMask, Window) (TwoD a (Maybe a))
navNSearchKeyMap = [((KeyMask, Window), TwoD a (Maybe a))]
-> Map (KeyMask, Window) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Window
xK_Escape)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
cancel)
          ,((KeyMask
0,Window
xK_Return)     , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
select)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
          ,((KeyMask
0,Window
xK_Tab)        , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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,Window
xK_Tab), TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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,Window
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. [a] -> [a]
init String
s) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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, Window) (TwoD a (Maybe a))
searchKeyMap = [((KeyMask, Window), TwoD a (Maybe a))]
-> Map (KeyMask, Window) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
           ((KeyMask
0,Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
returnNavigation)
          ,((KeyMask
0,Window
xK_Return)   , TwoD a (Maybe a)
returnNavigation)
          ,((KeyMask
0,Window
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. [a] -> [a]
init String
s) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
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 ((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Window, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Window, String, KeyMask) -> TwoD a (Maybe a))
 -> TwoD a (Maybe a))
-> ((Window, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Window) (TwoD a (Maybe a))
-> ((Window, String, KeyMask) -> TwoD a (Maybe a))
-> (Window, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Window) a
-> ((Window, String, KeyMask) -> a)
-> (Window, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Window) (TwoD a (Maybe a))
searchKeyMap (Window, 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (String
"#faff69", String
"black")
         else (String, String) -> X (String, String)
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 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 :: Window -> Bool -> X (String, String)
fromClassName Window
w Bool
active = Query String -> Window -> X String
forall a. Query a -> Window -> X a
runQuery Query String
className Window
w X String -> (String -> X (String, String)) -> X (String, String)
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)
-> Window
-> 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 Window
w Bool
active =
    do String
classname <- Query String -> Window -> X String
forall a. Query a -> Window -> X a
runQuery Query String
className Window
w
       if Bool
active
         then (String, String) -> X (String, String)
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 (String, String) -> X (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word8, Word8, Word8) -> String
rgbToHex ((Word8, Word8, Word8) -> String)
-> (Word8, Word8, Word8) -> String
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
                  (Double -> (Word8, Word8, Word8))
-> Double -> (Word8, Word8, Word8)
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
'#'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 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 (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)
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 (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
    Window
rootw <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    Rectangle
scr <- (XState -> Rectangle) -> X Rectangle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Rectangle) -> X Rectangle)
-> (XState -> Rectangle) -> X Rectangle
forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (XState -> ScreenDetail) -> XState -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> ScreenDetail)
-> (XState
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Screen String (Layout Window) Window 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 Window) Window ScreenId ScreenDetail
 -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
    Window
win <- IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ Display
-> Screen
-> Window
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Window
mkUnmanagedWindow Display
dpy (Display -> Screen
defaultScreenOfDisplay Display
dpy) Window
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)
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ()
mapWindow Display
dpy Window
win
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
selectInput Display
dpy Window
win (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
keyPressMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonReleaseMask)
    CInt
status <- IO CInt -> X CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO CInt -> X CInt) -> IO CInt -> X CInt
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Bool -> CInt -> CInt -> Window -> IO CInt
grabKeyboard Display
dpy Window
win Bool
True CInt
grabModeAsync CInt
grabModeAsync Window
currentTime
    IO CInt -> X CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO CInt -> X CInt) -> IO CInt -> X CInt
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> Bool
-> Window
-> CInt
-> CInt
-> Window
-> Window
-> Window
-> IO CInt
grabPointer Display
dpy Window
win Bool
True Window
buttonReleaseMask CInt
grabModeAsync CInt
grabModeAsync Window
none Window
none Window
currentTime
    XMonadFont
font <- String -> X XMonadFont
initXMF (GSConfig a -> String
forall a. GSConfig a -> String
gs_font GSConfig a
gsconfig)
    let screenWidth :: Integer
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 :: Integer
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
    Maybe a
selectedElement <- if CInt
status CInt -> CInt -> Bool
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 = (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 :: Integer
restrictX = Double -> Integer
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 :: Integer
restrictY = Double -> Integer
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 :: Integer
originPosX = Double -> Integer
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 :: Integer
originPosY = Double -> Integer
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 :: [TwoDPosition]
coords = Integer -> Integer -> Integer -> Integer -> [TwoDPosition]
diamondRestrict Integer
restrictX Integer
restrictY Integer
originPosX Integer
originPosY
                                s :: TwoDState a
s = TwoDState :: forall a.
TwoDPosition
-> [TwoDPosition]
-> [(String, a)]
-> GSConfig a
-> XMonadFont
-> Integer
-> Integer
-> Window
-> String
-> TwoDElementMap a
-> TwoDState a
TwoDState { td_curpos :: TwoDPosition
td_curpos = [TwoDPosition] -> TwoDPosition
forall a. [a] -> a
head [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 :: Window
td_drawingWin = Window
win,
                                                td_searchString :: String
td_searchString = String
"",
                                                td_elementmap :: TwoDElementMap a
td_elementmap = [] }
                            TwoDElementMap a
m <- TwoDState a -> X (TwoDElementMap a)
forall a. TwoDState a -> X (TwoDElementMap a)
generateElementmap TwoDState a
s
                            TwoD a (Maybe a) -> TwoDState a -> X (Maybe a)
forall a1 a. TwoD a1 a -> TwoDState a1 -> X a
evalTwoD (TwoD a ()
forall a. TwoD a ()
updateAllElements TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GSConfig a -> TwoD a (Maybe a)
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
                          Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
      Display -> Window -> IO ()
unmapWindow Display
dpy Window
win
      Display -> Window -> IO ()
destroyWindow Display
dpy Window
win
      Display -> Window -> IO ()
ungrabPointer Display
dpy Window
currentTime
      Display -> Bool -> IO ()
sync Display
dpy Bool
False
    XMonadFont -> X ()
releaseXMF XMonadFont
font
    Maybe a -> X (Maybe a)
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 Window -> X (Maybe Window)
gridselectWindow GSConfig Window
gsconf = X [(String, Window)]
windowMap X [(String, Window)]
-> ([(String, Window)] -> X (Maybe Window)) -> X (Maybe Window)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GSConfig Window -> [(String, Window)] -> X (Maybe Window)
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig Window
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 :: (Window -> X ()) -> GSConfig Window -> X ()
withSelectedWindow Window -> X ()
callback GSConfig Window
conf = do
    Maybe Window
mbWindow <- GSConfig Window -> X (Maybe Window)
gridselectWindow GSConfig Window
conf
    Maybe Window -> (Window -> X ()) -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Window
mbWindow Window -> X ()
callback

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

decorateName' :: Window -> X String
decorateName' :: Window -> X String
decorateName' Window
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
<$> Window -> X NamedWindow
getName Window
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
-> GSConfig a
forall a.
Integer
-> Integer
-> Integer
-> (a -> Bool -> X (String, String))
-> String
-> TwoD a (Maybe a)
-> Rearranger a
-> Double
-> Double
-> String
-> 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"

-- | Brings selected window to the current workspace.
bringSelected :: GSConfig Window -> X ()
bringSelected :: GSConfig Window -> X ()
bringSelected = (Window -> X ()) -> GSConfig Window -> X ()
withSelectedWindow ((Window -> X ()) -> GSConfig Window -> X ())
-> (Window -> X ()) -> GSConfig Window -> X ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> X ()
windows (Window
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
bringWindow Window
w)
    Window -> X ()
XMonad.focus Window
w
    (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> X ()
windows StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window 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 Window -> X ()
goToSelected = (Window -> X ()) -> GSConfig Window -> X ()
withSelectedWindow ((Window -> X ()) -> GSConfig Window -> X ())
-> (Window -> X ()) -> GSConfig Window -> X ()
forall a b. (a -> b) -> a -> b
$ (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Window) Window ScreenId ScreenDetail
  -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
 -> X ())
-> (Window
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> Window
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window 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 (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
    Maybe (X ())
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 Maybe (X ())
selectedActionM of
        Just X ()
selectedAction -> X ()
selectedAction
        Maybe (X ())
Nothing -> () -> X ()
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 Window) Window ScreenId ScreenDetail
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> X ()
gridselectWorkspace GSConfig String
conf String
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
viewFunc = GSConfig String -> (String -> X ()) -> X ()
gridselectWorkspace' GSConfig String
conf ((StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Window) Window ScreenId ScreenDetail
  -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
 -> X ())
-> (String
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> String
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window 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 Window) Window ScreenId ScreenDetail
 -> X ())
-> X ()
forall a.
(StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> X a)
-> X a
withWindowSet ((StackSet String (Layout Window) Window ScreenId ScreenDetail
  -> X ())
 -> X ())
-> (StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> X ())
-> X ()
forall a b. (a -> b) -> a -> b
$ \StackSet String (Layout Window) Window ScreenId ScreenDetail
ws -> do
    let wss :: [String]
wss = (Workspace String (Layout Window) Window -> String)
-> [Workspace String (Layout Window) Window] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Workspace String (Layout Window) Window -> String
forall i l a. Workspace i l a -> i
W.tag ([Workspace String (Layout Window) Window] -> [String])
-> [Workspace String (Layout Window) Window] -> [String]
forall a b. (a -> b) -> a -> b
$ StackSet String (Layout Window) Window ScreenId ScreenDetail
-> [Workspace String (Layout Window) Window]
forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden StackSet String (Layout Window) Window ScreenId ScreenDetail
ws [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
forall a. [a] -> [a] -> [a]
++ (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Workspace String (Layout Window) Window)
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> [Workspace String (Layout Window) Window]
forall a b. (a -> b) -> [a] -> [b]
map Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Screen String (Layout Window) Window 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 Window) Window ScreenId ScreenDetail
ws Screen String (Layout Window) Window ScreenId ScreenDetail
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
-> [Screen String (Layout Window) Window ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: StackSet String (Layout Window) Window ScreenId ScreenDetail
-> [Screen String (Layout Window) Window 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 Window) Window 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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
        r String
s  [(String, a)]
xs | String
s String -> [String] -> 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 (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
                | Bool
otherwise           = [(String, a)] -> m [(String, 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