fake-type-0.2.0.0: lib/FakeType.hs

{-# LANGUAGE
ForeignFunctionInterface,
NondecreasingIndentation,
RecordWildCards,
NoImplicitPrelude
  #-}


module FakeType
(
  sendString,
  sendStringWithDelay,
)
where


import BasePrelude
import Numeric
import Foreign
import Foreign.C.Types
import Graphics.X11
import Data.List.Split (chunksOf)


foreign import ccall unsafe "HsXlib.h XGetKeyboardMapping"
  xGetKeyboardMapping
    :: Display
    -> KeyCode                         -- First keycode
    -> CInt                            -- Amount of keycodes
    -> Ptr CInt                        -- Keysyms per keycode
    -> IO (Ptr KeySym)                 -- Keysyms

foreign import ccall unsafe "HsXlib.h XChangeKeyboardMapping"
  xChangeKeyboardMapping
    :: Display
    -> KeyCode                         -- First keycode
    -> CInt                            -- Keysyms per keycode
    -> Ptr KeySym                      -- Array of keysyms
    -> CInt                            -- Amount of keycodes
    -> IO ()

foreign import ccall unsafe "X11/extensions/XTest.h XTestFakeKeyEvent"
  xFakeKeyEvent :: Display -> KeyCode -> Bool -> CULong -> IO Status

data Mapping = Mapping {
  minKey    :: KeyCode,
  keyCount  :: CInt,
  symArray  :: Ptr KeySym,
  symPerKey :: CInt }

getKeyboardMapping
  :: Display
  -> Maybe (KeyCode, CInt)  -- ^ First key + amount of keys,
                            --   or 'Nothing' if it's “all”
  -> IO Mapping
getKeyboardMapping display mb = do
  let (minKey, keyCount) = case mb of
        Just x  -> x
        Nothing -> let (a, b) = displayKeycodes display
                   in  (fromIntegral a, b-a+1)
  alloca $ \symPerKey_return -> do
  symArray <- xGetKeyboardMapping
                display
                minKey
                keyCount
                symPerKey_return
  symPerKey <- peek symPerKey_return
  return Mapping{..}

symIndex :: KeyCode -> Int -> Mapping -> Int
symIndex key pos Mapping{..} =
  fromIntegral (key-minKey) * fromIntegral symPerKey + pos

changeKeyboardMapping
  :: Display
  -> Maybe (KeyCode, CInt)  -- ^ First key + amount of keys,
                            --   or 'Nothing' if it's “all”
  -> Mapping
  -> IO ()
changeKeyboardMapping display mb mapping@Mapping{..} =
  case mb of
    Nothing ->
      xChangeKeyboardMapping
        display
        minKey
        symPerKey
        symArray
        keyCount
    Just (key, amount) ->
      xChangeKeyboardMapping
        display
        key
        symPerKey
        (advancePtr symArray (symIndex key 0 mapping))
        amount

charSym :: Char -> KeySym
charSym char = stringToKeysym ('U' : showHex (fromEnum char) "")

-- 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 = 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)