Feature/win key repeat (kmonad#541)

* Bump resolver to match available GHC in nix

* First attempt at key-repeat in windows

* Hooking up the parsers and preparing testing

* Changed micro to milli-seconds

* First attempt at key-repeat in windows

* Hooking up the parsers and preparing testing

* Changed micro to milli-seconds

* Fixed bug

* Modified testing values

* Fixed error in parser

* Made the test a little bit more sane

keymap/testing.kbd

@@ -0,0 +1,9 @@
+(defcfg
+ input (low-level-hook)
+ output (send-event-sink 300 100)
+)
+
+(defsrc q w e r t y lsft)
+
+(deflayer base
+ q w e r t y lsft)

src/KMonad/Args/Joiner.hs

@@ -260,7 +260,7 @@ pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
 pickOutput (KUinputSink t init) = pure $ runLF (uinputSink cfg)
  where cfg = defUinputCfg { _keyboardName = T.unpack t
  , _postInit = T.unpack <$> init }
-pickOutput KSendEventSink   = throwError $ InvalidOS "SendEventSink"
+pickOutput (KSendEventSink _) = throwError $ InvalidOS "SendEventSink"
 pickOutput KKextSink = throwError $ InvalidOS "KextSink"
 
 #endif
@@ -275,9 +275,9 @@ pickInput (KIOKitSource _) = throwError $ InvalidOS "IOKitSource"
 
 -- | The Windows correspondence between OToken and actual code
 pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
-pickOutput KSendEventSink  = pure $ runLF sendEventKeySink
-pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink"
-pickOutput KKextSink = throwError $ InvalidOS "KextSink"
+pickOutput (KSendEventSink di) = pure $ runLF (sendEventKeySink di)
+pickOutput (KUinputSink _ _)  = throwError $ InvalidOS "UinputSink"
+pickOutput KKextSink  = throwError $ InvalidOS "KextSink"
 
 #endif
 
@@ -293,7 +293,7 @@ pickInput KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource"
 pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
 pickOutput KKextSink = pure $ runLF kextSink
 pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink"
-pickOutput KSendEventSink   = throwError $ InvalidOS "SendEventSink"
+pickOutput (KSendEventSink _) = throwError $ InvalidOS "SendEventSink"
 
 #endif
 

src/KMonad/Args/Parser.hs

@@ -331,7 +331,7 @@ otokenP = choice $ map (try . uncurry statement) otokens
 otokens :: [(Text, Parser OToken)]
 otokens =
  [ ("uinput-sink" , KUinputSink <$> lexeme textP <*> optional textP)
- , ("send-event-sink", pure KSendEventSink)
+ , ("send-event-sink", KSendEventSink <$> (optional $ (,) <$> lexeme numP <*> numP))
  , ("kext" , pure KKextSink)]
 
 -- | Parse the DefCfg token

src/KMonad/Args/Types.hs

@@ -167,7 +167,7 @@ data IToken
 -- | All different output-tokens KMonad can take
 data OToken
  = KUinputSink Text (Maybe Text)
- | KSendEventSink
+ | KSendEventSink (Maybe (Int, Int))
  | KKextSink
  deriving Show
 

src/KMonad/Keyboard/IO/Windows/SendEventSink.hs

@@ -29,36 +29,73 @@ import KMonad.Keyboard.IO.Windows.Types
 
 --------------------------------------------------------------------------------
 
-foreign import ccall "sendKey"
- sendKey :: Ptr WinKeyEvent -> IO ()
+foreign import ccall "sendKey" sendKey :: Ptr WinKeyEvent -> IO ()
+
+
+
 
 -- | The SKSink environment
 data SKSink = SKSink
- { _buffer :: Ptr WinKeyEvent -- ^ The pointer we write events to
+ { _buffer :: MVar (Ptr WinKeyEvent) -- ^ The pointer we write events to
+ , _keyrep :: MVar (Maybe (Keycode, Async ()))
+ , _delay :: Int -- ^ How long to wait before starting key repeat in ms
+ , _rate :: Int -- ^ How long to wait between key repeats in ms
  }
 makeClassy ''SKSink
 
 -- | Return a 'KeySink' using Window's @sendEvent@ functionality.
-sendEventKeySink :: HasLogFunc e => RIO e (Acquire KeySink)
-sendEventKeySink = mkKeySink skOpen skClose skSend
+sendEventKeySink :: HasLogFunc e => Maybe (Int, Int) -> RIO e (Acquire KeySink)
+sendEventKeySink di = mkKeySink (skOpen (fromMaybe (300, 100) di)) skClose skSend
 
 -- | Create the 'SKSink' environment
-skOpen :: HasLogFunc e => RIO e SKSink
-skOpen = do
+skOpen :: HasLogFunc e => (Int, Int) -> RIO e SKSink
+skOpen (d, i) = do
  logInfo "Initializing Windows key sink"
- liftIO $ SKSink <$> mallocBytes (sizeOf (undefined :: WinKeyEvent))
+ bv <- liftIO $ mallocBytes (sizeOf (undefined :: WinKeyEvent))
+ bm <- newMVar bv
+ r <- newMVar Nothing
+ pure $ SKSink bm r d i
 
 -- | Close the 'SKSink' environment
 skClose :: HasLogFunc e => SKSink -> RIO e ()
-skClose sk = do
+skClose s = do
  logInfo "Closing Windows key sink"
- liftIO . free $ sk^.buffer
+ withMVar (s^.keyrep) $ \r -> maybe (pure ()) cancel (r^?_Just._2)
+ withMVar (s^.buffer) (liftIO . free)
+
+-- | Send 1 key event to Windows
+emit :: MonadUnliftIO m => SKSink -> WinKeyEvent -> m ()
+emit s w = withMVar (s^.buffer) $ \b -> liftIO $ poke b w >> sendKey b
 
 -- | Write an event to the pointer and prompt windows to inject it
 --
 -- NOTE: This can throw an error if event-conversion fails.
 skSend :: HasLogFunc e => SKSink -> KeyEvent -> RIO e ()
-skSend sk e = either throwIO go $ toWinKeyEvent e
- where go e' = liftIO $ do
- poke (sk^.buffer) e'
- sendKey $ sk^.buffer
+skSend s e = do
+
+ w <- either throwIO pure $ toWinKeyEvent e -- the event for windows
+ r <- takeMVar $ s^.keyrep -- the keyrep token
+
+ -- Whether this keycode is currently active in key-repeat
+ let beingRepped = Just (e^.keycode) == (r^?_Just._1)
+
+ -- When we're going to emit a press we are not already repeating
+ let handleNewPress = do
+ maybe (pure ()) cancel (r^?_Just._2)
+ emit s w
+ a <- async $ do
+ threadDelay (1000 * s^.delay)
+ forever $ emit s w >> threadDelay (1000 * s^.rate)
+ pure $ Just (e^.keycode, a)
+
+ -- When the event is a release
+ let handleRelease = do
+ when beingRepped $ maybe (pure ()) cancel (r^?_Just._2)
+ emit s w
+ pure $ if beingRepped then Nothing else r
+
+ -- Perform the correct action and store the rep-env
+ newRep <- if | isPress e && not beingRepped -> handleNewPress
+ | isRelease e -> handleRelease
+ | otherwise -> pure r
+ putMVar (s^.keyrep) newRep