{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, OverloadedStrings #-}
module WildBind.X11.Internal.Key
(
XKeyInput(..),
xKeyEventToXKeyInput,
KeyEventType(..),
KeyMaskMap(..),
getKeyMaskMap,
XKeyEvent(..),
XMod(..),
ToXKeyEvent(..),
addXMod,
press,
release,
shift,
ctrl,
alt,
super,
xGrabKey,
xUngrabKey,
xSendKeyEvent
) where
import Control.Applicative ((<$>), (<*>), (<|>))
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Maybe (MaybeT(MaybeT))
import Data.Bits ((.|.), (.&.))
import qualified Data.Bits as Bits
import Data.Foldable (foldr, fold)
import Data.List (nub)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map as M
import Data.Maybe (mapMaybe, listToMaybe)
import Data.Monoid ((<>))
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Foreign
import qualified Graphics.X11.Xlib as Xlib
import qualified Graphics.X11.Xlib.Extras as XlibE
import WildBind.Description (Describable(..))
import qualified WildBind.Input.NumPad as NumPad
data KeyEventType = KeyPress
| KeyRelease
deriving (Show,Eq,Ord,Bounded,Enum)
data KeyMaskMap =
KeyMaskMap
{ maskShift :: Xlib.KeyMask,
maskControl :: Xlib.KeyMask,
maskAlt :: Xlib.KeyMask,
maskSuper :: Xlib.KeyMask,
maskNumLock :: Xlib.KeyMask,
maskCapsLock :: Xlib.KeyMask,
maskShiftLock :: Xlib.KeyMask,
maskScrollLock :: Xlib.KeyMask
}
deriving (Show,Eq,Ord)
isMasked :: KeyMaskMap -> (KeyMaskMap -> Xlib.KeyMask) -> Xlib.KeyMask -> Bool
isMasked kmmap accessor target = if (target .&. accessor kmmap) == 0
then False
else True
class XKeyInput k where
toKeySym :: k -> Xlib.KeySym
toModifierMasks :: KeyMaskMap -> k -> NonEmpty Xlib.KeyMask
toModifierMasks _ _ = return 0
fromKeyEvent :: KeyMaskMap -> KeyEventType -> Xlib.KeySym -> Xlib.KeyMask -> Maybe k
fromKeySymDef :: (Bounded k, Enum k) => (k -> Xlib.KeySym) -> Xlib.KeySym -> Maybe k
fromKeySymDef to_conv ks = M.lookup ks $ M.fromList $ map (\n -> (to_conv n, n)) $ enumFromTo minBound maxBound
instance XKeyInput NumPad.NumPadUnlocked where
toKeySym n = case n of
NumPad.NumUp -> Xlib.xK_KP_Up
NumPad.NumDown -> Xlib.xK_KP_Down
NumPad.NumLeft -> Xlib.xK_KP_Left
NumPad.NumRight -> Xlib.xK_KP_Right
NumPad.NumHome -> Xlib.xK_KP_Home
NumPad.NumPageUp -> Xlib.xK_KP_Page_Up
NumPad.NumPageDown -> Xlib.xK_KP_Page_Down
NumPad.NumEnd -> Xlib.xK_KP_End
NumPad.NumCenter -> Xlib.xK_KP_Begin
NumPad.NumInsert -> Xlib.xK_KP_Insert
NumPad.NumDelete -> Xlib.xK_KP_Delete
NumPad.NumEnter -> Xlib.xK_KP_Enter
NumPad.NumDivide -> Xlib.xK_KP_Divide
NumPad.NumMulti -> Xlib.xK_KP_Multiply
NumPad.NumMinus -> Xlib.xK_KP_Subtract
NumPad.NumPlus -> Xlib.xK_KP_Add
fromKeyEvent _ KeyPress _ _ = Nothing
fromKeyEvent kmmask KeyRelease keysym mask = if is_numlocked
then Nothing
else fromKeySymDef toKeySym keysym
where
is_numlocked = isMasked kmmask maskNumLock mask
instance XKeyInput NumPad.NumPadLocked where
toKeySym n = case n of
NumPad.NumL0 -> Xlib.xK_KP_0
NumPad.NumL1 -> Xlib.xK_KP_1
NumPad.NumL2 -> Xlib.xK_KP_2
NumPad.NumL3 -> Xlib.xK_KP_3
NumPad.NumL4 -> Xlib.xK_KP_4
NumPad.NumL5 -> Xlib.xK_KP_5
NumPad.NumL6 -> Xlib.xK_KP_6
NumPad.NumL7 -> Xlib.xK_KP_7
NumPad.NumL8 -> Xlib.xK_KP_8
NumPad.NumL9 -> Xlib.xK_KP_9
NumPad.NumLDivide -> Xlib.xK_KP_Divide
NumPad.NumLMulti -> Xlib.xK_KP_Multiply
NumPad.NumLMinus -> Xlib.xK_KP_Subtract
NumPad.NumLPlus -> Xlib.xK_KP_Add
NumPad.NumLEnter -> Xlib.xK_KP_Enter
NumPad.NumLPeriod -> Xlib.xK_KP_Delete
toModifierMasks kmmap _ = return $ maskNumLock kmmap
fromKeyEvent _ KeyPress _ _ = Nothing
fromKeyEvent kmmap KeyRelease keysym mask =
if not $ is_num_locked
then Nothing
else if keysym == Xlib.xK_KP_Decimal
then Just NumPad.NumLPeriod
else fromKeySymDef toKeySym keysym
where
is_num_locked = isMasked kmmap maskNumLock mask
instance (XKeyInput a, XKeyInput b) => XKeyInput (Either a b) where
toKeySym = either toKeySym toKeySym
toModifierMasks kmmap = either (toModifierMasks kmmap) (toModifierMasks kmmap)
fromKeyEvent kmmap ev_type keysym mask =
(fmap Left $ fromKeyEvent kmmap ev_type keysym mask) <|> (fmap Right $ fromKeyEvent kmmap ev_type keysym mask)
xKeyEventToXKeyInput :: XKeyInput k => KeyMaskMap -> KeyEventType -> Xlib.XKeyEventPtr -> MaybeT IO k
xKeyEventToXKeyInput kmmap ev_type kev = do
keysym <- MaybeT (fst <$> Xlib.lookupString kev)
(_, _, _, _, _, _, _, status, _, _) <- liftIO $ Xlib.get_KeyEvent $ Foreign.castPtr kev
MaybeT $ return $ fromKeyEvent kmmap ev_type keysym status
type XModifierMap = [(Xlib.Modifier, [Xlib.KeyCode])]
getKeyMaskMap :: Xlib.Display -> IO KeyMaskMap
getKeyMaskMap disp = do
xmodmap <- getXModifierMap disp
let maskFor = lookupModifierKeyMask disp xmodmap
numlock_mask <- maskFor Xlib.xK_Num_Lock
capslock_mask <- maskFor Xlib.xK_Caps_Lock
shiftlock_mask <- maskFor Xlib.xK_Shift_Lock
scrolllock_mask <- maskFor Xlib.xK_Scroll_Lock
alt_mask <- maskFor Xlib.xK_Alt_L
super_mask <- maskFor Xlib.xK_Super_L
return KeyMaskMap { maskShift = Xlib.shiftMask,
maskControl = Xlib.controlMask,
maskAlt = alt_mask,
maskSuper = super_mask,
maskNumLock = numlock_mask,
maskCapsLock = capslock_mask,
maskShiftLock = shiftlock_mask,
maskScrollLock = scrolllock_mask
}
getXModifierMap :: Xlib.Display -> IO XModifierMap
getXModifierMap = XlibE.getModifierMapping
lookupModifierKeyMask :: Xlib.Display -> XModifierMap -> Xlib.KeySym -> IO Xlib.KeyMask
lookupModifierKeyMask disp xmmap keysym = do
keycode <- Xlib.keysymToKeycode disp keysym
return $ maybe 0 modifierToKeyMask $ listToMaybe $ mapMaybe (lookupXMod' keycode) xmmap
where
lookupXMod' key_code (xmod, codes) = if key_code `elem` codes
then Just xmod
else Nothing
modifierToKeyMask :: Xlib.Modifier -> Xlib.KeyMask
modifierToKeyMask = Bits.shift 1 . fromIntegral
xGrabKey :: Xlib.Display -> Xlib.Window -> Xlib.KeySym -> Xlib.KeyMask -> IO ()
xGrabKey disp win key mask = do
code <- Xlib.keysymToKeycode disp key
Xlib.grabKey disp code mask win False Xlib.grabModeAsync Xlib.grabModeAsync
xUngrabKey :: Xlib.Display -> Xlib.Window -> Xlib.KeySym -> Xlib.KeyMask -> IO ()
xUngrabKey disp win key mask = do
code <- Xlib.keysymToKeycode disp key
Xlib.ungrabKey disp code mask win
data XMod = Shift
| Ctrl
| Alt
| Super
deriving (Show,Eq,Ord,Enum,Bounded)
data XKeyEvent =
XKeyEvent
{ xKeyEventType :: KeyEventType,
xKeyEventMods :: S.Set XMod,
xKeyEventKeySym :: Xlib.KeySym
}
deriving (Show,Eq,Ord)
instance XKeyInput XKeyEvent where
toKeySym (XKeyEvent _ _ ks) = ks
toModifierMasks kmmap (XKeyEvent _ mods _) =
fmap (.|. xModsToKeyMask kmmap mods) $ lockVariations kmmap
fromKeyEvent kmmap ev_type keysym mask = Just $ XKeyEvent ev_type (keyMaskToXMods kmmap mask) keysym
class ToXKeyEvent k where
toXKeyEvent :: k -> XKeyEvent
instance ToXKeyEvent XKeyEvent where
toXKeyEvent = id
instance ToXKeyEvent Xlib.KeySym where
toXKeyEvent keysym = XKeyEvent KeyPress mempty keysym
instance (ToXKeyEvent a, ToXKeyEvent b) => ToXKeyEvent (Either a b) where
toXKeyEvent = either toXKeyEvent toXKeyEvent
instance Describable XKeyEvent where
describe (XKeyEvent ev mods keysym) = ev_txt <> T.pack (mods_str ++ Xlib.keysymToString keysym)
where
mods_str = fold $ S.map (\m -> show m ++ "+") mods
ev_txt = case ev of
KeyPress -> "press "
KeyRelease -> "release "
xModToKeyMask :: KeyMaskMap -> XMod -> Xlib.KeyMask
xModToKeyMask kmmap modi = case modi of
Shift -> maskShift kmmap
Ctrl -> maskControl kmmap
Alt -> maskAlt kmmap
Super -> maskSuper kmmap
xModsToKeyMask :: KeyMaskMap -> S.Set XMod -> Xlib.KeyMask
xModsToKeyMask kmmap = foldr f 0
where
f modi mask = xModToKeyMask kmmap modi .|. mask
lockVariations :: KeyMaskMap -> NonEmpty Xlib.KeyMask
lockVariations kmmap = toNonEmpty $ nub $ do
numl <- [0, maskNumLock kmmap]
capsl <- [0, maskCapsLock kmmap]
shiftl <- [0, maskShiftLock kmmap]
scl <- [0, maskScrollLock kmmap]
return (numl .|. capsl .|. shiftl .|. scl)
where
toNonEmpty [] = return 0
toNonEmpty (x:rest) = x :| rest
keyMaskToXMods :: KeyMaskMap -> Xlib.KeyMask -> S.Set XMod
keyMaskToXMods kmmap mask = S.fromList$ toXMod =<< [ (maskShift, Shift),
(maskControl, Ctrl),
(maskAlt, Alt),
(maskSuper, Super)
]
where
toXMod (acc, mod_symbol) = if isMasked kmmap acc mask
then [mod_symbol]
else []
addXMod :: ToXKeyEvent k => XMod -> k -> XKeyEvent
addXMod modi mkey = case toXKeyEvent mkey of
XKeyEvent ev_type mods ks -> XKeyEvent ev_type (S.insert modi mods) ks
press :: ToXKeyEvent k => k -> XKeyEvent
press k = (toXKeyEvent k) { xKeyEventType = KeyPress }
release :: ToXKeyEvent k => k -> XKeyEvent
release k = (toXKeyEvent k) { xKeyEventType = KeyRelease }
shift :: ToXKeyEvent k => k -> XKeyEvent
shift = addXMod Shift
ctrl :: ToXKeyEvent k => k -> XKeyEvent
ctrl = addXMod Ctrl
alt :: ToXKeyEvent k => k -> XKeyEvent
alt = addXMod Alt
super :: ToXKeyEvent k => k -> XKeyEvent
super = addXMod Super
xSendKeyEvent :: KeyMaskMap -> Xlib.Display -> Xlib.Window -> XKeyEvent -> IO ()
xSendKeyEvent kmmap disp target_win key_event = Xlib.allocaXEvent $ \xev -> do
setupXEvent xev
Xlib.sendEvent disp target_win propagate event_mask xev
Xlib.sync disp False
where
propagate = True
event_type = xKeyEventType key_event
event_mask = case event_type of
KeyPress -> Xlib.keyPressMask
KeyRelease -> Xlib.keyReleaseMask
xevent_type = case event_type of
KeyPress -> Xlib.keyPress
KeyRelease -> Xlib.keyRelease
setupXEvent xev = do
key_code <- Xlib.keysymToKeycode disp $ xKeyEventKeySym key_event
XlibE.setEventType xev xevent_type
XlibE.setKeyEvent xev target_win (Xlib.defaultRootWindow disp) subwindow key_mask key_code is_same_screen
subwindow = 0
is_same_screen = True
key_mask = xModsToKeyMask kmmap $ xKeyEventMods key_event