fake-type 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+70/−52 lines, 3 filesdep +split

Dependencies added: split

Files

• CHANGELOG.md +4/−0
• fake-type.cabal +4/−3
• lib/FakeType.hs +62/−49

@@ -1,3 +1,7 @@+# 0.2.0.0++* The key-entering algoritm is much more advanced now.+ # 0.1.0.0  First release. Only Linux support is available so far.

@@ -1,5 +1,5 @@ name:                fake-type-version:             0.1.0.0+version:             0.2.0.0 synopsis:            A crossplatform library to simulate keyboard input description:            A crossplatform library to simulate keyboard input (so far it works only on Linux, but I'll add Windows and OS X soon).@@ -25,9 +25,10 @@   exposed-modules:     FakeType   -- other-modules:          -- other-extensions:    -  build-depends:       base >= 4.7 && < 5+  build-depends:       X11+                     , base >= 4.7 && < 5                      , base-prelude == 0.1.*-                     , X11+                     , split == 0.2.*   extra-libraries:     "Xtst"   ghc-options:         -Wall -fno-warn-unused-do-bind   hs-source-dirs:      lib

@@ -9,6 +9,7 @@ module FakeType (   sendString,+  sendStringWithDelay, ) where @@ -18,6 +19,7 @@ import Foreign import Foreign.C.Types import Graphics.X11+import Data.List.Split (chunksOf)   foreign import ccall unsafe "HsXlib.h XGetKeyboardMapping"@@ -92,55 +94,66 @@         (advancePtr symArray (symIndex key 0 mapping))         amount -getSymbol-  :: KeyCode     -- ^ Key-  -> Int         -- ^ Position (usually 0..3)-  -> Mapping-  -> IO KeySym-getSymbol key pos mapping =-  peekElemOff (symArray mapping) (symIndex key pos mapping)--changeSymbol-  :: Display-  -> KeyCode     -- ^ Key-  -> Int         -- ^ Position (usually 0..3)-  -> KeySym      -- ^ Symbol-  -> Mapping-  -> IO ()-changeSymbol display key pos sym mapping = do-  pokeElemOff (symArray mapping) (symIndex key pos mapping) sym-  changeKeyboardMapping display (Just (key, 1)) mapping-  flush display--findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM _ [] = return Nothing-findM p (x:xs) = do-  r <- p x-  if r then return (Just x) else findM p xs+charSym :: Char -> KeySym+charSym char = stringToKeysym ('U' : showHex (fromEnum char) "") --- Find a key that has an empty default position (so that we'd be able to--- simulate a keypress without having to use any key modifiers). If there's--- no empty key, throw an exception.-findFreeKey :: Mapping -> IO KeyCode-findFreeKey mapping@Mapping{..} = do-  let isEmptyKey key = (== noSymbol) <$> getSymbol key 0 mapping-  mbFreeKey <- findM isEmptyKey (take (fromIntegral keyCount) [minKey..])-  case mbFreeKey of-    Nothing -> error "findFreeKey: couldn't find a free key"-    Just k  -> return k+-- Find unused keys (so that we'd be able to simulate a keypress without+-- having to use any key modifiers). An important thing is that the keys have+-- to be completely unused – keys -that have Alt or Super assigned to them-+-- will behave weirdly if you try to use them (even tho they don't have any+-- symbols in default positions).+findFreeKeys :: Mapping -> IO [KeyCode]+findFreeKeys mapping@Mapping{..} = do+  let isEmptyKey key = do+        -- Get a pointer to the part of symArray that corresponds to the key.+        let keyPtr = advancePtr symArray (symIndex key 0 mapping)+        -- Get the symbols (there's symPerKey of them).+        syms <- peekArray (fromIntegral symPerKey) keyPtr+        -- Check that they all are noSymbol.+        return (all (== noSymbol) syms)+  filterM isEmptyKey (take (fromIntegral keyCount) [minKey..])  sendString :: String -> IO ()-sendString string = do-  display <- openDisplay ":0.0"-  mapping <- getKeyboardMapping display Nothing-  freeKey <- findFreeKey mapping-  sync display False-  forM_ string $ \char -> do-    let sym = stringToKeysym ('U' : showHex (fromEnum char) "")-    changeSymbol display freeKey 0 sym mapping-    xFakeKeyEvent display freeKey True 0-    xFakeKeyEvent display freeKey False 0-    sync display False-    threadDelay 12000-  changeSymbol display freeKey 0 noSymbol mapping-  closeDisplay display+sendString = sendStringWithDelay 20 8 20++sendStringWithDelay+  :: Int               -- ^ Delay after changing the layout (in ms)+  -> Int               -- ^ Delay after pressing\/releasing a key+  -> Int               -- ^ Delay after entering a batch of symbols+  -> String+  -> IO ()+sendStringWithDelay mappingDelay pressDelay batchDelay string =+  bracket (openDisplay ":0.0") closeDisplay $ \display -> do+    mapping <- getKeyboardMapping display Nothing+    freeKeys <- findFreeKeys mapping+    when (null freeKeys) $+      error "sendStringWithDelay: couldn't find a free key"+    let syncAndFlush = sync display False >> flush display+    -- This function assigns given symbols to freeKeys.+    let assignSyms syms = do+          for_ (zip syms freeKeys) $ \(sym, key) -> do+            let keyPtr = advancePtr (symArray mapping) (symIndex key 0 mapping)+            pokeArray keyPtr (replicate (fromIntegral (symPerKey mapping)) sym)+          changeKeyboardMapping display Nothing mapping+          syncAndFlush+          threadDelay (mappingDelay * 1000)+    -- To enter a chunk of characters, we first assign all characters to free+    -- keys and then press those keys; it's done like this because+    -- changeKeyboardMapping is pretty slow and doing it for *each* key+    -- results in glitches when typing.+    let typeChunk chunk = do+          let len = length chunk+          assignSyms (map charSym chunk)+          for_ (take len freeKeys) $ \key -> do+            xFakeKeyEvent display key True 0+            syncAndFlush+            threadDelay (pressDelay * 1000)+            xFakeKeyEvent display key False 0+            syncAndFlush+            threadDelay (pressDelay * 1000)+          threadDelay (batchDelay * 1000)+    -- Okay, let's enter all chunks. We also have to make the keys free again+    -- after entering the chunks.+    let chunks = chunksOf (length freeKeys) string+    mapM_ typeChunk chunks `finally`+      assignSyms (repeat noSymbol)