{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, TupleSections #-}
module XMonad.Actions.GridSelect (
GSConfig(..),
def,
TwoDPosition,
buildDefaultGSConfig,
gridselect,
gridselectWindow,
withSelectedWindow,
bringSelected,
goToSelected,
gridselectWorkspace,
gridselectWorkspace',
spawnSelected,
runSelectedAction,
HasColorizer(defaultColorizer),
fromClassName,
stringColorizer,
colorRangeFromClassName,
stringToRatio,
TwoD,
makeXEventhandler,
shadowWithKeymap,
defaultNavigation,
substringSearch,
navNSearch,
setPos,
move,
moveNext, movePrev,
select,
cancel,
transformSearchString,
Rearranger,
noRearranger,
searchStringRearrangerGenerator,
TwoDState,
) where
import Control.Arrow ((***))
import Data.Bits
import Data.Ord (comparing)
import Control.Monad.State
import Data.List as L
import qualified Data.Map as M
import XMonad hiding (liftX)
import XMonad.Prelude
import XMonad.Util.Font
import XMonad.Prompt (mkUnmanagedWindow)
import XMonad.StackSet as W
import XMonad.Layout.Decoration
import XMonad.Util.NamedWindows
import XMonad.Actions.WindowBringer (bringWindow)
import Text.Printf
import System.Random (mkStdGen, randomR)
import Data.Word (Word8)
import qualified Data.List.NonEmpty as NE
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,
forall a. GSConfig a -> Bool
gs_cancelOnEmptyClick :: Bool
}
class HasColorizer a where
defaultColorizer :: a -> Bool -> X (String, String)
instance HasColorizer Window where
defaultColorizer :: Word64 -> Bool -> X (String, String)
defaultColorizer = Word64 -> Bool -> X (String, String)
fromClassName
instance HasColorizer String where
defaultColorizer :: String -> Bool -> X (String, String)
defaultColorizer = String -> Bool -> X (String, String)
stringColorizer
instance {-# OVERLAPPABLE #-} HasColorizer a where
defaultColorizer :: a -> Bool -> X (String, String)
defaultColorizer a
_ Bool
isFg =
let getColor :: XConfig l -> String
getColor = if Bool
isFg then XConfig l -> String
forall (l :: * -> *). XConfig l -> String
focusedBorderColor else XConfig l -> String
forall (l :: * -> *). XConfig l -> String
normalBorderColor
in (XConf -> (String, String)) -> X (String, String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> (String, String)) -> X (String, String))
-> (XConf -> (String, String)) -> X (String, String)
forall a b. (a -> b) -> a -> b
$ (, String
"black") (String -> (String, String))
-> (XConf -> String) -> XConf -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConfig Layout -> String
forall (l :: * -> *). XConfig l -> String
getColor (XConfig Layout -> String)
-> (XConf -> XConfig Layout) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config
instance HasColorizer a => Default (GSConfig a) where
def :: GSConfig a
def = (a -> Bool -> X (String, String)) -> GSConfig a
forall a. (a -> Bool -> X (String, String)) -> GSConfig a
buildDefaultGSConfig a -> Bool -> X (String, String)
forall a. HasColorizer a => a -> Bool -> X (String, String)
defaultColorizer
type TwoDPosition = (Integer, Integer)
type TwoDElementMap a = [(TwoDPosition,(String,a))]
data TwoDState a = TwoDState { forall a. TwoDState a -> TwoDPosition
td_curpos :: TwoDPosition
, forall a. TwoDState a -> [TwoDPosition]
td_availSlots :: [TwoDPosition]
, forall a. TwoDState a -> [(String, a)]
td_elements :: [(String,a)]
, forall a. TwoDState a -> GSConfig a
td_gsconfig :: GSConfig a
, forall a. TwoDState a -> XMonadFont
td_font :: XMonadFont
, forall a. TwoDState a -> Integer
td_paneX :: Integer
, forall a. TwoDState a -> Integer
td_paneY :: Integer
, forall a. TwoDState a -> Word64
td_drawingWin :: Window
, forall a. TwoDState a -> String
td_searchString :: String
, forall a. TwoDState a -> TwoDElementMap a
td_elementmap :: TwoDElementMap a
}
generateElementmap :: TwoDState a -> X (TwoDElementMap a)
generateElementmap :: forall a. TwoDState a -> X (TwoDElementMap a)
generateElementmap TwoDState a
s = do
rearrangedElements <- Rearranger a
rearranger String
searchString [(String, a)]
sortedElements
return $ zip positions rearrangedElements
where
TwoDState {td_availSlots :: forall a. TwoDState a -> [TwoDPosition]
td_availSlots = [TwoDPosition]
positions,
td_gsconfig :: forall a. TwoDState a -> GSConfig a
td_gsconfig = GSConfig a
gsconfig,
td_searchString :: forall a. TwoDState a -> String
td_searchString = String
searchString} = TwoDState a
s
GSConfig {gs_rearranger :: forall a. GSConfig a -> Rearranger a
gs_rearranger = Rearranger a
rearranger} = GSConfig a
gsconfig
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)
sortedElements :: [(String, a)]
sortedElements = String -> [(String, a)] -> [(String, a)]
forall a. String -> [(String, a)] -> [(String, a)]
orderElementmap String
searchString [(String, a)]
filteredElements
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
orderElementmap :: String -> [(String,a)] -> [(String,a)]
orderElementmap :: forall a. String -> [(String, a)] -> [(String, a)]
orderElementmap String
searchString [(String, a)]
elements = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
searchString then [(String, a)]
sortedElements else [(String, a)]
elements
where
upper :: String -> String
upper = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper
calcScore :: (String, b) -> (Int, (String, b))
calcScore (String, b)
element = ( [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String
upper String
searchString)) (String -> [String]
forall a. [a] -> [[a]]
tails (String -> [String])
-> ((String, b) -> String) -> (String, b) -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
upper (String -> String)
-> ((String, b) -> String) -> (String, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, b) -> String
forall a b. (a, b) -> a
fst ((String, b) -> [String]) -> (String, b) -> [String]
forall a b. (a -> b) -> a -> b
$ (String, b)
element)
, (String, b)
element)
compareScore :: (Int, (String, b)) -> (Int, (String, b)) -> Ordering
compareScore = ((Int, (String, b)) -> (Int, String))
-> (Int, (String, b)) -> (Int, (String, b)) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Int
score, (String
str,b
_)) -> (Int
score, String
str))
sortedElements :: [(String, a)]
sortedElements = ((Int, (String, a)) -> (String, a))
-> [(Int, (String, a))] -> [(String, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (String, a)) -> (String, a)
forall a b. (a, b) -> b
snd ([(Int, (String, a))] -> [(String, a)])
-> ([(Int, (String, a))] -> [(Int, (String, a))])
-> [(Int, (String, a))]
-> [(String, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (String, a)) -> (Int, (String, a)) -> Ordering)
-> [(Int, (String, a))] -> [(Int, (String, a))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int, (String, a)) -> (Int, (String, a)) -> Ordering
forall {b}. (Int, (String, b)) -> (Int, (String, b)) -> Ordering
compareScore ([(Int, (String, a))] -> [(String, a)])
-> [(Int, (String, a))] -> [(String, a)]
forall a b. (a -> b) -> a -> b
$ ((String, a) -> (Int, (String, a)))
-> [(String, a)] -> [(Int, (String, a))]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> (Int, (String, a))
forall {b}. (String, b) -> (Int, (String, b))
calcScore [(String, a)]
elements
newtype TwoD a b = TwoD { forall a b. TwoD a b -> StateT (TwoDState a) X b
unTwoD :: StateT (TwoDState a) X b }
deriving ((forall a b. (a -> b) -> TwoD a a -> TwoD a b)
-> (forall a b. a -> TwoD a b -> TwoD a a) -> Functor (TwoD a)
forall a b. a -> TwoD a b -> TwoD a a
forall a b. (a -> b) -> TwoD a a -> TwoD a b
forall a a b. a -> TwoD a b -> TwoD a a
forall a a b. (a -> b) -> TwoD a a -> TwoD a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a a b. (a -> b) -> TwoD a a -> TwoD a b
fmap :: forall a b. (a -> b) -> TwoD a a -> TwoD a b
$c<$ :: forall a a b. a -> TwoD a b -> TwoD a a
<$ :: forall a b. a -> TwoD a b -> TwoD a a
Functor, Functor (TwoD a)
Functor (TwoD a) =>
(forall a. a -> TwoD a a)
-> (forall a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b)
-> (forall a b c.
(a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c)
-> (forall a b. TwoD a a -> TwoD a b -> TwoD a b)
-> (forall a b. TwoD a a -> TwoD a b -> TwoD a a)
-> Applicative (TwoD a)
forall a. Functor (TwoD a)
forall a. a -> TwoD a a
forall a a. a -> TwoD a a
forall a b. TwoD a a -> TwoD a b -> TwoD a a
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
forall a a b. TwoD a a -> TwoD a b -> TwoD a a
forall a a b. TwoD a a -> TwoD a b -> TwoD a b
forall a a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
forall a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
forall a a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a a. a -> TwoD a a
pure :: forall a. a -> TwoD a a
$c<*> :: forall a a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
<*> :: forall a b. TwoD a (a -> b) -> TwoD a a -> TwoD a b
$cliftA2 :: forall a a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
liftA2 :: forall a b c. (a -> b -> c) -> TwoD a a -> TwoD a b -> TwoD a c
$c*> :: forall a a b. TwoD a a -> TwoD a b -> TwoD a b
*> :: forall a b. TwoD a a -> TwoD a b -> TwoD a b
$c<* :: forall a a b. TwoD a a -> TwoD a b -> TwoD a a
<* :: forall a b. TwoD a a -> TwoD a b -> TwoD a a
Applicative, Applicative (TwoD a)
Applicative (TwoD a) =>
(forall a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b)
-> (forall a b. TwoD a a -> TwoD a b -> TwoD a b)
-> (forall a. a -> TwoD a a)
-> Monad (TwoD a)
forall a. Applicative (TwoD a)
forall a. a -> TwoD a a
forall a a. a -> TwoD a a
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
forall a a b. TwoD a a -> TwoD a b -> TwoD a b
forall a a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
>>= :: forall a b. TwoD a a -> (a -> TwoD a b) -> TwoD a b
$c>> :: forall a a b. TwoD a a -> TwoD a b -> TwoD a b
>> :: forall a b. TwoD a a -> TwoD a b -> TwoD a b
$creturn :: forall a a. a -> TwoD a a
return :: forall a. a -> TwoD a a
Monad, MonadState (TwoDState a))
liftX :: X a1 -> TwoD a a1
liftX :: forall a1 a. X a1 -> TwoD a a1
liftX = StateT (TwoDState a) X a1 -> TwoD a a1
forall a b. StateT (TwoDState a) X b -> TwoD a b
TwoD (StateT (TwoDState a) X a1 -> TwoD a a1)
-> (X a1 -> StateT (TwoDState a) X a1) -> X a1 -> TwoD a a1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X a1 -> StateT (TwoDState a) X a1
forall (m :: * -> *) a. Monad m => m a -> StateT (TwoDState a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
evalTwoD :: TwoD a1 a -> TwoDState a1 -> X a
evalTwoD :: forall a1 a. TwoD a1 a -> TwoDState a1 -> X a
evalTwoD TwoD a1 a
m TwoDState a1
s = (StateT (TwoDState a1) X a -> TwoDState a1 -> X a)
-> TwoDState a1 -> StateT (TwoDState a1) X a -> X a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (TwoDState a1) X a -> TwoDState a1 -> X a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT TwoDState a1
s (StateT (TwoDState a1) X a -> X a)
-> StateT (TwoDState a1) X a -> X a
forall a b. (a -> b) -> a -> b
$ TwoD a1 a -> StateT (TwoDState a1) X a
forall a b. TwoD a b -> StateT (TwoDState a) X b
unTwoD TwoD a1 a
m
diamondLayer :: (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer :: forall a. (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer a
0 = [(a
0,a
0)]
diamondLayer a
n =
let tr :: [(a, a)]
tr = [ (a
x,a
na -> a -> a
forall a. Num a => a -> a -> a
-a
x) | a
x <- [a
0..a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1] ]
r :: [(a, a)]
r = [(a, a)]
tr [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ ((a, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
x,a
y) -> (a
y,-a
x)) [(a, a)]
tr
in [(a, a)]
r [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ ((a, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a
forall a. Num a => a -> a
negate (a -> a) -> (a -> a) -> (a, a) -> (a, a)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> a
forall a. Num a => a -> a
negate) [(a, a)]
r
diamond :: (Enum a, Num a, Eq a) => Stream (a, a)
diamond :: forall a. (Enum a, Num a, Eq a) => Stream (a, a)
diamond = [Item (Stream (a, a))] -> Stream (a, a)
forall l. IsList l => [Item l] -> l
fromList ([Item (Stream (a, a))] -> Stream (a, a))
-> [Item (Stream (a, a))] -> Stream (a, a)
forall a b. (a -> b) -> a -> b
$ (a -> [(a, a)]) -> [a] -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [(a, a)]
forall a. (Enum a, Num a, Eq a) => a -> [(a, a)]
diamondLayer [a
0..]
diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [(Integer, Integer)]
diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [TwoDPosition]
diamondRestrict Integer
x Integer
y Integer
originX Integer
originY =
(TwoDPosition -> Bool) -> [TwoDPosition] -> [TwoDPosition]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\(Integer
x',Integer
y') -> Integer -> Integer
forall a. Num a => a -> a
abs Integer
x' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
x Bool -> Bool -> Bool
&& Integer -> Integer
forall a. Num a => a -> a
abs Integer
y' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
y) ([TwoDPosition] -> [TwoDPosition])
-> (Stream TwoDPosition -> [TwoDPosition])
-> Stream TwoDPosition
-> [TwoDPosition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(TwoDPosition -> TwoDPosition) -> [TwoDPosition] -> [TwoDPosition]
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
x', Integer
y') -> (Integer
x' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
originX, Integer
y' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
originY)) ([TwoDPosition] -> [TwoDPosition])
-> (Stream TwoDPosition -> [TwoDPosition])
-> Stream TwoDPosition
-> [TwoDPosition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> Stream TwoDPosition -> [TwoDPosition]
forall a. Int -> Stream a -> [a]
takeS Int
1000 (Stream TwoDPosition -> [TwoDPosition])
-> Stream TwoDPosition -> [TwoDPosition]
forall a b. (a -> b) -> a -> b
$ Stream TwoDPosition
forall a. (Enum a, Num a, Eq a) => Stream (a, a)
diamond
findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b)
findInElementMap :: forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap a
pos = ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
pos) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)
drawWinBox :: Window -> XMonadFont -> (String, String) -> String -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()
drawWinBox :: Word64
-> XMonadFont
-> (String, String)
-> String
-> Integer
-> Integer
-> String
-> Integer
-> Integer
-> Integer
-> X ()
drawWinBox Word64
win XMonadFont
font (String
fg,String
bg) String
bc Integer
ch Integer
cw String
text Integer
x Integer
y Integer
cp =
(Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
gc <- IO GC -> X GC
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GC -> X GC) -> IO GC -> X GC
forall a b. (a -> b) -> a -> b
$ Display -> Word64 -> IO GC
createGC Display
dpy Word64
win
bordergc <- liftIO $ createGC dpy win
liftIO $ do
Just fgcolor <- initColor dpy fg
Just bgcolor <- initColor dpy bg
Just bordercolor <- initColor dpy bc
setForeground dpy gc fgcolor
setBackground dpy gc bgcolor
setForeground dpy bordergc bordercolor
fillRectangle dpy win gc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
stext <- shrinkWhile (shrinkIt shrinkText)
(\String
n -> do size <- IO Int -> X Int
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> X Int) -> IO Int -> X Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
font String
n
return $ size > fromInteger (cw-(2*cp)))
text
(asc,desc) <- liftIO $ textExtentsXMF font stext
let offset = ((Integer
ch Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position
asc Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
desc)) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Position -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
asc
printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+offset)) stext
liftIO $ freeGC dpy gc
liftIO $ freeGC dpy bordergc
updateAllElements :: TwoD a ()
updateAllElements :: forall a. TwoD a ()
updateAllElements =
do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
updateElements (td_elementmap s)
grayoutElements :: Int -> TwoD a ()
grayoutElements :: forall a. Int -> TwoD a ()
grayoutElements Int
skip =
do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
updateElementsWithColorizer grayOnly $ drop skip (td_elementmap s)
where grayOnly :: p -> p -> m (String, String)
grayOnly p
_ p
_ = (String, String) -> m (String, String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#808080", String
"#808080")
updateElements :: TwoDElementMap a -> TwoD a ()
updateElements :: forall a. TwoDElementMap a -> TwoD a ()
updateElements TwoDElementMap a
elementmap = do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
updateElementsWithColorizer (gs_colorizer (td_gsconfig s)) elementmap
updateElementsWithColorizer :: (a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer :: forall a.
(a -> Bool -> X (String, String)) -> TwoDElementMap a -> TwoD a ()
updateElementsWithColorizer a -> Bool -> X (String, String)
colorizer TwoDElementMap a
elementmap = do
TwoDState { td_curpos = curpos,
td_drawingWin = win,
td_gsconfig = gsconfig,
td_font = font,
td_paneX = paneX,
td_paneY = paneY} <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
let cellwidth = GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellwidth GSConfig a
gsconfig
cellheight = GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellheight GSConfig a
gsconfig
paneX' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div (Integer
paneXInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
cellwidth) Integer
2
paneY' = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div (Integer
paneYInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
cellheight) Integer
2
updateElement (pos :: TwoDPosition
pos@(Integer
x,Integer
y),(String
text, a
element)) = X () -> TwoD a ()
forall a1 a. X a1 -> TwoD a a1
liftX (X () -> TwoD a ()) -> X () -> TwoD a ()
forall a b. (a -> b) -> a -> b
$ do
colors <- a -> Bool -> X (String, String)
colorizer a
element (TwoDPosition
pos TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
== TwoDPosition
curpos)
drawWinBox win font
colors
(gs_bordercolor gsconfig)
cellheight
cellwidth
text
(paneX'+x*cellwidth)
(paneY'+y*cellheight)
(gs_cellpadding gsconfig)
mapM_ updateElement elementmap
stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
stdHandle :: forall a. Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)
stdHandle ButtonEvent{ ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_x :: Event -> CInt
ev_x = CInt
x, ev_y :: Event -> CInt
ev_y = CInt
y } TwoD a (Maybe a)
contEventloop
| Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
buttonRelease = do
s@TwoDState{ td_paneX = px
, td_paneY = py
, td_gsconfig = GSConfig{ gs_cellheight = ch
, gs_cellwidth = cw
, gs_cancelOnEmptyClick = cancelOnEmptyClick
}
} <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
let gridX = (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
px Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
cw) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
cw
gridY = (CInt -> Integer
forall a b. (Integral a, Num b) => a -> b
fi CInt
y Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (Integer
py Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
ch) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
ch
case lookup (gridX,gridY) (td_elementmap s) of
Just (String
_,a
el) -> Maybe a -> TwoD a (Maybe a)
forall a. a -> TwoD a a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
el)
Maybe (String, a)
Nothing -> if Bool
cancelOnEmptyClick
then Maybe a -> TwoD a (Maybe a)
forall a. a -> TwoD a a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
else TwoD a (Maybe a)
contEventloop
| Bool
otherwise = TwoD a (Maybe a)
contEventloop
stdHandle ExposeEvent{} TwoD a (Maybe a)
contEventloop = TwoD a ()
forall a. TwoD a ()
updateAllElements TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
contEventloop
stdHandle Event
_ TwoD a (Maybe a)
contEventloop = TwoD a (Maybe a)
contEventloop
makeXEventhandler :: ((KeySym, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler :: forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (Word64, String, KeyMask) -> TwoD a (Maybe a)
keyhandler = (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a. (a -> a) -> a
fix ((TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a))
-> (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ \TwoD a (Maybe a)
me -> TwoD a (TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (TwoD a (TwoD a (Maybe a)) -> TwoD a (Maybe a))
-> TwoD a (TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ X (TwoD a (Maybe a)) -> TwoD a (TwoD a (Maybe a))
forall a1 a. X a1 -> TwoD a a1
liftX (X (TwoD a (Maybe a)) -> TwoD a (TwoD a (Maybe a)))
-> X (TwoD a (Maybe a)) -> TwoD a (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ (Display -> X (TwoD a (Maybe a))) -> X (TwoD a (Maybe a))
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (TwoD a (Maybe a))) -> X (TwoD a (Maybe a)))
-> (Display -> X (TwoD a (Maybe a))) -> X (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO (TwoD a (Maybe a)) -> X (TwoD a (Maybe a))
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TwoD a (Maybe a)) -> X (TwoD a (Maybe a)))
-> IO (TwoD a (Maybe a)) -> X (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO (TwoD a (Maybe a))) -> IO (TwoD a (Maybe a))
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (TwoD a (Maybe a))) -> IO (TwoD a (Maybe a)))
-> (XEventPtr -> IO (TwoD a (Maybe a))) -> IO (TwoD a (Maybe a))
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
Display -> Word64 -> XEventPtr -> IO ()
maskEvent Display
d (Word64
exposureMask Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
keyPressMask Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
buttonReleaseMask) XEventPtr
e
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
if ev_event_type ev == keyPress
then do
(_, s) <- lookupString $ asKeyEvent e
ks <- keycodeToKeysym d (ev_keycode ev) 0
return $ do
mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)
keyhandler (ks, s, mask)
else
return $ stdHandle ev me
shadowWithKeymap :: M.Map (KeyMask, KeySym) a -> ((KeySym, String, KeyMask) -> a) -> (KeySym, String, KeyMask) -> a
shadowWithKeymap :: forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) a
keymap (Word64, String, KeyMask) -> a
dflt keyEvent :: (Word64, String, KeyMask)
keyEvent@(Word64
ks,String
_,KeyMask
m') = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe ((Word64, String, KeyMask) -> a
dflt (Word64, String, KeyMask)
keyEvent) ((KeyMask, Word64) -> Map (KeyMask, Word64) a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
m',Word64
ks) Map (KeyMask, Word64) a
keymap)
select :: TwoD a (Maybe a)
select :: forall a. TwoD a (Maybe a)
select = do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
return $ snd . snd <$> findInElementMap (td_curpos s) (td_elementmap s)
cancel :: TwoD a (Maybe a)
cancel :: forall a. TwoD a (Maybe a)
cancel = Maybe a -> TwoD a (Maybe a)
forall a. a -> TwoD a a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
setPos :: (Integer, Integer) -> TwoD a ()
setPos :: forall a. TwoDPosition -> TwoD a ()
setPos TwoDPosition
newPos = do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
let elmap = TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
newSelectedEl = TwoDPosition
-> TwoDElementMap a -> Maybe (TwoDPosition, (String, a))
forall a b. Eq a => a -> [(a, b)] -> Maybe (a, b)
findInElementMap TwoDPosition
newPos (TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s)
oldPos = TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos TwoDState a
s
when (isJust newSelectedEl && newPos /= oldPos) $ do
put s { td_curpos = newPos }
updateElements (catMaybes [findInElementMap oldPos elmap, newSelectedEl])
move :: (Integer, Integer) -> TwoD a ()
move :: forall a. TwoDPosition -> TwoD a ()
move (Integer
dx,Integer
dy) = do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
let (x,y) = td_curpos s
newPos = (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
dx,Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
dy)
setPos newPos
moveNext :: TwoD a ()
moveNext :: forall a. TwoD a ()
moveNext = do
position <- (TwoDState a -> TwoDPosition) -> TwoD a TwoDPosition
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos
elems <- gets td_elementmap
let n = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
m = case ((TwoDPosition, (String, a)) -> Bool)
-> TwoDElementMap a -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(TwoDPosition, (String, a))
p -> (TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a, b) -> a
fst (TwoDPosition, (String, a))
p TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
== TwoDPosition
position) TwoDElementMap a
elems of
Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
Just Int
k | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
| Bool
otherwise -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
whenJust m $ \Int
i ->
TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
setPos ((TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a, b) -> a
fst ((TwoDPosition, (String, a)) -> TwoDPosition)
-> (TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a -> b) -> a -> b
$ TwoDElementMap a
elems TwoDElementMap a -> Int -> (TwoDPosition, (String, a))
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
movePrev :: TwoD a ()
movePrev :: forall a. TwoD a ()
movePrev = do
position <- (TwoDState a -> TwoDPosition) -> TwoD a TwoDPosition
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwoDState a -> TwoDPosition
forall a. TwoDState a -> TwoDPosition
td_curpos
elems <- gets td_elementmap
let n = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TwoDElementMap a
elems
m = case ((TwoDPosition, (String, a)) -> Bool)
-> TwoDElementMap a -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(TwoDPosition, (String, a))
p -> (TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a, b) -> a
fst (TwoDPosition, (String, a))
p TwoDPosition -> TwoDPosition -> Bool
forall a. Eq a => a -> a -> Bool
== TwoDPosition
position) TwoDElementMap a
elems of
Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
Just Int
0 -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
Just Int
k -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
whenJust m $ \Int
i ->
TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
setPos ((TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a, b) -> a
fst ((TwoDPosition, (String, a)) -> TwoDPosition)
-> (TwoDPosition, (String, a)) -> TwoDPosition
forall a b. (a -> b) -> a -> b
$ TwoDElementMap a
elems TwoDElementMap a -> Int -> (TwoDPosition, (String, a))
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
transformSearchString :: (String -> String) -> TwoD a ()
transformSearchString :: forall a. (String -> String) -> TwoD a ()
transformSearchString String -> String
f = do
s <- TwoD a (TwoDState a)
forall s (m :: * -> *). MonadState s m => m s
get
let oldSearchString = TwoDState a -> String
forall a. TwoDState a -> String
td_searchString TwoDState a
s
newSearchString = String -> String
f String
oldSearchString
when (newSearchString /= oldSearchString) $ do
let s' = TwoDState a
s { td_searchString = newSearchString }
m <- liftX $ generateElementmap s'
let s'' = TwoDState a
s' { td_elementmap = m }
oldLen = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TwoDElementMap a -> Int) -> TwoDElementMap a -> Int
forall a b. (a -> b) -> a -> b
$ TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s
newLen = TwoDElementMap a -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TwoDElementMap a -> Int) -> TwoDElementMap a -> Int
forall a b. (a -> b) -> a -> b
$ TwoDState a -> TwoDElementMap a
forall a. TwoDState a -> TwoDElementMap a
td_elementmap TwoDState a
s''
when (newLen < oldLen) $ grayoutElements newLen
put s''
updateAllElements
defaultNavigation :: TwoD a (Maybe a)
defaultNavigation :: forall a. TwoD a (Maybe a)
defaultNavigation = ((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Word64) (TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> (Word64, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
forall {a}. Map (KeyMask, Word64) (TwoD a (Maybe a))
navKeyMap (Word64, String, KeyMask) -> TwoD a (Maybe a)
forall {b} {a}. b -> TwoD a (Maybe a)
navDefaultHandler
where navKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
navKeyMap = [((KeyMask, Word64), TwoD a (Maybe a))]
-> Map (KeyMask, Word64) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
((KeyMask
0,Word64
xK_Escape) , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
cancel)
,((KeyMask
0,Word64
xK_Return) , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
select)
,((KeyMask
0,Word64
xK_slash) , TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a. TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_Left) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_h) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_Right) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_l) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_Down) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_j) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_Up) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_k) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_Tab) , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_n) , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
shiftMask,Word64
xK_Tab), TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
,((KeyMask
0,Word64
xK_p) , TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation)
]
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
navNSearch :: TwoD a (Maybe a)
navNSearch :: forall a. TwoD a (Maybe a)
navNSearch = ((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Word64) (TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> (Word64, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
forall {a}. Map (KeyMask, Word64) (TwoD a (Maybe a))
navNSearchKeyMap (Word64, String, KeyMask) -> TwoD a (Maybe a)
forall {a} {c} {a}. (a, String, c) -> TwoD a (Maybe a)
navNSearchDefaultHandler
where navNSearchKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
navNSearchKeyMap = [((KeyMask, Word64), TwoD a (Maybe a))]
-> Map (KeyMask, Word64) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
((KeyMask
0,Word64
xK_Escape) , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
cancel)
,((KeyMask
0,Word64
xK_Return) , TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
select)
,((KeyMask
0,Word64
xK_Left) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (-Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
,((KeyMask
0,Word64
xK_Right) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
1,Integer
0) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
,((KeyMask
0,Word64
xK_Down) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
,((KeyMask
0,Word64
xK_Up) , TwoDPosition -> TwoD a ()
forall a. TwoDPosition -> TwoD a ()
move (Integer
0,-Integer
1) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
,((KeyMask
0,Word64
xK_Tab) , TwoD a ()
forall a. TwoD a ()
moveNext TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
,((KeyMask
shiftMask,Word64
xK_Tab), TwoD a ()
forall a. TwoD a ()
movePrev TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
,((KeyMask
0,Word64
xK_BackSpace), (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (\String
s -> if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else String -> String
forall a. HasCallStack => [a] -> [a]
init String
s) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
navNSearch)
]
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
substringSearch :: TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch :: forall a. TwoD a (Maybe a) -> TwoD a (Maybe a)
substringSearch TwoD a (Maybe a)
returnNavigation = (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a. (a -> a) -> a
fix ((TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a))
-> (TwoD a (Maybe a) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ \TwoD a (Maybe a)
me ->
let searchKeyMap :: Map (KeyMask, Word64) (TwoD a (Maybe a))
searchKeyMap = [((KeyMask, Word64), TwoD a (Maybe a))]
-> Map (KeyMask, Word64) (TwoD a (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
((KeyMask
0,Word64
xK_Escape) , (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (String -> String -> String
forall a b. a -> b -> a
const String
"") TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
returnNavigation)
,((KeyMask
0,Word64
xK_Return) , TwoD a (Maybe a)
returnNavigation)
,((KeyMask
0,Word64
xK_BackSpace), (String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (\String
s -> if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else String -> String
forall a. HasCallStack => [a] -> [a]
init String
s) TwoD a () -> TwoD a (Maybe a) -> TwoD a (Maybe a)
forall a b. TwoD a a -> TwoD a b -> TwoD a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TwoD a (Maybe a)
me)
]
searchDefaultHandler :: (a, String, c) -> TwoD a (Maybe a)
searchDefaultHandler (a
_,String
s,c
_) = do
(String -> String) -> TwoD a ()
forall a. (String -> String) -> TwoD a ()
transformSearchString (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
TwoD a (Maybe a)
me
in ((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
forall a.
((Word64, String, KeyMask) -> TwoD a (Maybe a)) -> TwoD a (Maybe a)
makeXEventhandler (((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> TwoD a (Maybe a)
forall a b. (a -> b) -> a -> b
$ Map (KeyMask, Word64) (TwoD a (Maybe a))
-> ((Word64, String, KeyMask) -> TwoD a (Maybe a))
-> (Word64, String, KeyMask)
-> TwoD a (Maybe a)
forall a.
Map (KeyMask, Word64) a
-> ((Word64, String, KeyMask) -> a)
-> (Word64, String, KeyMask)
-> a
shadowWithKeymap Map (KeyMask, Word64) (TwoD a (Maybe a))
searchKeyMap (Word64, String, KeyMask) -> TwoD a (Maybe a)
forall {a} {c}. (a, String, c) -> TwoD a (Maybe a)
searchDefaultHandler
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."
stringColorizer :: String -> Bool -> X (String, String)
stringColorizer :: String -> Bool -> X (String, String)
stringColorizer String
s Bool
active =
let seed :: Int -> Integer
seed Int
x = Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x)(Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
s) :: Integer
(Double
r,Double
g,Double
b) = (Integer, Double, Double) -> (Double, Double, Double)
forall a. Fractional a => (Integer, a, a) -> (a, a, a)
hsv2rgb (Int -> Integer
seed Int
83 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
360,
Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
seed Int
191 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1000)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2500Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
0.4,
Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
seed Int
121 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1000)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2500Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
0.4)
in if Bool
active
then (String, String) -> X (String, String)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#faff69", String
"black")
else (String, String) -> X (String, String)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Double -> String) -> [Double] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Word8 -> String
twodigitHex(Word8 -> String) -> (Double -> Word8) -> Double -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round :: Double -> Word8)(Double -> Word8) -> (Double -> Double) -> Double -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
256)) [Double
r, Double
g, Double
b], String
"white")
fromClassName :: Window -> Bool -> X (String, String)
fromClassName :: Word64 -> Bool -> X (String, String)
fromClassName Word64
w Bool
active = Query String -> Word64 -> X String
forall a. Query a -> Word64 -> X a
runQuery Query String
className Word64
w X String -> (String -> X (String, String)) -> X (String, String)
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Bool -> X (String, String))
-> Bool -> String -> X (String, String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Bool -> X (String, String)
forall a. HasColorizer a => a -> Bool -> X (String, String)
defaultColorizer Bool
active
twodigitHex :: Word8 -> String
twodigitHex :: Word8 -> String
twodigitHex = String -> Word8 -> String
forall r. PrintfType r => String -> r
printf String
"%02x"
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)
-> (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> (Word8, Word8, Word8)
-> Word64
-> Bool
-> X (String, String)
colorRangeFromClassName (Word8, Word8, Word8)
startC (Word8, Word8, Word8)
endC (Word8, Word8, Word8)
activeC (Word8, Word8, Word8)
inactiveT (Word8, Word8, Word8)
activeT Word64
w Bool
active =
do classname <- Query String -> Word64 -> X String
forall a. Query a -> Word64 -> X a
runQuery Query String
className Word64
w
if active
then return (rgbToHex activeC, rgbToHex activeT)
else return (rgbToHex $ mix startC endC
$ stringToRatio classname, rgbToHex inactiveT)
where rgbToHex :: (Word8, Word8, Word8) -> String
rgbToHex :: (Word8, Word8, Word8) -> String
rgbToHex (Word8
r, Word8
g, Word8
b) = Char
'#'Char -> String -> String
forall a. a -> [a] -> [a]
:Word8 -> String
twodigitHex Word8
r
String -> String -> String
forall a. [a] -> [a] -> [a]
++Word8 -> String
twodigitHex Word8
gString -> String -> String
forall a. [a] -> [a] -> [a]
++Word8 -> String
twodigitHex Word8
b
mix :: (Word8, Word8, Word8) -> (Word8, Word8, Word8)
-> Double -> (Word8, Word8, Word8)
mix :: (Word8, Word8, Word8)
-> (Word8, Word8, Word8) -> Double -> (Word8, Word8, Word8)
mix (Word8
r1, Word8
g1, Word8
b1) (Word8
r2, Word8
g2, Word8
b2) Double
r = (Word8 -> Word8 -> Word8
forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
r1 Word8
r2, Word8 -> Word8 -> Word8
forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
g1 Word8
g2, Word8 -> Word8 -> Word8
forall {b} {a} {a}.
(Integral b, Integral a, Integral a) =>
a -> a -> b
mix' Word8
b1 Word8
b2)
where mix' :: a -> a -> b
mix' a
a a
b = Double -> b
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> b) -> Double -> b
forall a b. (a -> b) -> a -> b
$ (a -> Double
forall a b. (Integral a, Num b) => a -> b
fi a
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
r) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (a -> Double
forall a b. (Integral a, Num b) => a -> b
fi a
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r))
stringToRatio :: String -> Double
stringToRatio :: String -> Double
stringToRatio String
"" = Double
0
stringToRatio String
s = let gen :: StdGen
gen = Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ (Int -> Char -> Int) -> Int -> String -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
t Char
c -> Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
31 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) Int
0 String
s
in (Double, StdGen) -> Double
forall a b. (a, b) -> a
fst ((Double, StdGen) -> Double) -> (Double, StdGen) -> Double
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> StdGen -> (Double, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
forall g. RandomGen g => (Double, Double) -> g -> (Double, g)
randomR (Double
0, Double
1) StdGen
gen
gridselect :: GSConfig a -> [(String,a)] -> X (Maybe a)
gridselect :: forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig a
_ [] = Maybe a -> X (Maybe a)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
gridselect GSConfig a
gsconfig [(String, a)]
elements =
(Display -> X (Maybe a)) -> X (Maybe a)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Maybe a)) -> X (Maybe a))
-> (Display -> X (Maybe a)) -> X (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
rootw <- (XConf -> Word64) -> X Word64
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Word64
theRoot
scr <- gets $ screenRect . W.screenDetail . W.current . windowset
win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
(rect_x scr) (rect_y scr) (rect_width scr) (rect_height scr)
liftIO $ mapWindow dpy win
liftIO $ selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask)
status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
void $ io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime
font <- initXMF (gs_font gsconfig)
let screenWidth = Dimension -> Integer
forall a. Integral a => a -> Integer
toInteger (Dimension -> Integer) -> Dimension -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_width Rectangle
scr
screenHeight = Dimension -> Integer
forall a. Integral a => a -> Integer
toInteger (Dimension -> Integer) -> Dimension -> Integer
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
scr
selectedElement <- if status == grabSuccess then do
let restriction Integer
ss GSConfig a -> Integer
cs = (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
ssDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Integer -> Double
forall a. Num a => Integer -> a
fromInteger (GSConfig a -> Integer
cs GSConfig a
gsconfig)Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
1)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2 :: Double
restrictX = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
screenWidth GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellwidth
restrictY = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> (GSConfig a -> Integer) -> Double
restriction Integer
screenHeight GSConfig a -> Integer
forall a. GSConfig a -> Integer
gs_cellheight
originPosX = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ (GSConfig a -> Double
forall a. GSConfig a -> Double
gs_originFractX GSConfig a
gsconfig Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
restrictX
originPosY = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ (GSConfig a -> Double
forall a. GSConfig a -> Double
gs_originFractY GSConfig a
gsconfig Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
restrictY
coords = Integer -> Integer -> Integer -> Integer -> [TwoDPosition]
diamondRestrict Integer
restrictX Integer
restrictY Integer
originPosX Integer
originPosY
s = TwoDState { td_curpos :: TwoDPosition
td_curpos = NonEmpty TwoDPosition -> TwoDPosition
forall a. NonEmpty a -> a
NE.head ([TwoDPosition] -> NonEmpty TwoDPosition
forall a. HasCallStack => [a] -> NonEmpty a
notEmpty [TwoDPosition]
coords),
td_availSlots :: [TwoDPosition]
td_availSlots = [TwoDPosition]
coords,
td_elements :: [(String, a)]
td_elements = [(String, a)]
elements,
td_gsconfig :: GSConfig a
td_gsconfig = GSConfig a
gsconfig,
td_font :: XMonadFont
td_font = XMonadFont
font,
td_paneX :: Integer
td_paneX = Integer
screenWidth,
td_paneY :: Integer
td_paneY = Integer
screenHeight,
td_drawingWin :: Word64
td_drawingWin = Word64
win,
td_searchString :: String
td_searchString = String
"",
td_elementmap :: TwoDElementMap a
td_elementmap = [] }
m <- generateElementmap s
evalTwoD (updateAllElements >> gs_navigate gsconfig)
(s { td_elementmap = m })
else
return Nothing
liftIO $ do
unmapWindow dpy win
destroyWindow dpy win
ungrabPointer dpy currentTime
sync dpy False
releaseXMF font
return selectedElement
gridselectWindow :: GSConfig Window -> X (Maybe Window)
gridselectWindow :: GSConfig Word64 -> X (Maybe Word64)
gridselectWindow GSConfig Word64
gsconf = X [(String, Word64)]
windowMap X [(String, Word64)]
-> ([(String, Word64)] -> X (Maybe Word64)) -> X (Maybe Word64)
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GSConfig Word64 -> [(String, Word64)] -> X (Maybe Word64)
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig Word64
gsconf
withSelectedWindow :: (Window -> X ()) -> GSConfig Window -> X ()
withSelectedWindow :: (Word64 -> X ()) -> GSConfig Word64 -> X ()
withSelectedWindow Word64 -> X ()
callback GSConfig Word64
conf = do
mbWindow <- GSConfig Word64 -> X (Maybe Word64)
gridselectWindow GSConfig Word64
conf
for_ mbWindow callback
windowMap :: X [(String,Window)]
windowMap :: X [(String, Word64)]
windowMap = do
ws <- (XState
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
windowset
mapM keyValuePair (W.allWindows ws)
where keyValuePair :: Word64 -> X (String, Word64)
keyValuePair Word64
w = (, Word64
w) (String -> (String, Word64)) -> X String -> X (String, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> X String
decorateName' Word64
w
decorateName' :: Window -> X String
decorateName' :: Word64 -> X String
decorateName' Word64
w = do
NamedWindow -> String
forall a. Show a => a -> String
show (NamedWindow -> String) -> X NamedWindow -> X String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> X NamedWindow
getName Word64
w
buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a
buildDefaultGSConfig :: forall a. (a -> Bool -> X (String, String)) -> GSConfig a
buildDefaultGSConfig a -> Bool -> X (String, String)
col = Integer
-> Integer
-> Integer
-> (a -> Bool -> X (String, String))
-> String
-> TwoD a (Maybe a)
-> Rearranger a
-> Double
-> Double
-> String
-> Bool
-> GSConfig a
forall a.
Integer
-> Integer
-> Integer
-> (a -> Bool -> X (String, String))
-> String
-> TwoD a (Maybe a)
-> Rearranger a
-> Double
-> Double
-> String
-> Bool
-> GSConfig a
GSConfig Integer
50 Integer
130 Integer
10 a -> Bool -> X (String, String)
col String
"xft:Sans-8" TwoD a (Maybe a)
forall a. TwoD a (Maybe a)
defaultNavigation Rearranger a
forall a. Rearranger a
noRearranger (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) String
"white" Bool
True
bringSelected :: GSConfig Window -> X ()
bringSelected :: GSConfig Word64 -> X ()
bringSelected = (Word64 -> X ()) -> GSConfig Word64 -> X ()
withSelectedWindow ((Word64 -> X ()) -> GSConfig Word64 -> X ())
-> (Word64 -> X ()) -> GSConfig Word64 -> X ()
forall a b. (a -> b) -> a -> b
$ \Word64
w -> do
(StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows (Word64
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
bringWindow Word64
w)
Word64 -> X ()
XMonad.focus Word64
w
(StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.shiftMaster
goToSelected :: GSConfig Window -> X ()
goToSelected :: GSConfig Word64 -> X ()
goToSelected = (Word64 -> X ()) -> GSConfig Word64 -> X ()
withSelectedWindow ((Word64 -> X ()) -> GSConfig Word64 -> X ())
-> (Word64 -> X ()) -> GSConfig Word64 -> X ()
forall a b. (a -> b) -> a -> b
$ (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ())
-> (Word64
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> Word64
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
forall s a i l sd.
(Eq s, Eq a, Eq i) =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.focusWindow
spawnSelected :: GSConfig String -> [String] -> X ()
spawnSelected :: GSConfig String -> [String] -> X ()
spawnSelected GSConfig String
conf [String]
lst = GSConfig String -> [(String, String)] -> X (Maybe String)
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig String
conf ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
lst [String]
lst) X (Maybe String) -> (Maybe String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> (String -> X ()) -> X ())
-> (String -> X ()) -> Maybe String -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe String -> (String -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn
runSelectedAction :: GSConfig (X ()) -> [(String, X ())] -> X ()
runSelectedAction :: GSConfig (X ()) -> [(String, X ())] -> X ()
runSelectedAction GSConfig (X ())
conf [(String, X ())]
actions = do
selectedActionM <- GSConfig (X ()) -> [(String, X ())] -> X (Maybe (X ()))
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig (X ())
conf [(String, X ())]
actions
case selectedActionM of
Just X ()
selectedAction -> X ()
selectedAction
Maybe (X ())
Nothing -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
gridselectWorkspace :: GSConfig WorkspaceId ->
(WorkspaceId -> WindowSet -> WindowSet) -> X ()
gridselectWorkspace :: GSConfig String
-> (String
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
gridselectWorkspace GSConfig String
conf String
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
viewFunc = GSConfig String -> (String -> X ()) -> X ()
gridselectWorkspace' GSConfig String
conf ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ()
windows ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> X ())
-> (String
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail)
-> String
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
viewFunc)
gridselectWorkspace' :: GSConfig WorkspaceId -> (WorkspaceId -> X ()) -> X ()
gridselectWorkspace' :: GSConfig String -> (String -> X ()) -> X ()
gridselectWorkspace' GSConfig String
conf String -> X ()
func = (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> X ())
-> X ()
forall a.
(StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> X a)
-> X a
withWindowSet ((StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> X ())
-> X ())
-> (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> X ())
-> X ()
forall a b. (a -> b) -> a -> b
$ \StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws -> do
let wss :: [String]
wss = (Workspace String (Layout Word64) Word64 -> String)
-> [Workspace String (Layout Word64) Word64] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Workspace String (Layout Word64) Word64 -> String
forall i l a. Workspace i l a -> i
W.tag ([Workspace String (Layout Word64) Word64] -> [String])
-> [Workspace String (Layout Word64) Word64] -> [String]
forall a b. (a -> b) -> a -> b
$ StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> [Workspace String (Layout Word64) Word64]
forall i l a sid sd. StackSet i l a sid sd -> [Workspace i l a]
W.hidden StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws [Workspace String (Layout Word64) Word64]
-> [Workspace String (Layout Word64) Word64]
-> [Workspace String (Layout Word64) Word64]
forall a. [a] -> [a] -> [a]
++ (Screen String (Layout Word64) Word64 ScreenId ScreenDetail
-> Workspace String (Layout Word64) Word64)
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
-> [Workspace String (Layout Word64) Word64]
forall a b. (a -> b) -> [a] -> [b]
map Screen String (Layout Word64) Word64 ScreenId ScreenDetail
-> Workspace String (Layout Word64) Word64
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> Screen String (Layout Word64) Word64 ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws Screen String (Layout Word64) Word64 ScreenId ScreenDetail
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
-> [Screen String (Layout Word64) Word64 ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible StackSet String (Layout Word64) Word64 ScreenId ScreenDetail
ws)
GSConfig String -> [(String, String)] -> X (Maybe String)
forall a. GSConfig a -> [(String, a)] -> X (Maybe a)
gridselect GSConfig String
conf ([String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
wss [String]
wss) X (Maybe String) -> (Maybe String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> (String -> X ()) -> X ())
-> (String -> X ()) -> Maybe String -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe String -> (String -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust String -> X ()
func
type Rearranger a = String -> [(String, a)] -> X [(String, a)]
noRearranger :: Rearranger a
noRearranger :: forall a. Rearranger a
noRearranger String
_ = [(String, a)] -> X [(String, a)]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return
searchStringRearrangerGenerator :: (String -> a) -> Rearranger a
searchStringRearrangerGenerator :: forall a. (String -> a) -> Rearranger a
searchStringRearrangerGenerator String -> a
f =
let r :: String -> [(String, a)] -> m [(String, a)]
r String
"" [(String, a)]
xs = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
r String
s [(String, a)]
xs | String
s String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> String
forall a b. (a, b) -> a
fst [(String, a)]
xs = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, a)]
xs
| Bool
otherwise = [(String, a)] -> m [(String, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, a)] -> m [(String, a)])
-> [(String, a)] -> m [(String, a)]
forall a b. (a -> b) -> a -> b
$ [(String, a)]
xs [(String, a)] -> [(String, a)] -> [(String, a)]
forall a. [a] -> [a] -> [a]
++ [(String
s, String -> a
f String
s)]
in String -> [(String, a)] -> X [(String, a)]
forall {m :: * -> *}.
Monad m =>
String -> [(String, a)] -> m [(String, a)]
r