{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module WildBind.X11.Internal.GrabMan
( GrabMan
, GrabOp (..)
, new
, modify
) where
import Control.Monad (forM_)
import Data.Foldable (foldr)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as M
import Data.Monoid (Monoid (..), (<>))
import qualified Data.Set as S
import qualified Graphics.X11.Xlib as Xlib
import WildBind.X11.Internal.Key (KeyEventType (..), KeyMaskMap, XKeyEvent (..),
XKeyInput (..), press, xGrabKey, xUngrabKey)
type GrabField = (Xlib.KeySym, Xlib.KeyMask)
type GrabbedInputs k = M.Map GrabField (S.Set k)
insertG :: Ord k => GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
insertG :: forall k.
Ord k =>
GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
insertG GrabField
field k
key GrabbedInputs k
inputs = (GrabbedInputs k
new_inputs, Bool
is_new_entry)
where
is_new_entry :: Bool
is_new_entry = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Bool
M.member GrabField
field GrabbedInputs k
inputs
new_inputs :: GrabbedInputs k
new_inputs = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Ord a => Set a -> Set a -> Set a
S.union GrabField
field (forall a. a -> Set a
S.singleton k
key) GrabbedInputs k
inputs
deleteG :: Ord k => GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
deleteG :: forall k.
Ord k =>
GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
deleteG GrabField
field k
key GrabbedInputs k
inputs = (GrabbedInputs k
new_inputs, Bool
is_entry_deleted)
where
(GrabbedInputs k
new_inputs, Bool
is_entry_deleted) = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GrabField
field GrabbedInputs k
inputs of
Maybe (Set k)
Nothing -> (GrabbedInputs k
inputs, Bool
False)
Just Set k
cur_grabbed -> let new_grabbed :: Set k
new_grabbed = forall a. Ord a => a -> Set a -> Set a
S.delete k
key Set k
cur_grabbed
removed :: Bool
removed = Set k
new_grabbed forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty
in ( if Bool
removed
then forall k a. Ord k => k -> Map k a -> Map k a
M.delete GrabField
field GrabbedInputs k
inputs
else forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert GrabField
field Set k
new_grabbed GrabbedInputs k
inputs,
Bool
removed
)
data GrabOp = DoSetGrab | DoUnsetGrab deriving (GrabOp -> GrabOp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GrabOp -> GrabOp -> Bool
$c/= :: GrabOp -> GrabOp -> Bool
== :: GrabOp -> GrabOp -> Bool
$c== :: GrabOp -> GrabOp -> Bool
Eq, Eq GrabOp
GrabOp -> GrabOp -> Bool
GrabOp -> GrabOp -> Ordering
GrabOp -> GrabOp -> GrabOp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GrabOp -> GrabOp -> GrabOp
$cmin :: GrabOp -> GrabOp -> GrabOp
max :: GrabOp -> GrabOp -> GrabOp
$cmax :: GrabOp -> GrabOp -> GrabOp
>= :: GrabOp -> GrabOp -> Bool
$c>= :: GrabOp -> GrabOp -> Bool
> :: GrabOp -> GrabOp -> Bool
$c> :: GrabOp -> GrabOp -> Bool
<= :: GrabOp -> GrabOp -> Bool
$c<= :: GrabOp -> GrabOp -> Bool
< :: GrabOp -> GrabOp -> Bool
$c< :: GrabOp -> GrabOp -> Bool
compare :: GrabOp -> GrabOp -> Ordering
$ccompare :: GrabOp -> GrabOp -> Ordering
Ord, Int -> GrabOp -> ShowS
[GrabOp] -> ShowS
GrabOp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GrabOp] -> ShowS
$cshowList :: [GrabOp] -> ShowS
show :: GrabOp -> String
$cshow :: GrabOp -> String
showsPrec :: Int -> GrabOp -> ShowS
$cshowsPrec :: Int -> GrabOp -> ShowS
Show)
modifyG :: Ord k => GrabOp -> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
modifyG :: forall k.
Ord k =>
GrabOp
-> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
modifyG GrabOp
op = case GrabOp
op of
GrabOp
DoSetGrab -> forall k.
Ord k =>
GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
insertG
GrabOp
DoUnsetGrab -> forall k.
Ord k =>
GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
deleteG
data GrabMan k
= GrabMan
{ forall k. GrabMan k -> KeyMaskMap
gmKeyMaskMap :: KeyMaskMap
, forall k. GrabMan k -> Display
gmDisplay :: Xlib.Display
, forall k. GrabMan k -> Word64
gmRootWindow :: Xlib.Window
, forall k. GrabMan k -> GrabbedInputs k
gmGrabbedInputs :: GrabbedInputs k
}
deriving (GrabMan k -> GrabMan k -> Bool
forall k. Eq k => GrabMan k -> GrabMan k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GrabMan k -> GrabMan k -> Bool
$c/= :: forall k. Eq k => GrabMan k -> GrabMan k -> Bool
== :: GrabMan k -> GrabMan k -> Bool
$c== :: forall k. Eq k => GrabMan k -> GrabMan k -> Bool
Eq, GrabMan k -> GrabMan k -> Bool
GrabMan k -> GrabMan k -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {k}. Ord k => Eq (GrabMan k)
forall k. Ord k => GrabMan k -> GrabMan k -> Bool
forall k. Ord k => GrabMan k -> GrabMan k -> Ordering
forall k. Ord k => GrabMan k -> GrabMan k -> GrabMan k
min :: GrabMan k -> GrabMan k -> GrabMan k
$cmin :: forall k. Ord k => GrabMan k -> GrabMan k -> GrabMan k
max :: GrabMan k -> GrabMan k -> GrabMan k
$cmax :: forall k. Ord k => GrabMan k -> GrabMan k -> GrabMan k
>= :: GrabMan k -> GrabMan k -> Bool
$c>= :: forall k. Ord k => GrabMan k -> GrabMan k -> Bool
> :: GrabMan k -> GrabMan k -> Bool
$c> :: forall k. Ord k => GrabMan k -> GrabMan k -> Bool
<= :: GrabMan k -> GrabMan k -> Bool
$c<= :: forall k. Ord k => GrabMan k -> GrabMan k -> Bool
< :: GrabMan k -> GrabMan k -> Bool
$c< :: forall k. Ord k => GrabMan k -> GrabMan k -> Bool
compare :: GrabMan k -> GrabMan k -> Ordering
$ccompare :: forall k. Ord k => GrabMan k -> GrabMan k -> Ordering
Ord, Int -> GrabMan k -> ShowS
forall k. Show k => Int -> GrabMan k -> ShowS
forall k. Show k => [GrabMan k] -> ShowS
forall k. Show k => GrabMan k -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GrabMan k] -> ShowS
$cshowList :: forall k. Show k => [GrabMan k] -> ShowS
show :: GrabMan k -> String
$cshow :: forall k. Show k => GrabMan k -> String
showsPrec :: Int -> GrabMan k -> ShowS
$cshowsPrec :: forall k. Show k => Int -> GrabMan k -> ShowS
Show)
new :: KeyMaskMap -> Xlib.Display -> Xlib.Window -> IO (IORef (GrabMan k))
new :: forall k. KeyMaskMap -> Display -> Word64 -> IO (IORef (GrabMan k))
new KeyMaskMap
kmm Display
disp Word64
win = forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ GrabMan { gmKeyMaskMap :: KeyMaskMap
gmKeyMaskMap = KeyMaskMap
kmm,
gmDisplay :: Display
gmDisplay = Display
disp,
gmRootWindow :: Word64
gmRootWindow = Word64
win,
gmGrabbedInputs :: GrabbedInputs k
gmGrabbedInputs = forall a. Monoid a => a
mempty
}
grabFieldsFor :: XKeyInput k => KeyMaskMap -> k -> NonEmpty GrabField
grabFieldsFor :: forall k. XKeyInput k => KeyMaskMap -> k -> NonEmpty GrabField
grabFieldsFor KeyMaskMap
kmmap k
k = do
Word64
sym <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k. XKeyInput k => k -> Word64
toKeySym k
k
CUInt
modmask <- forall k. XKeyInput k => KeyMaskMap -> k -> NonEmpty CUInt
toModifierMasks KeyMaskMap
kmmap k
k
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
sym, CUInt
modmask)
modifyGM :: (XKeyInput k, Ord k) => GrabOp -> k -> GrabMan k
-> (GrabMan k, [GrabField])
modifyGM :: forall k.
(XKeyInput k, Ord k) =>
GrabOp -> k -> GrabMan k -> (GrabMan k, [GrabField])
modifyGM GrabOp
op k
input GrabMan k
gm = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GrabField -> (GrabMan k, [GrabField]) -> (GrabMan k, [GrabField])
modifySingle (GrabMan k
gm, []) NonEmpty GrabField
fields
where
fields :: NonEmpty GrabField
fields = forall k. XKeyInput k => KeyMaskMap -> k -> NonEmpty GrabField
grabFieldsFor (forall k. GrabMan k -> KeyMaskMap
gmKeyMaskMap GrabMan k
gm) k
input
modifySingle :: GrabField -> (GrabMan k, [GrabField]) -> (GrabMan k, [GrabField])
modifySingle GrabField
field (GrabMan k
cur_gm, [GrabField]
cur_changed) = (GrabMan k
new_gm, [GrabField]
new_changed)
where
(GrabbedInputs k
new_gi, Bool
modified) = forall k.
Ord k =>
GrabOp
-> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
modifyG GrabOp
op GrabField
field k
input forall a b. (a -> b) -> a -> b
$ forall k. GrabMan k -> GrabbedInputs k
gmGrabbedInputs GrabMan k
cur_gm
new_gm :: GrabMan k
new_gm = GrabMan k
cur_gm { gmGrabbedInputs :: GrabbedInputs k
gmGrabbedInputs = GrabbedInputs k
new_gi }
new_changed :: [GrabField]
new_changed = if Bool
modified then (GrabField
field forall a. a -> [a] -> [a]
: [GrabField]
cur_changed) else [GrabField]
cur_changed
modify :: (XKeyInput k, Ord k) => IORef (GrabMan k) -> GrabOp -> k -> IO ()
modify :: forall k.
(XKeyInput k, Ord k) =>
IORef (GrabMan k) -> GrabOp -> k -> IO ()
modify IORef (GrabMan k)
gm_ref GrabOp
op k
input = do
GrabMan k
cur_gm <- forall a. IORef a -> IO a
readIORef IORef (GrabMan k)
gm_ref
let (GrabMan k
new_gm, [GrabField]
changed_fields) = forall k.
(XKeyInput k, Ord k) =>
GrabOp -> k -> GrabMan k -> (GrabMan k, [GrabField])
modifyGM GrabOp
op k
input GrabMan k
cur_gm
disp :: Display
disp = forall k. GrabMan k -> Display
gmDisplay GrabMan k
cur_gm
rwin :: Word64
rwin = forall k. GrabMan k -> Word64
gmRootWindow GrabMan k
cur_gm
forall a. IORef a -> a -> IO ()
writeIORef IORef (GrabMan k)
gm_ref GrabMan k
new_gm
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GrabField]
changed_fields forall a b. (a -> b) -> a -> b
$ \(Word64
keysym, CUInt
mask) -> do
case GrabOp
op of
GrabOp
DoSetGrab -> Display -> Word64 -> Word64 -> CUInt -> IO ()
xGrabKey Display
disp Word64
rwin Word64
keysym CUInt
mask
GrabOp
DoUnsetGrab -> Display -> Word64 -> Word64 -> CUInt -> IO ()
xUngrabKey Display
disp Word64
rwin Word64
keysym CUInt
mask