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

import Rahm.Desktop.Common
import Control.Monad.Trans.Maybe
import Control.Monad.Trans
import Control.Monad (void)
import XMonad hiding (keys)
import Control.Monad.Fix (fix)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Concurrent (threadDelay)
import Data.Word (Word64)
import Data.Time.Clock.POSIX


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

{-
 - 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 2000 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
  fn m keysym str

{- 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
  XConf { theRoot = root, display = d } <- ask
  io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime

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

  io $ ungrabPointer d currentTime

  return 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 ()) (\arg ->
    case Map.lookup arg actions of
      Nothing -> defaultAction arg window
      Just fn -> fn window) =<< nextButton