{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Module: WildBind.X11.Internal.GrabMan
-- Description: internal key grab manager
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. Package users should not rely on this.__
--
-- 'GrabMan' is a \"grab manager\". It manages the state of key grabs.
--
-- Of course X11 server itself manages key grabs. The reason why we
-- need 'GrabMan' is that the input symbols for X11 FrontEnd do not
-- map one-to-one to X11 'GrabField's. For example, @(press $ ctrl xK_x)@
-- actually corresponds to multiple 'GrabField's, each with a different
-- 'Xlib.KeyMask'. In addition, @(release $ ctrl xK_x)@ has exactly the
-- same set of 'GrabField's as @(press $ ctrl xK_x)@. For each possible
-- 'GrabField', we need to grab it if and only if there is at least
-- one grabbed input symbol for the 'GrabField'.
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)

-- | Unit of key grabs in X11. X server manages state of key grabs
-- independently for each 'GrabField'.
type GrabField = (Xlib.KeySym, Xlib.KeyMask)

-- | High-level grab state. For each 'GrabField', the 'M.Map' value is
-- non-empty set of input symbols (type @k@) currently grabbed.
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
                             )

-- | Grab operation. Either \"set grab\" or \"unset grab\".
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

-- | The key grab manager.
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)

-- | Create a new 'GrabMan'.
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)

-- | Pure version of 'modify'.
modifyGM :: (XKeyInput k, Ord k) => GrabOp -> k -> GrabMan k
         -> (GrabMan k, [GrabField])
         -- ^ the next state of 'GrabMan', and the list of
         -- 'GrabField's which needs modifying with the X server.
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 the grab state. The modification operation is specified by
-- 'GrabOp'. It controls grabs of the X server if necessary.
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