{-# 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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GrabField -> GrabbedInputs k -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member GrabField
field GrabbedInputs k
inputs
    new_inputs :: GrabbedInputs k
new_inputs = (Set k -> Set k -> Set k)
-> GrabField -> Set k -> GrabbedInputs k -> GrabbedInputs k
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
S.union GrabField
field (k -> Set k
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 GrabField -> GrabbedInputs k -> Maybe (Set k)
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 = k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
S.delete k
key Set k
cur_grabbed
                              removed :: Bool
removed = Set k
new_grabbed Set k -> Set k -> Bool
forall a. Eq a => a -> a -> Bool
== Set k
forall a. Monoid a => a
mempty
                          in ( if Bool
removed
                               then GrabField -> GrabbedInputs k -> GrabbedInputs k
forall k a. Ord k => k -> Map k a -> Map k a
M.delete GrabField
field GrabbedInputs k
inputs
                               else GrabField -> Set k -> GrabbedInputs k -> GrabbedInputs k
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
(GrabOp -> GrabOp -> Bool)
-> (GrabOp -> GrabOp -> Bool) -> Eq GrabOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GrabOp -> GrabOp -> Bool
== :: GrabOp -> GrabOp -> Bool
$c/= :: GrabOp -> GrabOp -> Bool
/= :: GrabOp -> GrabOp -> Bool
Eq, Eq GrabOp
Eq GrabOp =>
(GrabOp -> GrabOp -> Ordering)
-> (GrabOp -> GrabOp -> Bool)
-> (GrabOp -> GrabOp -> Bool)
-> (GrabOp -> GrabOp -> Bool)
-> (GrabOp -> GrabOp -> Bool)
-> (GrabOp -> GrabOp -> GrabOp)
-> (GrabOp -> GrabOp -> GrabOp)
-> Ord 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
$ccompare :: GrabOp -> GrabOp -> Ordering
compare :: GrabOp -> GrabOp -> Ordering
$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
>= :: GrabOp -> GrabOp -> Bool
$cmax :: GrabOp -> GrabOp -> GrabOp
max :: GrabOp -> GrabOp -> GrabOp
$cmin :: GrabOp -> GrabOp -> GrabOp
min :: GrabOp -> GrabOp -> GrabOp
Ord, Int -> GrabOp -> ShowS
[GrabOp] -> ShowS
GrabOp -> String
(Int -> GrabOp -> ShowS)
-> (GrabOp -> String) -> ([GrabOp] -> ShowS) -> Show GrabOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GrabOp -> ShowS
showsPrec :: Int -> GrabOp -> ShowS
$cshow :: GrabOp -> String
show :: GrabOp -> String
$cshowList :: [GrabOp] -> ShowS
showList :: [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   -> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
forall k.
Ord k =>
GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
insertG
  GrabOp
DoUnsetGrab -> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
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
(GrabMan k -> GrabMan k -> Bool)
-> (GrabMan k -> GrabMan k -> Bool) -> Eq (GrabMan k)
forall k. Eq k => GrabMan k -> GrabMan k -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: GrabMan k -> GrabMan k -> Bool
Eq, Eq (GrabMan k)
Eq (GrabMan k) =>
(GrabMan k -> GrabMan k -> Ordering)
-> (GrabMan k -> GrabMan k -> Bool)
-> (GrabMan k -> GrabMan k -> Bool)
-> (GrabMan k -> GrabMan k -> Bool)
-> (GrabMan k -> GrabMan k -> Bool)
-> (GrabMan k -> GrabMan k -> GrabMan k)
-> (GrabMan k -> GrabMan k -> GrabMan k)
-> Ord (GrabMan k)
GrabMan k -> GrabMan k -> Bool
GrabMan k -> GrabMan k -> Ordering
GrabMan k -> GrabMan k -> GrabMan k
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
$ccompare :: forall k. Ord k => GrabMan k -> GrabMan k -> Ordering
compare :: GrabMan k -> GrabMan k -> Ordering
$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
>= :: GrabMan k -> GrabMan k -> Bool
$cmax :: forall k. Ord k => GrabMan k -> GrabMan k -> GrabMan k
max :: GrabMan k -> GrabMan k -> GrabMan k
$cmin :: forall k. Ord k => GrabMan k -> GrabMan k -> GrabMan k
min :: GrabMan k -> GrabMan k -> GrabMan k
Ord, Int -> GrabMan k -> ShowS
[GrabMan k] -> ShowS
GrabMan k -> String
(Int -> GrabMan k -> ShowS)
-> (GrabMan k -> String)
-> ([GrabMan k] -> ShowS)
-> Show (GrabMan k)
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
$cshowsPrec :: forall k. Show k => Int -> GrabMan k -> ShowS
showsPrec :: Int -> GrabMan k -> ShowS
$cshow :: forall k. Show k => GrabMan k -> String
show :: GrabMan k -> String
$cshowList :: forall k. Show k => [GrabMan k] -> ShowS
showList :: [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 = GrabMan k -> IO (IORef (GrabMan k))
forall a. a -> IO (IORef a)
newIORef (GrabMan k -> IO (IORef (GrabMan k)))
-> GrabMan k -> IO (IORef (GrabMan k))
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 = GrabbedInputs k
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 <- Word64 -> NonEmpty Word64
forall a. a -> NonEmpty a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> NonEmpty Word64) -> Word64 -> NonEmpty Word64
forall a b. (a -> b) -> a -> b
$ k -> Word64
forall k. XKeyInput k => k -> Word64
toKeySym k
k
  CUInt
modmask <- KeyMaskMap -> k -> NonEmpty CUInt
forall k. XKeyInput k => KeyMaskMap -> k -> NonEmpty CUInt
toModifierMasks KeyMaskMap
kmmap k
k
  GrabField -> NonEmpty GrabField
forall a. a -> NonEmpty a
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 = (GrabField -> (GrabMan k, [GrabField]) -> (GrabMan k, [GrabField]))
-> (GrabMan k, [GrabField])
-> NonEmpty GrabField
-> (GrabMan k, [GrabField])
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
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 = KeyMaskMap -> k -> NonEmpty GrabField
forall k. XKeyInput k => KeyMaskMap -> k -> NonEmpty GrabField
grabFieldsFor (GrabMan k -> KeyMaskMap
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) = GrabOp
-> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
forall k.
Ord k =>
GrabOp
-> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)
modifyG GrabOp
op GrabField
field k
input (GrabbedInputs k -> (GrabbedInputs k, Bool))
-> GrabbedInputs k -> (GrabbedInputs k, Bool)
forall a b. (a -> b) -> a -> b
$ GrabMan k -> GrabbedInputs k
forall k. GrabMan k -> GrabbedInputs k
gmGrabbedInputs GrabMan k
cur_gm
        new_gm :: GrabMan k
new_gm = GrabMan k
cur_gm { gmGrabbedInputs = new_gi }
        new_changed :: [GrabField]
new_changed = if Bool
modified then (GrabField
field GrabField -> [GrabField] -> [GrabField]
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 <- IORef (GrabMan k) -> IO (GrabMan k)
forall a. IORef a -> IO a
readIORef IORef (GrabMan k)
gm_ref
  let (GrabMan k
new_gm, [GrabField]
changed_fields) = GrabOp -> k -> GrabMan k -> (GrabMan k, [GrabField])
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 = GrabMan k -> Display
forall k. GrabMan k -> Display
gmDisplay GrabMan k
cur_gm
      rwin :: Word64
rwin = GrabMan k -> Word64
forall k. GrabMan k -> Word64
gmRootWindow GrabMan k
cur_gm
  IORef (GrabMan k) -> GrabMan k -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (GrabMan k)
gm_ref GrabMan k
new_gm
  [GrabField] -> (GrabField -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GrabField]
changed_fields ((GrabField -> IO ()) -> IO ()) -> (GrabField -> IO ()) -> IO ()
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