module Evdev.Uinput (
Device,
newDevice,
writeEvent,
writeBatch,
defaultDeviceOpts,
DeviceOpts (..),
LL.AbsInfo (..),
deviceSyspath,
deviceDevnode,
) where
import Control.Monad
import Data.Tuple.Extra
import Foreign
import Data.ByteString.Char8 (ByteString)
import Evdev hiding (Device, newDevice)
import Evdev.Codes
import qualified Evdev.LowLevel as LL
import Util
newtype Device = Device LL.UDevice
newDevice ::
ByteString ->
DeviceOpts ->
IO Device
newDevice :: ByteString -> DeviceOpts -> IO Device
newDevice ByteString
name DeviceOpts{[(RepeatEvent, Int)]
[(AbsoluteAxis, AbsInfo)]
[SoundEvent]
[LEDEvent]
[MiscEvent]
[SwitchEvent]
[RelativeAxis]
[Key]
[EventCode]
Maybe Int
Maybe ByteString
ffStats :: DeviceOpts -> [EventCode]
powers :: DeviceOpts -> [EventCode]
ffs :: DeviceOpts -> [EventCode]
reps :: DeviceOpts -> [(RepeatEvent, Int)]
sounds :: DeviceOpts -> [SoundEvent]
leds :: DeviceOpts -> [LEDEvent]
switchs :: DeviceOpts -> [SwitchEvent]
miscs :: DeviceOpts -> [MiscEvent]
absAxes :: DeviceOpts -> [(AbsoluteAxis, AbsInfo)]
relAxes :: DeviceOpts -> [RelativeAxis]
keys :: DeviceOpts -> [Key]
idVersion :: DeviceOpts -> Maybe Int
idBustype :: DeviceOpts -> Maybe Int
idVendor :: DeviceOpts -> Maybe Int
idProduct :: DeviceOpts -> Maybe Int
uniq :: DeviceOpts -> Maybe ByteString
phys :: DeviceOpts -> Maybe ByteString
ffStats :: [EventCode]
powers :: [EventCode]
ffs :: [EventCode]
reps :: [(RepeatEvent, Int)]
sounds :: [SoundEvent]
leds :: [LEDEvent]
switchs :: [SwitchEvent]
miscs :: [MiscEvent]
absAxes :: [(AbsoluteAxis, AbsInfo)]
relAxes :: [RelativeAxis]
keys :: [Key]
idVersion :: Maybe Int
idBustype :: Maybe Int
idVendor :: Maybe Int
idProduct :: Maybe Int
uniq :: Maybe ByteString
phys :: Maybe ByteString
..} = do
Device
dev <- IO Device
LL.libevdev_new
Device -> ByteString -> IO ()
LL.setDeviceName Device
dev ByteString
name
let maybeSet :: (LL.Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet :: (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> a -> IO ()
setter Maybe a
x = IO () -> (a -> IO ()) -> Maybe a -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Device -> a -> IO ()
setter Device
dev) Maybe a
x
(Device -> ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> ByteString -> IO ()
LL.setDevicePhys Maybe ByteString
phys
(Device -> ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> ByteString -> IO ()
LL.setDeviceUniq Maybe ByteString
uniq
(Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_product Maybe Int
idProduct
(Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_vendor Maybe Int
idVendor
(Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_bustype Maybe Int
idBustype
(Device -> Int -> IO ()) -> Maybe Int -> IO ()
forall a. (Device -> a -> IO ()) -> Maybe a -> IO ()
maybeSet Device -> Int -> IO ()
LL.libevdev_set_id_version Maybe Int
idVersion
let enable :: Ptr () -> EventType -> [Word16] -> IO ()
enable :: Ptr () -> EventType -> [Word16] -> IO ()
enable Ptr ()
ptr EventType
t [Word16]
cs = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Word16] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Word16]
cs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Errno -> IO (CErrCallRes Errno)
forall a. CErrCall a => IO a -> IO (CErrCallRes a)
cec (IO Errno -> IO (CErrCallRes Errno))
-> IO Errno -> IO (CErrCallRes Errno)
forall a b. (a -> b) -> a -> b
$ Device -> Word16 -> IO Errno
LL.enableType Device
dev Word16
t'
[Word16] -> (Word16 -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Word16]
cs ((Word16 -> IO ()) -> IO ()) -> (Word16 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Word16
c -> IO Errno -> IO (CErrCallRes Errno)
forall a. CErrCall a => IO a -> IO (CErrCallRes a)
cec (IO Errno -> IO (CErrCallRes Errno))
-> IO Errno -> IO (CErrCallRes Errno)
forall a b. (a -> b) -> a -> b
$ Device -> Word16 -> Word16 -> Ptr () -> IO Errno
LL.enableCode Device
dev Word16
t' Word16
c Ptr ()
ptr
where
t' :: Word16
t' = EventType -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' EventType
t
((EventType, [Word16]) -> IO ())
-> [(EventType, [Word16])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
((EventType -> [Word16] -> IO ()) -> (EventType, [Word16]) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((EventType -> [Word16] -> IO ())
-> (EventType, [Word16]) -> IO ())
-> (EventType -> [Word16] -> IO ())
-> (EventType, [Word16])
-> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr () -> EventType -> [Word16] -> IO ()
enable Ptr ()
forall a. Ptr a
nullPtr)
[ (EventType
EvKey, (Key -> Word16) -> [Key] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [Key]
keys)
, (EventType
EvRel, (RelativeAxis -> Word16) -> [RelativeAxis] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map RelativeAxis -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [RelativeAxis]
relAxes)
, (EventType
EvMsc, (MiscEvent -> Word16) -> [MiscEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map MiscEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [MiscEvent]
miscs)
, (EventType
EvSw, (SwitchEvent -> Word16) -> [SwitchEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map SwitchEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [SwitchEvent]
switchs)
, (EventType
EvLed, (LEDEvent -> Word16) -> [LEDEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map LEDEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [LEDEvent]
leds)
, (EventType
EvSnd, (SoundEvent -> Word16) -> [SoundEvent] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map SoundEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [SoundEvent]
sounds)
, (EventType
EvFf, (EventCode -> Word16) -> [EventCode] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map EventCode -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [EventCode]
ffs)
, (EventType
EvPwr, (EventCode -> Word16) -> [EventCode] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map EventCode -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [EventCode]
powers)
, (EventType
EvFfStatus, (EventCode -> Word16) -> [EventCode] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map EventCode -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' [EventCode]
ffStats)
]
[(RepeatEvent, Int)] -> ((RepeatEvent, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RepeatEvent, Int)]
reps (((RepeatEvent, Int) -> IO ()) -> IO ())
-> ((RepeatEvent, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(RepeatEvent
rep, Int
n) -> do
ForeignPtr Int
pf <- IO (ForeignPtr Int)
forall a. Storable a => IO (ForeignPtr a)
mallocForeignPtr
ForeignPtr Int -> (Ptr Int -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Int
pf \Ptr Int
p -> do
Ptr Int -> Int -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Int
p Int
n
Ptr () -> EventType -> [Word16] -> IO ()
enable (Ptr Int -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr Int
p) EventType
EvRep [RepeatEvent -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' RepeatEvent
rep]
[(AbsoluteAxis, AbsInfo)]
-> ((AbsoluteAxis, AbsInfo) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(AbsoluteAxis, AbsInfo)]
absAxes (((AbsoluteAxis, AbsInfo) -> IO ()) -> IO ())
-> ((AbsoluteAxis, AbsInfo) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AbsoluteAxis
axis, AbsInfo
absInfo) ->
AbsInfo -> (Ptr () -> IO ()) -> IO ()
forall a. AbsInfo -> (Ptr () -> IO a) -> IO a
LL.withAbsInfo AbsInfo
absInfo ((Ptr () -> IO ()) -> IO ()) -> (Ptr () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr ()
ptr ->
Ptr () -> EventType -> [Word16] -> IO ()
enable Ptr ()
ptr EventType
EvAbs [AbsoluteAxis -> Word16
forall c a. (Num c, Enum a) => a -> c
fromEnum' AbsoluteAxis
axis]
(UDevice -> Device) -> IO UDevice -> IO Device
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UDevice -> Device
Device (IO UDevice -> IO Device) -> IO UDevice -> IO Device
forall a b. (a -> b) -> a -> b
$ IO (Errno, UDevice) -> IO (CErrCallRes (Errno, UDevice))
forall a. CErrCall a => IO a -> IO (CErrCallRes a)
cec (IO (Errno, UDevice) -> IO (CErrCallRes (Errno, UDevice)))
-> IO (Errno, UDevice) -> IO (CErrCallRes (Errno, UDevice))
forall a b. (a -> b) -> a -> b
$ Device -> Fd -> IO (Errno, UDevice)
LL.createFromDevice Device
dev (Fd -> IO (Errno, UDevice)) -> Fd -> IO (Errno, UDevice)
forall a b. (a -> b) -> a -> b
$ UInputOpenMode -> Fd
forall c a. (Num c, Enum a) => a -> c
fromEnum' UInputOpenMode
LL.UOMManaged
where
cec :: CErrCall a => IO a -> IO (CErrCallRes a)
cec :: IO a -> IO (CErrCallRes a)
cec = String -> () -> IO a -> IO (CErrCallRes a)
forall a info.
(CErrCall a, CErrInfo info) =>
String -> info -> IO a -> IO (CErrCallRes a)
cErrCall String
"newDevice" ()
data DeviceOpts = DeviceOpts
{ DeviceOpts -> Maybe ByteString
phys :: Maybe ByteString
, DeviceOpts -> Maybe ByteString
uniq :: Maybe ByteString
, DeviceOpts -> Maybe Int
idProduct :: Maybe Int
, DeviceOpts -> Maybe Int
idVendor :: Maybe Int
, DeviceOpts -> Maybe Int
idBustype :: Maybe Int
, DeviceOpts -> Maybe Int
idVersion :: Maybe Int
, DeviceOpts -> [Key]
keys :: [Key]
, DeviceOpts -> [RelativeAxis]
relAxes :: [RelativeAxis]
, DeviceOpts -> [(AbsoluteAxis, AbsInfo)]
absAxes :: [(AbsoluteAxis, LL.AbsInfo)]
, DeviceOpts -> [MiscEvent]
miscs :: [MiscEvent]
, DeviceOpts -> [SwitchEvent]
switchs :: [SwitchEvent]
, DeviceOpts -> [LEDEvent]
leds :: [LEDEvent]
, DeviceOpts -> [SoundEvent]
sounds :: [SoundEvent]
, DeviceOpts -> [(RepeatEvent, Int)]
reps :: [(RepeatEvent, Int)]
, DeviceOpts -> [EventCode]
ffs :: [EventCode]
, DeviceOpts -> [EventCode]
powers :: [EventCode]
, DeviceOpts -> [EventCode]
ffStats :: [EventCode]
}
defaultDeviceOpts :: DeviceOpts
defaultDeviceOpts :: DeviceOpts
defaultDeviceOpts =
DeviceOpts :: Maybe ByteString
-> Maybe ByteString
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> [Key]
-> [RelativeAxis]
-> [(AbsoluteAxis, AbsInfo)]
-> [MiscEvent]
-> [SwitchEvent]
-> [LEDEvent]
-> [SoundEvent]
-> [(RepeatEvent, Int)]
-> [EventCode]
-> [EventCode]
-> [EventCode]
-> DeviceOpts
DeviceOpts
{ uniq :: Maybe ByteString
uniq = Maybe ByteString
forall a. Maybe a
Nothing
, phys :: Maybe ByteString
phys = Maybe ByteString
forall a. Maybe a
Nothing
, idProduct :: Maybe Int
idProduct = Maybe Int
forall a. Maybe a
Nothing
, idVendor :: Maybe Int
idVendor = Maybe Int
forall a. Maybe a
Nothing
, idBustype :: Maybe Int
idBustype = Maybe Int
forall a. Maybe a
Nothing
, idVersion :: Maybe Int
idVersion = Maybe Int
forall a. Maybe a
Nothing
, keys :: [Key]
keys = []
, relAxes :: [RelativeAxis]
relAxes = []
, absAxes :: [(AbsoluteAxis, AbsInfo)]
absAxes = []
, miscs :: [MiscEvent]
miscs = []
, switchs :: [SwitchEvent]
switchs = []
, leds :: [LEDEvent]
leds = []
, sounds :: [SoundEvent]
sounds = []
, reps :: [(RepeatEvent, Int)]
reps = []
, ffs :: [EventCode]
ffs = []
, powers :: [EventCode]
powers = []
, ffStats :: [EventCode]
ffStats = []
}
writeEvent :: Device -> EventData -> IO ()
writeEvent :: Device -> EventData -> IO ()
writeEvent (Device UDevice
dev) EventData
e = do
String -> UDevice -> IO Errno -> IO (CErrCallRes Errno)
forall a info.
(CErrCall a, CErrInfo info) =>
String -> info -> IO a -> IO (CErrCallRes a)
cErrCall String
"writeEvent" UDevice
dev (IO Errno -> IO (CErrCallRes Errno))
-> IO Errno -> IO (CErrCallRes Errno)
forall a b. (a -> b) -> a -> b
$ (Word16 -> Word16 -> Int32 -> IO Errno)
-> (Word16, Word16, Int32) -> IO Errno
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 (UDevice -> Word16 -> Word16 -> Int32 -> IO Errno
LL.writeEvent UDevice
dev) ((Word16, Word16, Int32) -> IO Errno)
-> (Word16, Word16, Int32) -> IO Errno
forall a b. (a -> b) -> a -> b
$ EventData -> (Word16, Word16, Int32)
toCEventData EventData
e
writeBatch :: Foldable t => Device -> t EventData -> IO ()
writeBatch :: Device -> t EventData -> IO ()
writeBatch Device
dev t EventData
es = do
t EventData -> (EventData -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t EventData
es ((EventData -> IO ()) -> IO ()) -> (EventData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Device -> EventData -> IO ()
writeEvent Device
dev
Device -> EventData -> IO ()
writeEvent Device
dev (EventData -> IO ()) -> EventData -> IO ()
forall a b. (a -> b) -> a -> b
$ SyncEvent -> EventData
SyncEvent SyncEvent
SynReport
deviceSyspath :: Device -> IO (Maybe ByteString)
deviceSyspath :: Device -> IO (Maybe ByteString)
deviceSyspath = UDevice -> IO (Maybe ByteString)
LL.getSyspath (UDevice -> IO (Maybe ByteString))
-> (Device -> UDevice) -> Device -> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(Device UDevice
d) -> UDevice
d
deviceDevnode :: Device -> IO (Maybe ByteString)
deviceDevnode :: Device -> IO (Maybe ByteString)
deviceDevnode = UDevice -> IO (Maybe ByteString)
LL.getDevnode (UDevice -> IO (Maybe ByteString))
-> (Device -> UDevice) -> Device -> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(Device UDevice
d) -> UDevice
d