path: root/src/Rahm/Desktop/Submap.hs

module Rahm.Desktop.Submap
  ( mapNextString,
    mapNextStringWithKeysym,
    submapButtonsWithKey,
    nextButton,
    nextMotion,
    nextMotionOrButton,
    submap,
    submapDefault,
    submapDefaultWithKey,
    ButtonOrKeyEvent (..),
    nextButtonOrKeyEvent,
    getStringForKey,
    escape,
  )
where

import Control.Concurrent (threadDelay)
import Control.Exception (SomeException (SomeException), catch, finally)
import Control.Monad (when)
import Control.Monad.Fix (fix)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import Data.Aeson (Result (Error))
import Data.Bits ((.&.))
import Data.Char (toUpper)
import Data.Map (Map)
import qualified Data.Map as Map (findWithDefault, lookup)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word64)
import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
import Rahm.Desktop.Logger (logs)
import XMonad
  ( Button,
    ButtonMask,
    Display,
    Event (..),
    ExtensionClass (initialValue),
    KeyMask,
    KeySym,
    MonadReader (ask),
    StateExtension,
    Window,
    X,
    XConf (..),
    XEventPtr,
    allocaXEvent,
    asKeyEvent,
    asks,
    buttonPressMask,
    checkMaskEvent,
    cleanMask,
    currentTime,
    getEvent,
    grabKeyboard,
    grabModeAsync,
    grabPointer,
    io,
    isModifierKey,
    keyPressMask,
    keycodeToKeysym,
    keysymToKeycode,
    keysymToString,
    lookupString,
    maskEvent,
    pointerMotionMask,
    setKeyEvent,
    shiftMask,
    ungrabKeyboard,
    ungrabPointer,
    (.|.), KeyCode,
  )
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.Loggers (logSp)

newtype Escape = Escape Bool

instance ExtensionClass Escape where
  initialValue = Escape False

-- Escape a submapping. Useful for continuous submappings where a final
-- button/key should finish the mapping.
escape :: X ()
escape = XS.put (Escape True)

getEscape :: X Bool
getEscape = do
  (Escape cur) <- XS.get
  XS.put (Escape False)
  return cur

currentTimeMillis :: IO Int
currentTimeMillis = round . (* 1000) <$> getPOSIXTime

getMaskEventWithTimeout ::
  Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a)
getMaskEventWithTimeout timeout d mask fn = do
  curTime <- currentTimeMillis
  allocaXEvent $ \ptr -> do
    val <- getMaskEventWithTimeout' ptr (curTime + timeout)
    if val
      then Just <$> fn ptr
      else return Nothing
  where
    getMaskEventWithTimeout' ptr timeout = do
      curTime <- currentTimeMillis

      if curTime >= timeout
        then return False
        else do
          b <- checkMaskEvent d mask ptr
          if b
            then return True
            else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout

data ButtonOrKeyEvent
  = ButtonPress
      { event_mask :: KeyMask,
        event_button :: Button
      }
  | KeyPress
      { event_mask :: KeyMask,
        event_keysym :: KeySym,
        event_keycode :: KeyCode,
        event_string :: String
      }

nextButtonOrKeyEvent :: MaybeT X ButtonOrKeyEvent
nextButtonOrKeyEvent = do
  b <- lift getEscape
  when b (MaybeT (return Nothing))

  XConf {theRoot = root, display = d} <- ask

  ret <-
    MaybeT $
      io $
        ( do
            grabKeyboard d root False grabModeAsync grabModeAsync currentTime
            grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
            fix
              ( \tryAgain ->
                  do
                    ret <-
                      getMaskEventWithTimeout 5000 d (keyPressMask .|. buttonPressMask) $ \p -> do
                        ev <- getEvent p
                        case ev of
                          ButtonEvent {ev_button = b, ev_state = m} ->
                            return $ ButtonPress m b
                          KeyEvent {ev_keycode = code, ev_state = m} -> do
                            keysym <- keycodeToKeysym d code 0
                            (_, str) <- lookupString (asKeyEvent p)
                            return $ KeyPress m keysym code str
                    case ret of
                      Just (KeyPress m sym _ str) | isModifierKey sym -> tryAgain
                      x -> return x
              )
        )
          `finally` ( do
                        ungrabKeyboard d currentTime
                        ungrabPointer d currentTime
                    )

  m' <- lift $ cleanMask (event_mask ret)
  return ret {event_mask = m'}

{-
 - Like submap fram XMonad.Actions.Submap, but sends the string from
 - XLookupString to the function along side the keysym.
 -
 - This function allows mappings where the mapped string might be important,
 - but also allows submappings for keys that may not have a character associated
 - with them (for example, the function keys).
 -}
mapNextStringWithKeysym ::
  (KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a
mapNextStringWithKeysym fn = do
  XConf {theRoot = root, display = d} <- ask
  io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime

  ret <- io $
    fix $ \nextkey -> do
      ret <-
        getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do
          KeyEvent {ev_keycode = code, ev_state = m} <- getEvent p
          keysym <- keycodeToKeysym d code 0
          (_, str) <- lookupString (asKeyEvent p)
          return (m, str, keysym)

      case ret of
        Just (m, str, keysym) ->
          if isModifierKey keysym
            then nextkey
            else return ret
        Nothing -> return Nothing

  io $ ungrabKeyboard d currentTime

  (m', str, keysym) <- MaybeT $ return ret
  m <- lift $ cleanMask m'
  fn m keysym str

-- getStringForKey :: (KeyMask, KeySym) -> X String
-- getStringForKey (m, sym) = do
--   d <- asks display
--   io $
--     allocaXEvent
--       ( \xev -> do
--           kc <- keysymToKeycode d sym
--           setKeyEvent xev 0 0 0 m kc False
--           (_, str) <- lookupString (asKeyEvent xev)
--           return str
--       )
--       `catch` ( \e -> do
--                   putStrLn $ "Error in getStringForKey: " ++ show (e :: SomeException)
--                   return "?"
--               )
getStringForKey :: (KeyMask, KeySym) -> String
getStringForKey (m, sym) = (if (m .&. shiftMask) /= 0 then map toUpper else id) (keysymToString sym)

{- Like submap, but on the character typed rather than the kysym. -}
mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a
mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)

submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X ()
submapDefaultWithKey def m = runMaybeT_ $
  mapNextStringWithKeysym $ \mask sym _ -> lift $ do
    Map.findWithDefault (def (mask, sym)) (mask, sym) m

submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X ()
submapDefault def = submapDefaultWithKey (const def)

submap :: Map (KeyMask, KeySym) (X ()) -> X ()
submap = submapDefault (return ())

-- Returns the next button press, or Nothing if the timeout expires before the
-- next button is pressed.
nextButton :: X (Maybe (ButtonMask, Button))
nextButton = do
  b <- getEscape
  if b
    then return Nothing
    else nextButton'
  where
    nextButton' = do
      XConf {theRoot = root, display = d} <- ask
      io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime

      ret <- io $
        getMaskEventWithTimeout 5000 d buttonPressMask $ \xEv -> do
          ButtonEvent {ev_button = button, ev_state = m} <- getEvent xEv
          return (m, button)

      io $ ungrabPointer d currentTime

      mapM
        ( \(m', b) -> do
            m <- fromIntegral <$> cleanMask (fromIntegral m')
            return (m, b)
        )
        ret

{- Grabs the mouse and reports the next mouse motion. -}
nextMotion :: X (Int, Int)
nextMotion = do
  XConf {theRoot = root, display = d} <- ask
  io $ grabPointer d root False pointerMotionMask grabModeAsync grabModeAsync 0 0 currentTime

  ret <- io $
    allocaXEvent $ \xEv -> do
      maskEvent d pointerMotionMask xEv
      MotionEvent {ev_x = x, ev_y = y} <- getEvent xEv
      return (fromIntegral x, fromIntegral y)

  io $ ungrabPointer d currentTime

  return ret

{- Grabs the mouse and reports the next mouse motion or button press. -}
nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button))
nextMotionOrButton = do
  XConf {theRoot = root, display = d} <- ask
  io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime

  ret <- io $
    allocaXEvent $ \xEv -> do
      maskEvent d (pointerMotionMask .|. buttonPressMask) xEv
      ev <- getEvent xEv
      case ev of
        MotionEvent {ev_x = x, ev_y = y} ->
          return $ Left (fromIntegral x, fromIntegral y)
        ButtonEvent {ev_button = button, ev_state = m} ->
          return $ Right (m, button)

  io $ ungrabPointer d currentTime

  return ret

submapButtonsWithKey ::
  ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X ()
submapButtonsWithKey defaultAction actions window = do
  maybe
    (return ())
    ( \key -> do
        win' <- pointerWindow
        case Map.lookup key actions of
          Nothing -> defaultAction key win'
          Just fn -> fn win'
    )
    =<< nextButton