X11Spec.hs

{-# LANGUAGE FlexibleContexts, CPP, OverloadedStrings #-}
module WildBind.X11Spec (main, spec) where

import Control.Applicative ((<$>))
import Control.Concurrent.Async (async, waitCatch)
import Control.Exception (finally, Exception(fromException), throwIO)
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.Trans.State as State
import Data.Monoid ((<>))
import Data.List (intercalate, reverse)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import Data.Text (unpack)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import qualified Graphics.X11.Xlib as Xlib
import System.IO (hPutStrLn,stderr)
import Test.Hspec

import WildBind
  ( FrontEnd(frontSetGrab, frontUnsetGrab, frontNextEvent),
    FrontEvent(FEChange,FEInput), Describable, ActionDescription,
    Option(..), defOption, wildBind',
    binds', startFrom, on, as, run, whenBack, revise, justBefore
  )
import qualified WildBind.Description as WBD
import qualified WildBind.Input.NumPad as NumPad
import WildBind.X11
  ( withFrontEnd, ActiveWindow, XKeyInput,
    XMod(..), XKeyEvent(..), KeyEventType(..),
    ctrl, alt, super, shift, release, press
  )
import qualified WildBind.X11.KeySym as WKS

import WildBind.X11.TestUtil (checkIfX11Available, withGrabs)

newtype MyException = MyException String
                    deriving (Show,Eq,Ord)

instance Exception MyException

main :: IO ()
main = hspec spec

maybeRun :: Expectation -> Expectation
#ifdef TEST_INTERACTIVE
maybeRun = id
#else
maybeRun _ = pendingWith ("You need to set test-interactive flag to run the test.")
#endif

p :: String -> IO ()
p = hPutStrLn stderr . ("--- " ++)

withFrontEndForTest :: (XKeyInput i, Describable i, Ord i) => (FrontEnd ActiveWindow i -> IO a) -> IO a
withFrontEndForTest action = withFrontEnd $ \front -> do
  _ <- frontNextEvent front -- discard the first FEChange event.
  action front

grabExp :: (Bounded i, Enum i, Show i, Eq i)
        => FrontEnd ActiveWindow i -> i -> Expectation
grabExp front grab_input = grabExpMain `finally` releaseAll where
  grabExpMain = do
    frontSetGrab front grab_input
    p ("Press some numpad keys (grab="++ show grab_input ++")..")
    ev <- frontNextEvent front
    p ("Got event: " ++ show ev)
    ev `shouldBe` FEInput grab_input
  releaseAll = mapM_ (frontUnsetGrab front) (enumFromTo minBound maxBound)

grabCase :: (Bounded i, Enum i, Show i, Eq i) => FrontEnd ActiveWindow i -> Expectation
grabCase front = mapM_ (grabExp front) (enumFromTo minBound maxBound)

stopWatchMsec :: IO a -> IO (a, Int)
stopWatchMsec act = do
  start <- getCurrentTime
  ret <- act
  end <- getCurrentTime
  return (ret, floor ((diffUTCTime end start) * 1000))

describeStr :: Describable a => a -> String
describeStr = unpack . WBD.describe

unshiftNewBinding :: Eq i => IORef [[(i,ActionDescription)]] -> [(i,ActionDescription)] -> IO ()
unshiftNewBinding ref got = do
  cur <- readIORef ref
  case cur of
   [] -> update
   (latest : _) -> if latest /= got
                   then update
                   else return ()
  where
    update = modifyIORef ref (got :)

spec :: Spec
spec = checkIfX11Available $ do
  describe "X11Front" $ do
    it "should first emit FEChange event when initialized" $ withFrontEnd $ \f -> do
      p "try to get the first event..."
      (ev, time) <- stopWatchMsec $ frontNextEvent f :: IO (FrontEvent ActiveWindow NumPad.NumPadUnlocked, Int)
      time `shouldSatisfy` (< 500)
      case ev of
        FEChange _ -> return ()
        _ -> expectationFailure ("FEChange is expected, but got " ++ show ev)
    it "should NOT throw exception when it tries to double-grab in the same process" $ withFrontEnd $ \f1 ->
      withFrontEnd $ \f2 -> do
        frontSetGrab f1 NumPad.NumLeft `shouldReturn` ()
        frontSetGrab f2 NumPad.NumLeft `shouldReturn` ()
    it "should control key grab based on ('release' || 'press')" $ maybeRun $ withFrontEnd $ \f -> do
      got_binds_rev <- newIORef []
      let opt = defOption { optBindingHook = unshiftNewBinding got_binds_rev,
                            optCatch = (\_ _ e -> throwIO e)
                          }
          b_base = binds' $ do
            on (press $ ctrl $ WKS.xK_g) `as` "P(C-g)" `run` liftIO (throwIO $ MyException "NG")
            on (release $ alt $ ctrl $ WKS.xK_x) `as` "R(M-C-x)" `run` liftIO (throwIO $ MyException "OK")
          b_0 = whenBack (== 0) $ binds' $ do
            on (press $ ctrl $ WKS.xK_i) `as` "P(C-i)" `run` State.put 1
          b_1 = whenBack (== 1) $ binds' $ do
            on (press $ ctrl $ WKS.xK_i) `as` "P(C-i)" `run` State.put 0
            on (press $ alt $ ctrl $ WKS.xK_x) `as` "P(M-C-x)" `run` return ()
          rev _ _ i = justBefore $ p ("Input: " ++ (unpack $ WBD.describe i))
          b = revise rev $ startFrom (0 :: Int) $ b_base <> b_0 <> b_1
          exp_descs = [ ["P(C-g)", "R(M-C-x)", "P(C-i)"],
                        ["P(C-g)", "R(M-C-x)", "P(C-i)", "P(M-C-x)"],
                        ["P(C-g)", "R(M-C-x)", "P(C-i)"]
                      ]
      p "Input C-i C-i M-C-x. If wildBind is still blocked, then type C-g."
      result <- waitCatch =<< async (wildBind' opt b f)
      got_descs <- fmap ((map . map) snd . reverse) $ readIORef got_binds_rev
      length got_descs `shouldBe` length exp_descs
      forM_ (zip got_descs exp_descs) $ uncurry shouldMatchList
      case result of
       Right _ -> expectationFailure "expects an exception, but nothing happened."
       Left e -> fromException e `shouldBe` (Just $ MyException "OK")
      
  describe "X11Front - NumPadUnlocked" $ do
    it "should grab/ungrab keys" $ maybeRun $ withFrontEndForTest $ \f -> do
      let grabCase' :: FrontEnd ActiveWindow NumPad.NumPadUnlocked -> Expectation
          grabCase' = grabCase
      grabCase' f
  describe "X11Front - NumPadLocked" $ do
    it "should grab/ungrab keys" $ maybeRun $ withFrontEndForTest $ \f -> do
      let grabCase' :: FrontEnd ActiveWindow NumPad.NumPadLocked -> Expectation
          grabCase' = grabCase
      grabCase' f
  describe "X11Front - normal modified keys (pressed)" $ do
    it "should distinguish modifiers" $ maybeRun $ withFrontEndForTest $ \f -> do
      let inputs = [ ctrl Xlib.xK_i,
                     ctrl $ alt Xlib.xK_i,
                     super Xlib.xK_i,
                     shift $ super Xlib.xK_I
                   ]
      withGrabs f inputs $ do
        p ("Grabbed " ++ (intercalate ", " $ map describeStr inputs))
        forM_ inputs $ \input -> do
          p ("Push " ++ describeStr input)
          press_ev <- frontNextEvent f
          p ("Got event: " ++ show press_ev)
          press_ev `shouldBe` FEInput input
          release_ev <- frontNextEvent f
          p ("Got event: " ++ show release_ev)
          release_ev `shouldBe` (FEInput $ input { xKeyEventType = KeyRelease })
  describe "X11Front - Either" $ do
    it "should combine input types" $ maybeRun $ withFrontEndForTest $ \f -> do
      let inputs = [Left NumPad.NumLPeriod, Right NumPad.NumDelete]
      withGrabs f inputs $ do
        forM_ inputs $ \input -> do
          p ("Push " ++ show input)
          ev <- frontNextEvent f
          ev `shouldBe` FEInput input