gistfile1.hs

{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Control.Applicative
import Control.Concurrent(forkIO)
import Control.Monad hiding(mapM)
import Control.Monad.IO.Class
import qualified Data.ByteString as B (putStr, pack, length)
import Data.ByteString.Lazy (toStrict)
import Data.Binary
import Data.Monoid ((<>))
import Data.Conduit
import Data.Data
import Data.Int
import Data.List
import Data.Maybe
import Data.Text (unpack)
import Data.Traversable
import Prelude hiding(mapM)
import SDL hiding (Mode)
import SDL.Raw
import System.Console.CmdArgs
import System.Hardware.Serialport
import Text.Show.Pretty(ppShow)
import qualified Data.Vector as V
import Joystick

printSink :: Show a => Sink a IO ()
printSink = forever $ liftIO <$> putStrLn . ppShow  =<< await

serialSink :: SerialPort -> Sink JoystickState IO ()
serialSink s = forever $
  do j <- await
     let magic = B.pack [0x73, 0x79, 0x6f, 0x6a] -- 'joys'
         joystickBytes = toStrict (encode j)
         message = magic <> joystickBytes
         numPaddingBytes = 64 - B.length message
         padding = B.pack (replicate numPaddingBytes 0)
     liftIO $ send s (message <> padding)

data JplArgs = List
             | Forward { serialPort :: FilePath, stickName :: String, stickIndex :: Int, pollInterval :: Int }
             | Print { serialPort :: FilePath }
             | DumpStick { stickName :: String, stickIndex :: Int, pollInterval :: Int }
  deriving (Show, Data, Typeable)

printPort :: SerialPort -> IO ()
printPort s = forever (recv s 1 >>= B.putStr)

listMode :: JplArgs
listMode = List

forwardMode :: JplArgs
forwardMode = Forward
  { serialPort = def &= argPos 0 &= typ "serial-port"
  , stickName = def &= argPos 1 &= typ "joystick-name"
  , stickIndex = def &= help "Index to differentiate identically named sticks"
  , pollInterval = def &= help "Polling interval in ms"
  }

dumpStickMode :: JplArgs
dumpStickMode = DumpStick
  { stickName = def &= argPos 3 &= typ "joystick-name"
  , stickIndex = def &= help "Index to differentiate identically named sticks"
  , pollInterval = def &= help "Polling interval in ms"
  }

printMode :: JplArgs
printMode = Print { serialPort = def &= argPos 2 &= typ "serial-port" }

jplModes :: Mode (CmdArgs JplArgs)
jplModes = cmdArgsMode $ modes
                           [ listMode &= help "List available joysticks"
                           , printMode &= help "Print data received over the specified serial port"
                           , forwardMode
                             &= auto
                             &= help "Forward joystick input over serial port"
                             &= details
                                  [ "Example usage on Windows: jpl COM3 \"Joystick name\""
                                  , "Example usage elsewhere: jpl /dev/tty3 \"Joystick name\""
                                  ]
                           , dumpStickMode
                             &= help "Dump joystick input to console"
                           ] &= program "jpl"
                             &= versionArg [ignore]
                             &= verbosity

selectJoystick :: String -> Int -> IO (Maybe SDL.Joystick)
selectJoystick name i =
  do ds <- V.toList <$> availableJoysticks
     let js = filter ((== name) . unpack . joystickDeviceName) ds
         j = case js of
               [] -> Nothing
               [j] -> Just j
               js -> listToMaybe $ drop i js
     traverse openJoystick j

main :: IO ()
main =
  do args <- cmdArgsRun jplModes
     SDL.initialize [InitJoystick]
     SDL.Raw.joystickEventState 0 -- SDL_IGNORE
     case args of
       List -> mapM_ putStrLn =<< getJoystickNames
       Print port -> withSerial port defaultSerialSettings printPort
       Forward port stickName stickIndex pollingInterval ->
         do withJoystickOr stickName stickIndex
              (\j -> (withSerial port defaultSerialSettings $ \s ->
                do whenNormal $ void (forkIO (printPort s))
                   joystickSource pollingInterval j $$ serialSink s))
              (putStrLn ("Couldn't find joystick: \"" ++ stickName ++ "\""))
       DumpStick stickName stickIndex pollingInterval ->
         do withJoystickOr stickName stickIndex
              (\j -> joystickSource pollingInterval j $$ printSink)
              (putStrLn ("Couldn't find joystick: \"" ++ stickName ++ "\""))