-- Module for intercepting key presses not explicity mapped in the key bindings.
-- This uses some deep magic with grabKey and windows and everything else, but
-- it makes window-specific key bindings awesome!
module Rahm.Desktop.RebindKeys
  ( remapHook,
    disableKey,
    remapKey,
    sendKeyQ,
    sendKey,
    rebindKey,
    WindowHook (..),
  )
where

import Control.Applicative ((<|>))
import Control.Monad (forM, forM_)
import Control.Monad.Trans.Class (lift)
import Data.Default (def)
import Data.Map (Map)
import qualified Data.Map as Map
  ( delete,
    findWithDefault,
    fromListWith,
    insert,
    lookup,
  )
import Data.Monoid (All (..))
import Rahm.Desktop.Keys.Grab (KeySymOrKeyCode (..), doGrab, getKeyCodesForKeysym)
import XMonad
  ( Default (def),
    Display,
    Event (KeyEvent, ev_event_type, ev_keycode, ev_state, ev_window),
    ExtensionClass (initialValue),
    KeyCode,
    KeyMask,
    KeySym,
    MonadReader (ask),
    Query (..),
    Window,
    X,
    XConf (XConf, display, theRoot),
    allocaXEvent,
    displayKeycodes,
    extraModifiers,
    grabKey,
    grabModeAsync,
    io,
    keyPress,
    keyPressMask,
    keyRelease,
    keyReleaseMask,
    keycodeToKeysym,
    liftX,
    noSymbol,
    none,
    sendEvent,
    setEventType,
    setKeyEvent,
    (.|.),
  )
import qualified XMonad.Util.ExtensibleState as XS (get, modify)

type WindowHook = Query ()

newtype InterceptState
  = InterceptState (Map (KeyMask, KeySymOrKeyCode) (X ()))

newtype RemapState
  = RemapState (Map (Window, (KeyMask, KeySymOrKeyCode)) (X ()))

instance ExtensionClass InterceptState where
  initialValue = InterceptState def

instance ExtensionClass RemapState where
  initialValue = RemapState def

remapHook :: Event -> X All
remapHook event = do
  RemapState map <- XS.get

  case event of
    KeyEvent {ev_window = win, ev_event_type = typ, ev_keycode = code, ev_state = m}
      | typ == keyPress -> do
        XConf {display = dpy, theRoot = rootw} <- ask
        keysym <- io $ keycodeToKeysym dpy code 0

        case Map.lookup (win, (m, Kc code)) map
          <|> Map.lookup (win, (m, Ks keysym)) map of
          Just xdo -> do
            xdo
            return (All False)
          Nothing -> return (All True)
    _ -> return (All True)

disableKey :: (KeyMask, KeySym) -> WindowHook
disableKey key = remapKey (fmap Ks key) (return ())

remapKey :: (KeyMask, KeySymOrKeyCode) -> X () -> WindowHook
remapKey keyFrom action = do
  window <- ask
  Query $
    lift $ do
      XConf {display = disp, theRoot = rootw} <- ask
      doGrab disp window keyFrom

      XS.modify $ \(RemapState keyMap) ->
        RemapState $
          Map.insert (window, keyFrom) action keyMap

-- sendKey, but as a query.
sendKeyQ :: (KeyMask, KeySym) -> Query ()
sendKeyQ key = do
  win <- ask
  liftX (sendKey key win)

sendKey :: (KeyMask, KeySym) -> Window -> X ()
sendKey (keymask, keysym) w = do
  XConf {display = disp, theRoot = rootw} <- ask

  codes <- io $ getKeyCodesForKeysym disp keysym

  case codes of
    (keycode : _) ->
      io $
        allocaXEvent $ \xEv -> do
          setEventType xEv keyPress
          setKeyEvent xEv w rootw none keymask keycode True
          sendEvent disp w True keyPressMask xEv

          setEventType xEv keyRelease
          sendEvent disp w True keyReleaseMask xEv
    _ -> return ()

rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook
rebindKey keyFrom keyTo =
  (remapKey (fmap Ks keyFrom) . sendKey keyTo) =<< ask