diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index e5275f7..f4940b6 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -11,51 +11,24 @@ jobs: name: main runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 - - - name: Set user input permissions - run: sudo usermod -a -G input $USER - - - name: Set up GHC - uses: haskell-actions/setup@v2 - id: setup + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v30 with: - ghc-version: '9.4' - cabal-version: '3.10' - cabal-update: true - - - name: Install libevdev - run: sudo apt install -y libevdev-dev - - - name: Configure the build - run: | - cabal configure --enable-tests --enable-benchmarks --disable-documentation - cabal build all --dry-run - - - name: Restore cached dependencies - uses: actions/cache/restore@v3 - id: cache - env: - key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} + github_access_token: ${{ secrets.GITHUB_TOKEN }} + extra_nix_config: | + extra-substituters = https://cache.iog.io https://cache.zw3rk.com + extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= + - uses: cachix/cachix-action@v15 with: - path: ${{ steps.setup.outputs.cabal-store }} - key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} - restore-keys: ${{ env.key }}- - - - name: Install dependencies - run: cabal build all --only-dependencies + name: georgefst + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} - - name: Save cached dependencies - uses: actions/cache/save@v3 - if: ${{ steps.cache.outputs.cache-primary-key != steps.cache.outputs.cache-matched-key }} - with: - path: ${{ steps.setup.outputs.cabal-store }} - key: ${{ steps.cache.outputs.cache-primary-key }} + - name: Build all packages + run: nix build .#ci - - name: Build - run: cabal build all + # TODO work around test permissions and ARM build and + # - name: Run checks + # run: nix flake check - - name: Run tests - run: | - cabal build test - sudo $(cabal list-bin test) + - name: Run main test with permissions + run: sudo $(nix build .#evdev:test:test --print-out-paths)/bin/test diff --git a/.gitignore b/.gitignore index db4503f..17b57c7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ dist-newstyle .ghc.environment.* cabal.project.local +result +evdev/output diff --git a/cabal.project b/cabal.project index 1415e03..d26d19b 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,18 @@ packages: evdev-streamly evdev-examples +source-repository-package + type: git + location: https://github.com/well-typed/hs-bindgen + tag: 3c4af10590d0d09e825a9735e9a03d7f60914e21 + subdir: c-expr-dsl c-expr-runtime hs-bindgen hs-bindgen-runtime + --sha256: UCA7w+u20+CX1XN8so76UfJkM0FKKpljOgweP2FjtS4= +source-repository-package + type: git + location: https://github.com/well-typed/libclang + tag: 1054474fae403bfb52c7919680cac03d3d3d4237 + --sha256: LTAyNMY4Vu0vPeEq2wXB0KWY4kGtqtHTRmADjLdkv78= + if impl(ghc >= 9.10) allow-newer: -- deprecated - we'll replace it ASAP in favour of `OsPath` diff --git a/evdev/evdev.cabal b/evdev/evdev.cabal index b08cf0d..5977389 100644 --- a/evdev/evdev.cabal +++ b/evdev/evdev.cabal @@ -22,11 +22,18 @@ common common base >= 4.11 && < 5, bytestring ^>= {0.10, 0.11, 0.12}, containers ^>= {0.6.2, 0.7, 0.8}, + directory ^>= 1.3, extra ^>= {1.6.18, 1.7, 1.8}, + filepath ^>= 1.5, filepath-bytestring ^>= {1.4.2, 1.5}, + hs-bindgen ^>= {0.1}, + hs-bindgen-runtime ^>= {0.1}, monad-loops ^>= 0.4.3, mtl ^>= {2.2, 2.3}, + ordered-containers ^>= 0.2.4, + process ^>= 1.6, rawfilepath ^>= {1.0, 1.1}, + template-haskell ^>= {2.21, 2.22, 2.23}, time ^>= {1.9.3, 1.10, 1.11, 1.12, 1.13, 1.14, 1.15}, unix ^>= 2.8, default-language: GHC2021 @@ -48,16 +55,15 @@ library Evdev Evdev.Codes Evdev.Uinput - other-modules: - Evdev.LowLevel + Evdev.Raw Util + other-modules: + Evdev.Codes.Generator hs-source-dirs: src c-sources: src-c/evdev-hs.c pkgconfig-depends: libevdev - build-tool-depends: - c2hs:c2hs test-suite test import: common diff --git a/evdev/src/Evdev.hs b/evdev/src/Evdev.hs index 455d112..0d32ec3 100644 --- a/evdev/src/Evdev.hs +++ b/evdev/src/Evdev.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -fno-state-hack #-} +{-# LANGUAGE LexicalNegation #-} +{-# LANGUAGE OverloadedRecordDot #-} -- | The main module for working with devices and events. module Evdev ( @@ -21,7 +22,7 @@ module Evdev ( deviceBustype, deviceVersion, deviceAbsAxis, - LL.AbsInfo (..), + AbsInfo (..), -- ** Grabbing grabDevice, ungrabDevice, @@ -36,28 +37,28 @@ module Evdev ( -- * Lower-level newDeviceFromFd, nextEventMay, - LL.LEDValue(..), + LEDValue(..), setDeviceLED, -- ** C-style types -- | These correspond more directly to C's /input_event/ and /timeval/. -- They are used internally, but may be useful for advanced users. - LL.CEvent(..), + Raw.Input_event(..), toCEvent, fromCEvent, toCEventData, fromCEventData, - LL.CTimeVal(..), + Raw.Timeval(..), toCTimeVal, fromCTimeVal, ) where -import Control.Arrow ((&&&)) import Control.Monad (filterM, join) +import Data.ByteString (packCString) import Data.ByteString.Char8 (ByteString, pack) +import Data.Coerce (coerce) +import Data.Function ((&)) +import Data.Functor ((<&>)) import Data.Int (Int32) -import Data.List.Extra (enumerate) -import Data.Map ((!?), Map) -import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Ratio ((%)) import Data.Set (Set) @@ -65,21 +66,22 @@ import qualified Data.Set as Set import Data.Time.Clock (DiffTime) import Data.Tuple.Extra (uncurry3) import Data.Word (Word16) -import Foreign ((.|.)) -import Foreign.C (CUInt) +import Foreign (alloca, (.|.), peek, ForeignPtr, withForeignPtr, newForeignPtr) +import Foreign.C (CInt (CInt), CUInt (CUInt), CUShort (CUShort), Errno (Errno), eAGAIN, eOK) +import Foreign.C.ConstPtr (ConstPtr (..)) import System.Posix.Process (getProcessID) import System.Posix.Files (readSymbolicLink) -import System.Posix.ByteString (Fd, RawFilePath) +import System.Posix.ByteString (Fd (Fd), RawFilePath) import System.Posix.IO.ByteString (OpenMode (..), defaultFileFlags, openFd) -import qualified Evdev.LowLevel as LL +import qualified Evdev.Raw as Raw import Evdev.Codes import Util -- stores path that was originally used, as it seems impossible to recover this later -- We don't allow the user to access the underlying low-level C device. -- | An input device. -data Device = Device { cDevice :: LL.Device, devicePath :: ByteString } +data Device = Device { cDevice :: ForeignPtr Raw.Libevdev, devicePath :: ByteString } instance Show Device where @@ -126,79 +128,102 @@ data KeyEvent | Repeated deriving (Bounded, Enum, Eq, Ord, Read, Show) -convertFlags :: Set LL.ReadFlag -> CUInt -convertFlags = fromIntegral . foldr ((.|.) . fromEnum) 0 +data ReadFlag = Sync | Normal | ForceSync | Blocking + deriving (Eq, Ord, Show) -defaultReadFlags :: Set LL.ReadFlag -defaultReadFlags = Set.fromList [LL.Normal, LL.Blocking] +convertFlags :: Set ReadFlag -> CUInt +convertFlags = foldr ((.|.) . (.unwrap) . convert) 0 + where + convert = \case + Sync -> Raw.LIBEVDEV_READ_FLAG_SYNC + Normal -> Raw.LIBEVDEV_READ_FLAG_NORMAL + ForceSync -> Raw.LIBEVDEV_READ_FLAG_FORCE_SYNC + Blocking -> Raw.LIBEVDEV_READ_FLAG_BLOCKING + +defaultReadFlags :: Set ReadFlag +defaultReadFlags = Set.fromList [Normal, Blocking] -nonBlockingReadFlags :: Set LL.ReadFlag -nonBlockingReadFlags = Set.fromList [LL.Normal] +nonBlockingReadFlags :: Set ReadFlag +nonBlockingReadFlags = Set.fromList [Normal] -- | Prevent other clients (including kernel-internal ones) from receiving events. Often a bad idea. grabDevice :: Device -> IO () -grabDevice = grabDevice' LL.LibevdevGrab +grabDevice = grabDevice' Raw.LIBEVDEV_GRAB -- | Release a grabbed device. ungrabDevice :: Device -> IO () -ungrabDevice = grabDevice' LL.LibevdevUngrab +ungrabDevice = grabDevice' Raw.LIBEVDEV_UNGRAB -- | Get the next event from the device. nextEvent :: Device -> IO Event nextEvent dev = - fromCEvent <$> cErrCall "nextEvent" dev (LL.nextEvent (cDevice dev) (convertFlags defaultReadFlags)) + cErrCallDev "nextEvent" dev $ withForeignPtr (cDevice dev) \devPtr -> alloca \evPtr -> + (,) + <$> (Errno <$> Raw.libevdev_next_event devPtr (convertFlags defaultReadFlags) evPtr) + <*> (fromCEvent <$> peek evPtr) {- | Get the next event from the device, if one is available. Designed for use with devices created from a non-blocking file descriptor. Otherwise equal to @fmap Just . nextEvent@. -} nextEventMay :: Device -> IO (Maybe Event) nextEventMay dev = - fmap fromCEvent <$> cErrCall "nextEventMay" dev (LL.nextEventMay (cDevice dev) (convertFlags nonBlockingReadFlags)) - -fromCEvent :: LL.CEvent -> Event -fromCEvent (LL.CEvent t c v time) = Event (fromCEventData (t,c,v)) $ fromCTimeVal time + cErrCallDev "nextEventMay" dev $ withForeignPtr (cDevice dev) \devPtr -> alloca \evPtr -> do + err <- Raw.libevdev_next_event devPtr (convertFlags nonBlockingReadFlags) evPtr + if Errno err /= eOK + then + pure + ( if Errno -err == eAGAIN then eOK else Errno err + , Nothing + ) + else (eOK,) . Just . fromCEvent <$> peek evPtr + +fromCEvent :: Raw.Input_event -> Event +fromCEvent Raw.Input_event{type', code, value, time} = + Event + (fromCEventData (coerce type', coerce code, coerce value)) + (fromCTimeVal time) fromCEventData :: (Word16, Word16, Int32) -> EventData -fromCEventData (t, EventCode -> c, EventValue -> v) = fromMaybe (UnknownEvent t c v) $ toEnum' t >>= \case - EvSyn -> SyncEvent <$> toEnum' c - EvKey -> KeyEvent <$> toEnum' c <*> toEnum' v - EvRel -> RelativeEvent <$> toEnum' c <*> pure v - EvAbs -> AbsoluteEvent <$> toEnum' c <*> pure v - EvMsc -> MiscEvent <$> toEnum' c <*> pure v - EvSw -> SwitchEvent <$> toEnum' c <*> pure v - EvLed -> LEDEvent <$> toEnum' c <*> pure v - EvSnd -> SoundEvent <$> toEnum' c <*> pure v - EvRep -> RepeatEvent <$> toEnum' c <*> pure v +fromCEventData (t, c'@(EventCode -> c), v'@(EventValue -> v)) = fromMaybe (UnknownEvent t c v) $ toEnum' t >>= \case + EvSyn -> SyncEvent <$> toEnum' c' + EvKey -> KeyEvent <$> toEnum' c' <*> case v' of 0 -> Just Released; 1-> Just Pressed; 2-> Just Repeated; _-> Nothing + EvRel -> RelativeEvent <$> toEnum' c' <*> pure v + EvAbs -> AbsoluteEvent <$> toEnum' c' <*> pure v + EvMsc -> MiscEvent <$> toEnum' c' <*> pure v + EvSw -> SwitchEvent <$> toEnum' c' <*> pure v + EvLed -> LEDEvent <$> toEnum' c' <*> pure v + EvSnd -> SoundEvent <$> toEnum' c' <*> pure v + EvRep -> RepeatEvent <$> toEnum' c' <*> pure v EvFf -> Just $ ForceFeedbackEvent c v EvPwr -> Just $ PowerEvent c v EvFfStatus -> Just $ ForceFeedbackStatusEvent c v -toCEvent :: Event -> LL.CEvent -toCEvent (Event e time) = uncurry3 LL.CEvent (toCEventData e) $ toCTimeVal time +toCEvent :: Event -> Raw.Input_event +toCEvent (Event e time) = uncurry3 (Raw.Input_event $ toCTimeVal time) (coerce $ toCEventData e) toCEventData :: EventData -> (Word16, Word16, Int32) toCEventData = \case -- from kernel docs, 'EV_SYN event values are undefined' - we always seem to see 0, so may as well use that - SyncEvent (fromEnum' -> c) -> (fromEnum' EvSyn, c, 0) - KeyEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvKey, c, v) - RelativeEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvRel, c, v) - AbsoluteEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvAbs, c, v) - MiscEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvMsc, c, v) - SwitchEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvSw, c, v) - LEDEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvLed, c, v) - SoundEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvSnd, c, v) - RepeatEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvRep, c, v) - ForceFeedbackEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvFf, c, v) - PowerEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvPwr, c, v) - ForceFeedbackStatusEvent (fromEnum' -> c) (fromEnum' -> v) -> (fromEnum' EvFfStatus, c, v) - UnknownEvent (fromEnum' -> t) (fromEnum' -> c) (fromEnum' -> v) -> (t, c, v) - -fromCTimeVal :: LL.CTimeVal -> DiffTime -fromCTimeVal (LL.CTimeVal s us) = + SyncEvent (fromEnum' -> c) -> (fromEnum' EvSyn, c, 0) + KeyEvent (fromEnum' -> c) (fromIntegral . fromEnum -> v) -> (fromEnum' EvKey, c, v) + RelativeEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvRel, c, v) + AbsoluteEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvAbs, c, v) + MiscEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvMsc, c, v) + SwitchEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvSw, c, v) + LEDEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvLed, c, v) + SoundEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvSnd, c, v) + RepeatEvent (fromEnum' -> c) (coerce -> v) -> (fromEnum' EvRep, c, v) + ForceFeedbackEvent (coerce -> c) (coerce -> v) -> (fromEnum' EvFf, c, v) + PowerEvent (coerce -> c) (coerce -> v) -> (fromEnum' EvPwr, c, v) + ForceFeedbackStatusEvent (coerce -> c) (coerce -> v) -> (fromEnum' EvFfStatus, c, v) + UnknownEvent t (coerce -> c) (coerce -> v) -> (t, c, v) + +fromCTimeVal :: Raw.Timeval -> DiffTime +fromCTimeVal Raw.Timeval{tv_sec = s, tv_usec = us} = fromRational $ fromIntegral s + (fromIntegral us % 1_000_000) --TODO QuickCheck inverse -toCTimeVal :: DiffTime -> LL.CTimeVal -toCTimeVal t = LL.CTimeVal n (round $ f * 1_000_000) +toCTimeVal :: DiffTime -> Raw.Timeval +toCTimeVal t = Raw.Timeval n (round $ f * 1_000_000) where (n,f) = properFraction t {- | Create a device from a valid path - usually /\/dev\/input\/eventX/ for some numeric /X/. @@ -217,7 +242,10 @@ __WARNING__: Don't attempt to reuse the 'Fd' - it will be closed when the 'Devic -} newDeviceFromFd :: Fd -> IO Device newDeviceFromFd fd = do - dev <- cErrCall "newDeviceFromFd" () $ LL.newDeviceFromFd fd + dev <- cErrCall "newDeviceFromFd" mempty do + dev <- newForeignPtr Raw.libevdev_hs_close =<< Raw.libevdev_new + err <- withForeignPtr dev $ fmap Errno . flip Raw.libevdev_set_fd (coerce fd) + pure (err, dev) pid <- getProcessID path <- readSymbolicLink $ "/proc/" <> show pid <> "/fd/" <> show fd return $ Device{cDevice = dev, devicePath = pack path} @@ -227,68 +255,78 @@ evdevDir :: RawFilePath evdevDir = "/dev/input" deviceName :: Device -> IO ByteString -deviceName = join . LL.deviceName . cDevice +deviceName = join . flip withForeignPtr (fmap (packCString . unConstPtr) . Raw.libevdev_get_name . ConstPtr) . cDevice deviceFd :: Device -> IO Fd -deviceFd = LL.deviceFd . cDevice +deviceFd = flip withForeignPtr (fmap Fd . Raw.libevdev_get_fd . ConstPtr) . cDevice devicePhys :: Device -> IO (Maybe ByteString) -devicePhys = join . LL.devicePhys . cDevice +devicePhys = join . flip withForeignPtr (fmap (packCString' . unConstPtr) . Raw.libevdev_get_phys . ConstPtr) . cDevice deviceUniq :: Device -> IO (Maybe ByteString) -deviceUniq = join . LL.deviceUniq . cDevice +deviceUniq = join . flip withForeignPtr (fmap (packCString' . unConstPtr) . Raw.libevdev_get_uniq . ConstPtr) . cDevice deviceProduct :: Device -> IO Int -deviceProduct = LL.deviceProduct . cDevice +deviceProduct = flip withForeignPtr (fmap fromIntegral . Raw.libevdev_get_id_product . ConstPtr) . cDevice deviceVendor :: Device -> IO Int -deviceVendor = LL.deviceVendor . cDevice +deviceVendor = flip withForeignPtr (fmap fromIntegral . Raw.libevdev_get_id_vendor . ConstPtr) . cDevice deviceBustype :: Device -> IO Int -deviceBustype = LL.deviceBustype . cDevice +deviceBustype = flip withForeignPtr (fmap fromIntegral . Raw.libevdev_get_id_bustype . ConstPtr) . cDevice deviceVersion :: Device -> IO Int -deviceVersion = LL.deviceVersion . cDevice +deviceVersion = flip withForeignPtr (fmap fromIntegral . Raw.libevdev_get_id_version . ConstPtr) . cDevice deviceProperties :: Device -> IO [DeviceProperty] -deviceProperties dev = filterM (LL.hasProperty $ cDevice dev) enumerate +deviceProperties (Device dev _) = enumerate' & filterM \prop -> withForeignPtr dev \p -> + toBool <$> Raw.libevdev_has_property (ConstPtr p) (fromEnum' prop) deviceEventTypes :: Device -> IO [EventType] -deviceEventTypes dev = filterM (LL.hasEventType $ cDevice dev) enumerate +deviceEventTypes (Device dev _) = enumerate' & filterM \et -> withForeignPtr dev \p -> + toBool <$> Raw.libevdev_has_event_type (ConstPtr p) (fromEnum' et) --TODO this is an imperfect API since '_val' is ignored entirely deviceHasEvent :: Device -> EventData -> IO Bool -deviceHasEvent dev e = LL.hasEventCode (cDevice dev) typ code - where (typ,code,_val) = toCEventData e - -deviceAbsAxis :: Device -> AbsoluteAxis -> IO (Maybe LL.AbsInfo) -deviceAbsAxis dev = LL.getAbsInfo (cDevice dev) . fromEnum' +deviceHasEvent (Device dev _) e = withForeignPtr dev \p -> + toBool <$> Raw.libevdev_has_event_code (ConstPtr p) (fromIntegral t) (fromIntegral c) + where + (t, c, _v) = toCEventData e + +data AbsInfo = AbsInfo + { absValue :: Int32 + , absMinimum :: Int32 + , absMaximum :: Int32 + , absFuzz :: Int32 + , absFlat :: Int32 + , absResolution :: Int32 + } + deriving (Show) + +deviceAbsAxis :: Device -> AbsoluteAxis -> IO (Maybe AbsInfo) +deviceAbsAxis dev (fromEnum' -> code) = withForeignPtr (cDevice dev) \devPtr -> + (unConstPtr <$> Raw.libevdev_get_abs_info (ConstPtr devPtr) (CUInt code)) + >>= handleNull (pure Nothing) \absInfoPtr -> + peek absInfoPtr <&> \raw -> + Just + AbsInfo + { absValue = coerce raw.value + , absMinimum = coerce raw.minimum + , absMaximum = coerce raw.maximum + , absFuzz = coerce raw.fuzz + , absFlat = coerce raw.flat + , absResolution = coerce raw.resolution + } + +data LEDValue = LedOn | LedOff + deriving (Bounded, Eq, Ord, Read, Show) -- | Set the state of a LED on a device. -setDeviceLED :: Device -> LEDEvent -> LL.LEDValue -> IO () -setDeviceLED dev led val = cErrCall "setDeviceLED" dev (LL.libevdev_kernel_set_led_value (cDevice dev) led val) +setDeviceLED :: Device -> LEDEvent -> LEDValue -> IO () +setDeviceLED dev led val = cErrCallDev "setDeviceLED" dev $ withForeignPtr (cDevice dev) \devPtr -> + Errno <$> Raw.libevdev_kernel_set_led_value devPtr (fromEnum' led) case val of + LedOn -> Raw.LIBEVDEV_LED_ON + LedOff -> Raw.LIBEVDEV_LED_OFF {- Util -} -grabDevice' :: LL.GrabMode -> Device -> IO () -grabDevice' mode dev = cErrCall "grabDevice" dev $ - LL.grabDevice (cDevice dev) mode - -{- -TODO this is a workaround until c2hs has a better story for enum conversions - when we remove it we can get rid of '-fno-state-hack' - -based on profiling, and Debug.Trace, it seems that 'enumMap' is computed no more times than necessary - (6 - number of combinations of a and k that it is called with) - but based on https://www.reddit.com/r/haskell/comments/grskne/help_reasoning_about_performance_memoization/, - it's possible that behaviour is worse without profiling on (argh...) - -open c2hs issue - we perhaps essentially want the `CEnum` class proposed at: https://github.com/haskell/c2hs/issues/78 - but perhaps belonging (at least initially) in c2hs rather than base, for expediency - this doesn't necessarily consider enum defines though - discussion is around capturing the semantics of actual C enums - alternatively, monomorphic functions for each type, as with c2hs's with* functions --} -toEnum' :: forall k a. (Ord k, Enum k, Bounded a, Enum a) => k -> Maybe a -toEnum' = (enumMap !?) - where - --TODO HashMap, IntMap? - enumMap :: Map k a - enumMap = Map.fromList $ map (toEnum . fromEnum &&& id) enumerate +grabDevice' :: Raw.Libevdev_grab_mode -> Device -> IO () +grabDevice' mode dev = cErrCallDev "grabDevice" dev $ + withForeignPtr (cDevice dev) $ fmap Errno . flip Raw.libevdev_grab mode -instance CErrInfo Device where - cErrInfo = return . Just . devicePath +cErrCallDev :: CErrCall a => String -> Device -> IO a -> IO (CErrCallRes a) +cErrCallDev f = cErrCall f . return . Just . devicePath diff --git a/evdev/src/Evdev/Codes.chs b/evdev/src/Evdev/Codes.chs deleted file mode 100644 index f1bbf02..0000000 --- a/evdev/src/Evdev/Codes.chs +++ /dev/null @@ -1,811 +0,0 @@ -{- -TODO haddock doesn't quite work correctly with LINE pragmas - https://github.com/haskell/haddock/issues/441 - for now we can work around this by deleting the pragmas before upload to hackage - -seems to be on its way to being fixed with `.hie` files (enable `-fwrite-ide-info`) - https://github.com/haskell/haddock/commit/8bc3c2990475a254e168fbdb005af93f9397b19c --} - --- | Datatypes corresponding to the constants in [input-event-codes.h](https://github.com/torvalds/linux/blob/master/include/uapi/linux/input-event-codes.h). --- See [the Linux Kernel documentation](https://www.kernel.org/doc/html/latest/input/event-codes.html) for full details, noting that all names have been mechanically transformed into CamelCase. -module Evdev.Codes - ( EventType(..) - , SyncEvent(..) - , Key - ( .. - , KeyHanguel - , KeyCoffee - , KeyDirection - , KeyBrightnessZero - , KeyWimax - , BtnMisc - , BtnMouse - , BtnTrigger - , BtnGamepad - , BtnSouth - , BtnEast - , BtnNorth - , BtnWest - , BtnDigi - , BtnWheel - , KeyBrightnessToggle - , BtnTriggerHappy ) - , RelativeAxis(..) - , AbsoluteAxis(..) - , SwitchEvent(..) - , MiscEvent(..) - , LEDEvent(..) - , RepeatEvent(..) - , SoundEvent(..) - , DeviceProperty(..) - ) where - -#include - --- | Each of these corresponds to one of the contructors of 'Evdev.EventData'. So you're unlikely to need to use these directly (C doesn't have ADTs - we do). -{#enum define EventType { - EV_SYN as EvSyn, - EV_KEY as EvKey, - EV_REL as EvRel, - EV_ABS as EvAbs, - EV_MSC as EvMsc, - EV_SW as EvSw, - EV_LED as EvLed, - EV_SND as EvSnd, - EV_REP as EvRep, - EV_FF as EvFf, - EV_PWR as EvPwr, - EV_FF_STATUS as EvFfStatus} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | Synchronization events -{#enum define SyncEvent { - SYN_REPORT as SynReport, -- | Used to separate packets of simultaneous events - SYN_CONFIG as SynConfig, - SYN_MT_REPORT as SynMtReport, - SYN_DROPPED as SynDropped} --TODO handle SYN_DROPPED automatically for streams - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | Keys and buttons -{#enum define Key { - KEY_RESERVED as KeyReserved, - KEY_ESC as KeyEsc, - KEY_1 as Key1, - KEY_2 as Key2, - KEY_3 as Key3, - KEY_4 as Key4, - KEY_5 as Key5, - KEY_6 as Key6, - KEY_7 as Key7, - KEY_8 as Key8, - KEY_9 as Key9, - KEY_0 as Key0, - KEY_MINUS as KeyMinus, - KEY_EQUAL as KeyEqual, - KEY_BACKSPACE as KeyBackspace, - KEY_TAB as KeyTab, - KEY_Q as KeyQ, - KEY_W as KeyW, - KEY_E as KeyE, - KEY_R as KeyR, - KEY_T as KeyT, - KEY_Y as KeyY, - KEY_U as KeyU, - KEY_I as KeyI, - KEY_O as KeyO, - KEY_P as KeyP, - KEY_LEFTBRACE as KeyLeftbrace, - KEY_RIGHTBRACE as KeyRightbrace, - KEY_ENTER as KeyEnter, - KEY_LEFTCTRL as KeyLeftctrl, - KEY_A as KeyA, - KEY_S as KeyS, - KEY_D as KeyD, - KEY_F as KeyF, - KEY_G as KeyG, - KEY_H as KeyH, - KEY_J as KeyJ, - KEY_K as KeyK, - KEY_L as KeyL, - KEY_SEMICOLON as KeySemicolon, - KEY_APOSTROPHE as KeyApostrophe, - KEY_GRAVE as KeyGrave, - KEY_LEFTSHIFT as KeyLeftshift, - KEY_BACKSLASH as KeyBackslash, - KEY_Z as KeyZ, - KEY_X as KeyX, - KEY_C as KeyC, - KEY_V as KeyV, - KEY_B as KeyB, - KEY_N as KeyN, - KEY_M as KeyM, - KEY_COMMA as KeyComma, - KEY_DOT as KeyDot, - KEY_SLASH as KeySlash, - KEY_RIGHTSHIFT as KeyRightshift, - KEY_KPASTERISK as KeyKpasterisk, - KEY_LEFTALT as KeyLeftalt, - KEY_SPACE as KeySpace, - KEY_CAPSLOCK as KeyCapslock, - KEY_F1 as KeyF1, - KEY_F2 as KeyF2, - KEY_F3 as KeyF3, - KEY_F4 as KeyF4, - KEY_F5 as KeyF5, - KEY_F6 as KeyF6, - KEY_F7 as KeyF7, - KEY_F8 as KeyF8, - KEY_F9 as KeyF9, - KEY_F10 as KeyF10, - KEY_NUMLOCK as KeyNumlock, - KEY_SCROLLLOCK as KeyScrolllock, - KEY_KP7 as KeyKp7, - KEY_KP8 as KeyKp8, - KEY_KP9 as KeyKp9, - KEY_KPMINUS as KeyKpminus, - KEY_KP4 as KeyKp4, - KEY_KP5 as KeyKp5, - KEY_KP6 as KeyKp6, - KEY_KPPLUS as KeyKpplus, - KEY_KP1 as KeyKp1, - KEY_KP2 as KeyKp2, - KEY_KP3 as KeyKp3, - KEY_KP0 as KeyKp0, - KEY_KPDOT as KeyKpdot, - KEY_ZENKAKUHANKAKU as KeyZenkakuhankaku, - KEY_102ND as Key102nd, - KEY_F11 as KeyF11, - KEY_F12 as KeyF12, - KEY_RO as KeyRo, - KEY_KATAKANA as KeyKatakana, - KEY_HIRAGANA as KeyHiragana, - KEY_HENKAN as KeyHenkan, - KEY_KATAKANAHIRAGANA as KeyKatakanahiragana, - KEY_MUHENKAN as KeyMuhenkan, - KEY_KPJPCOMMA as KeyKpjpcomma, - KEY_KPENTER as KeyKpenter, - KEY_RIGHTCTRL as KeyRightctrl, - KEY_KPSLASH as KeyKpslash, - KEY_SYSRQ as KeySysrq, - KEY_RIGHTALT as KeyRightalt, - KEY_LINEFEED as KeyLinefeed, - KEY_HOME as KeyHome, - KEY_UP as KeyUp, - KEY_PAGEUP as KeyPageup, - KEY_LEFT as KeyLeft, - KEY_RIGHT as KeyRight, - KEY_END as KeyEnd, - KEY_DOWN as KeyDown, - KEY_PAGEDOWN as KeyPagedown, - KEY_INSERT as KeyInsert, - KEY_DELETE as KeyDelete, - KEY_MACRO as KeyMacro, - KEY_MUTE as KeyMute, - KEY_VOLUMEDOWN as KeyVolumedown, - KEY_VOLUMEUP as KeyVolumeup, - KEY_POWER as KeyPower, - KEY_KPEQUAL as KeyKpequal, - KEY_KPPLUSMINUS as KeyKpplusminus, - KEY_PAUSE as KeyPause, - KEY_SCALE as KeyScale, - KEY_KPCOMMA as KeyKpcomma, - KEY_HANGEUL as KeyHangeul, - -- KEY_HANGUEL as KeyHanguel, (alias of KEY_HANGEUL) - KEY_HANJA as KeyHanja, - KEY_YEN as KeyYen, - KEY_LEFTMETA as KeyLeftmeta, - KEY_RIGHTMETA as KeyRightmeta, - KEY_COMPOSE as KeyCompose, - KEY_STOP as KeyStop, - KEY_AGAIN as KeyAgain, - KEY_PROPS as KeyProps, - KEY_UNDO as KeyUndo, - KEY_FRONT as KeyFront, - KEY_COPY as KeyCopy, - KEY_OPEN as KeyOpen, - KEY_PASTE as KeyPaste, - KEY_FIND as KeyFind, - KEY_CUT as KeyCut, - KEY_HELP as KeyHelp, - KEY_MENU as KeyMenu, - KEY_CALC as KeyCalc, - KEY_SETUP as KeySetup, - KEY_SLEEP as KeySleep, - KEY_WAKEUP as KeyWakeup, - KEY_FILE as KeyFile, - KEY_SENDFILE as KeySendfile, - KEY_DELETEFILE as KeyDeletefile, - KEY_XFER as KeyXfer, - KEY_PROG1 as KeyProg1, - KEY_PROG2 as KeyProg2, - KEY_WWW as KeyWww, - KEY_MSDOS as KeyMsdos, - -- KEY_COFFEE as KeyCoffee, (alias of KEY_SCREENLOCK) - KEY_SCREENLOCK as KeyScreenlock, - KEY_ROTATE_DISPLAY as KeyRotateDisplay, - -- KEY_DIRECTION as KeyDirection, (alias of KEY_ROTATE_DISPLAY) - KEY_CYCLEWINDOWS as KeyCyclewindows, - KEY_MAIL as KeyMail, - KEY_BOOKMARKS as KeyBookmarks, - KEY_COMPUTER as KeyComputer, - KEY_BACK as KeyBack, - KEY_FORWARD as KeyForward, - KEY_CLOSECD as KeyClosecd, - KEY_EJECTCD as KeyEjectcd, - KEY_EJECTCLOSECD as KeyEjectclosecd, - KEY_NEXTSONG as KeyNextsong, - KEY_PLAYPAUSE as KeyPlaypause, - KEY_PREVIOUSSONG as KeyPrevioussong, - KEY_STOPCD as KeyStopcd, - KEY_RECORD as KeyRecord, - KEY_REWIND as KeyRewind, - KEY_PHONE as KeyPhone, - KEY_ISO as KeyIso, - KEY_CONFIG as KeyConfig, - KEY_HOMEPAGE as KeyHomepage, - KEY_REFRESH as KeyRefresh, - KEY_EXIT as KeyExit, - KEY_MOVE as KeyMove, - KEY_EDIT as KeyEdit, - KEY_SCROLLUP as KeyScrollup, - KEY_SCROLLDOWN as KeyScrolldown, - KEY_KPLEFTPAREN as KeyKpleftparen, - KEY_KPRIGHTPAREN as KeyKprightparen, - KEY_NEW as KeyNew, - KEY_REDO as KeyRedo, - KEY_F13 as KeyF13, - KEY_F14 as KeyF14, - KEY_F15 as KeyF15, - KEY_F16 as KeyF16, - KEY_F17 as KeyF17, - KEY_F18 as KeyF18, - KEY_F19 as KeyF19, - KEY_F20 as KeyF20, - KEY_F21 as KeyF21, - KEY_F22 as KeyF22, - KEY_F23 as KeyF23, - KEY_F24 as KeyF24, - KEY_PLAYCD as KeyPlaycd, - KEY_PAUSECD as KeyPausecd, - KEY_PROG3 as KeyProg3, - KEY_PROG4 as KeyProg4, - KEY_DASHBOARD as KeyDashboard, - KEY_SUSPEND as KeySuspend, - KEY_CLOSE as KeyClose, - KEY_PLAY as KeyPlay, - KEY_FASTFORWARD as KeyFastforward, - KEY_BASSBOOST as KeyBassboost, - KEY_PRINT as KeyPrint, - KEY_HP as KeyHp, - KEY_CAMERA as KeyCamera, - KEY_SOUND as KeySound, - KEY_QUESTION as KeyQuestion, - KEY_EMAIL as KeyEmail, - KEY_CHAT as KeyChat, - KEY_SEARCH as KeySearch, - KEY_CONNECT as KeyConnect, - KEY_FINANCE as KeyFinance, - KEY_SPORT as KeySport, - KEY_SHOP as KeyShop, - KEY_ALTERASE as KeyAlterase, - KEY_CANCEL as KeyCancel, - KEY_BRIGHTNESSDOWN as KeyBrightnessdown, - KEY_BRIGHTNESSUP as KeyBrightnessup, - KEY_MEDIA as KeyMedia, - KEY_SWITCHVIDEOMODE as KeySwitchvideomode, - KEY_KBDILLUMTOGGLE as KeyKbdillumtoggle, - KEY_KBDILLUMDOWN as KeyKbdillumdown, - KEY_KBDILLUMUP as KeyKbdillumup, - KEY_SEND as KeySend, - KEY_REPLY as KeyReply, - KEY_FORWARDMAIL as KeyForwardmail, - KEY_SAVE as KeySave, - KEY_DOCUMENTS as KeyDocuments, - KEY_BATTERY as KeyBattery, - KEY_BLUETOOTH as KeyBluetooth, - KEY_WLAN as KeyWlan, - KEY_UWB as KeyUwb, - KEY_UNKNOWN as KeyUnknown, - KEY_VIDEO_NEXT as KeyVideoNext, - KEY_VIDEO_PREV as KeyVideoPrev, - KEY_BRIGHTNESS_CYCLE as KeyBrightnessCycle, - KEY_BRIGHTNESS_AUTO as KeyBrightnessAuto, - -- KEY_BRIGHTNESS_ZERO as KeyBrightnessZero, (alias of KEY_BRIGHTNESS_AUTO) - KEY_DISPLAY_OFF as KeyDisplayOff, - KEY_WWAN as KeyWwan, - -- KEY_WIMAX as KeyWimax, (alias of KEY_WWAN) - KEY_RFKILL as KeyRfkill, - KEY_MICMUTE as KeyMicmute, - -- BTN_MISC as BtnMisc, (alias of BTN_0) - BTN_0 as Btn0, - BTN_1 as Btn1, - BTN_2 as Btn2, - BTN_3 as Btn3, - BTN_4 as Btn4, - BTN_5 as Btn5, - BTN_6 as Btn6, - BTN_7 as Btn7, - BTN_8 as Btn8, - BTN_9 as Btn9, - -- BTN_MOUSE as BtnMouse, (alias of BTN_LEFT) - BTN_LEFT as BtnLeft, - BTN_RIGHT as BtnRight, - BTN_MIDDLE as BtnMiddle, - BTN_SIDE as BtnSide, - BTN_EXTRA as BtnExtra, - BTN_FORWARD as BtnForward, - BTN_BACK as BtnBack, - BTN_TASK as BtnTask, - BTN_JOYSTICK as BtnJoystick, - -- BTN_TRIGGER as BtnTrigger, (alias of BTN_JOYSTICK) - BTN_THUMB as BtnThumb, - BTN_THUMB2 as BtnThumb2, - BTN_TOP as BtnTop, - BTN_TOP2 as BtnTop2, - BTN_PINKIE as BtnPinkie, - BTN_BASE as BtnBase, - BTN_BASE2 as BtnBase2, - BTN_BASE3 as BtnBase3, - BTN_BASE4 as BtnBase4, - BTN_BASE5 as BtnBase5, - BTN_BASE6 as BtnBase6, - BTN_DEAD as BtnDead, - -- BTN_GAMEPAD as BtnGamepad, (alias of BTN_A) - -- BTN_SOUTH as BtnSouth, (alias of BTN_A) - BTN_A as BtnA, - -- BTN_EAST as BtnEast, (alias of BTN_B) - BTN_B as BtnB, - BTN_C as BtnC, - -- BTN_NORTH as BtnNorth, (alias of BTN_X) - BTN_X as BtnX, - -- BTN_WEST as BtnWest, (alias of BTN_Y) - BTN_Y as BtnY, - BTN_Z as BtnZ, - BTN_TL as BtnTl, - BTN_TR as BtnTr, - BTN_TL2 as BtnTl2, - BTN_TR2 as BtnTr2, - BTN_SELECT as BtnSelect, - BTN_START as BtnStart, - BTN_MODE as BtnMode, - BTN_THUMBL as BtnThumbl, - BTN_THUMBR as BtnThumbr, - -- BTN_DIGI as BtnDigi, (alias of BTN_TOOL_PEN) - BTN_TOOL_PEN as BtnToolPen, - BTN_TOOL_RUBBER as BtnToolRubber, - BTN_TOOL_BRUSH as BtnToolBrush, - BTN_TOOL_PENCIL as BtnToolPencil, - BTN_TOOL_AIRBRUSH as BtnToolAirbrush, - BTN_TOOL_FINGER as BtnToolFinger, - BTN_TOOL_MOUSE as BtnToolMouse, - BTN_TOOL_LENS as BtnToolLens, - BTN_TOOL_QUINTTAP as BtnToolQuinttap, - BTN_TOUCH as BtnTouch, - BTN_STYLUS as BtnStylus, - BTN_STYLUS2 as BtnStylus2, - BTN_TOOL_DOUBLETAP as BtnToolDoubletap, - BTN_TOOL_TRIPLETAP as BtnToolTripletap, - BTN_TOOL_QUADTAP as BtnToolQuadtap, - -- BTN_WHEEL as BtnWheel, (alias of BTN_GEAR_DOWN) - BTN_GEAR_DOWN as BtnGearDown, - BTN_GEAR_UP as BtnGearUp, - KEY_OK as KeyOk, - KEY_SELECT as KeySelect, - KEY_GOTO as KeyGoto, - KEY_CLEAR as KeyClear, - KEY_POWER2 as KeyPower2, - KEY_OPTION as KeyOption, - KEY_INFO as KeyInfo, - KEY_TIME as KeyTime, - KEY_VENDOR as KeyVendor, - KEY_ARCHIVE as KeyArchive, - KEY_PROGRAM as KeyProgram, - KEY_CHANNEL as KeyChannel, - KEY_FAVORITES as KeyFavorites, - KEY_EPG as KeyEpg, - KEY_PVR as KeyPvr, - KEY_MHP as KeyMhp, - KEY_LANGUAGE as KeyLanguage, - KEY_TITLE as KeyTitle, - KEY_SUBTITLE as KeySubtitle, - KEY_ANGLE as KeyAngle, - KEY_ZOOM as KeyZoom, - KEY_MODE as KeyMode, - KEY_KEYBOARD as KeyKeyboard, - KEY_SCREEN as KeyScreen, - KEY_PC as KeyPc, - KEY_TV as KeyTv, - KEY_TV2 as KeyTv2, - KEY_VCR as KeyVcr, - KEY_VCR2 as KeyVcr2, - KEY_SAT as KeySat, - KEY_SAT2 as KeySat2, - KEY_CD as KeyCd, - KEY_TAPE as KeyTape, - KEY_RADIO as KeyRadio, - KEY_TUNER as KeyTuner, - KEY_PLAYER as KeyPlayer, - KEY_TEXT as KeyText, - KEY_DVD as KeyDvd, - KEY_AUX as KeyAux, - KEY_MP3 as KeyMp3, - KEY_AUDIO as KeyAudio, - KEY_VIDEO as KeyVideo, - KEY_DIRECTORY as KeyDirectory, - KEY_LIST as KeyList, - KEY_MEMO as KeyMemo, - KEY_CALENDAR as KeyCalendar, - KEY_RED as KeyRed, - KEY_GREEN as KeyGreen, - KEY_YELLOW as KeyYellow, - KEY_BLUE as KeyBlue, - KEY_CHANNELUP as KeyChannelup, - KEY_CHANNELDOWN as KeyChanneldown, - KEY_FIRST as KeyFirst, - KEY_LAST as KeyLast, - KEY_AB as KeyAb, - KEY_NEXT as KeyNext, - KEY_RESTART as KeyRestart, - KEY_SLOW as KeySlow, - KEY_SHUFFLE as KeyShuffle, - KEY_BREAK as KeyBreak, - KEY_PREVIOUS as KeyPrevious, - KEY_DIGITS as KeyDigits, - KEY_TEEN as KeyTeen, - KEY_TWEN as KeyTwen, - KEY_VIDEOPHONE as KeyVideophone, - KEY_GAMES as KeyGames, - KEY_ZOOMIN as KeyZoomin, - KEY_ZOOMOUT as KeyZoomout, - KEY_ZOOMRESET as KeyZoomreset, - KEY_WORDPROCESSOR as KeyWordprocessor, - KEY_EDITOR as KeyEditor, - KEY_SPREADSHEET as KeySpreadsheet, - KEY_GRAPHICSEDITOR as KeyGraphicseditor, - KEY_PRESENTATION as KeyPresentation, - KEY_DATABASE as KeyDatabase, - KEY_NEWS as KeyNews, - KEY_VOICEMAIL as KeyVoicemail, - KEY_ADDRESSBOOK as KeyAddressbook, - KEY_MESSENGER as KeyMessenger, - KEY_DISPLAYTOGGLE as KeyDisplaytoggle, - -- KEY_BRIGHTNESS_TOGGLE as KeyBrightnessToggle, (alias of KEY_DISPLAYTOGGLE) - KEY_SPELLCHECK as KeySpellcheck, - KEY_LOGOFF as KeyLogoff, - KEY_DOLLAR as KeyDollar, - KEY_EURO as KeyEuro, - KEY_FRAMEBACK as KeyFrameback, - KEY_FRAMEFORWARD as KeyFrameforward, - KEY_CONTEXT_MENU as KeyContextMenu, - KEY_MEDIA_REPEAT as KeyMediaRepeat, - KEY_10CHANNELSUP as Key10channelsup, - KEY_10CHANNELSDOWN as Key10channelsdown, - KEY_IMAGES as KeyImages, - KEY_DEL_EOL as KeyDelEol, - KEY_DEL_EOS as KeyDelEos, - KEY_INS_LINE as KeyInsLine, - KEY_DEL_LINE as KeyDelLine, - KEY_FN as KeyFn, - KEY_FN_ESC as KeyFnEsc, - KEY_FN_F1 as KeyFnF1, - KEY_FN_F2 as KeyFnF2, - KEY_FN_F3 as KeyFnF3, - KEY_FN_F4 as KeyFnF4, - KEY_FN_F5 as KeyFnF5, - KEY_FN_F6 as KeyFnF6, - KEY_FN_F7 as KeyFnF7, - KEY_FN_F8 as KeyFnF8, - KEY_FN_F9 as KeyFnF9, - KEY_FN_F10 as KeyFnF10, - KEY_FN_F11 as KeyFnF11, - KEY_FN_F12 as KeyFnF12, - KEY_FN_1 as KeyFn1, - KEY_FN_2 as KeyFn2, - KEY_FN_D as KeyFnD, - KEY_FN_E as KeyFnE, - KEY_FN_F as KeyFnF, - KEY_FN_S as KeyFnS, - KEY_FN_B as KeyFnB, - KEY_BRL_DOT1 as KeyBrlDot1, - KEY_BRL_DOT2 as KeyBrlDot2, - KEY_BRL_DOT3 as KeyBrlDot3, - KEY_BRL_DOT4 as KeyBrlDot4, - KEY_BRL_DOT5 as KeyBrlDot5, - KEY_BRL_DOT6 as KeyBrlDot6, - KEY_BRL_DOT7 as KeyBrlDot7, - KEY_BRL_DOT8 as KeyBrlDot8, - KEY_BRL_DOT9 as KeyBrlDot9, - KEY_BRL_DOT10 as KeyBrlDot10, - KEY_NUMERIC_0 as KeyNumeric0, - KEY_NUMERIC_1 as KeyNumeric1, - KEY_NUMERIC_2 as KeyNumeric2, - KEY_NUMERIC_3 as KeyNumeric3, - KEY_NUMERIC_4 as KeyNumeric4, - KEY_NUMERIC_5 as KeyNumeric5, - KEY_NUMERIC_6 as KeyNumeric6, - KEY_NUMERIC_7 as KeyNumeric7, - KEY_NUMERIC_8 as KeyNumeric8, - KEY_NUMERIC_9 as KeyNumeric9, - KEY_NUMERIC_STAR as KeyNumericStar, - KEY_NUMERIC_POUND as KeyNumericPound, - KEY_NUMERIC_A as KeyNumericA, - KEY_NUMERIC_B as KeyNumericB, - KEY_NUMERIC_C as KeyNumericC, - KEY_NUMERIC_D as KeyNumericD, - KEY_CAMERA_FOCUS as KeyCameraFocus, - KEY_WPS_BUTTON as KeyWpsButton, - KEY_TOUCHPAD_TOGGLE as KeyTouchpadToggle, - KEY_TOUCHPAD_ON as KeyTouchpadOn, - KEY_TOUCHPAD_OFF as KeyTouchpadOff, - KEY_CAMERA_ZOOMIN as KeyCameraZoomin, - KEY_CAMERA_ZOOMOUT as KeyCameraZoomout, - KEY_CAMERA_UP as KeyCameraUp, - KEY_CAMERA_DOWN as KeyCameraDown, - KEY_CAMERA_LEFT as KeyCameraLeft, - KEY_CAMERA_RIGHT as KeyCameraRight, - KEY_ATTENDANT_ON as KeyAttendantOn, - KEY_ATTENDANT_OFF as KeyAttendantOff, - KEY_ATTENDANT_TOGGLE as KeyAttendantToggle, - KEY_LIGHTS_TOGGLE as KeyLightsToggle, - BTN_DPAD_UP as BtnDpadUp, - BTN_DPAD_DOWN as BtnDpadDown, - BTN_DPAD_LEFT as BtnDpadLeft, - BTN_DPAD_RIGHT as BtnDpadRight, - KEY_ALS_TOGGLE as KeyAlsToggle, - KEY_BUTTONCONFIG as KeyButtonconfig, - KEY_TASKMANAGER as KeyTaskmanager, - KEY_JOURNAL as KeyJournal, - KEY_CONTROLPANEL as KeyControlpanel, - KEY_APPSELECT as KeyAppselect, - KEY_SCREENSAVER as KeyScreensaver, - KEY_VOICECOMMAND as KeyVoicecommand, - KEY_BRIGHTNESS_MIN as KeyBrightnessMin, - KEY_BRIGHTNESS_MAX as KeyBrightnessMax, - KEY_KBDINPUTASSIST_PREV as KeyKbdinputassistPrev, - KEY_KBDINPUTASSIST_NEXT as KeyKbdinputassistNext, - KEY_KBDINPUTASSIST_PREVGROUP as KeyKbdinputassistPrevgroup, - KEY_KBDINPUTASSIST_NEXTGROUP as KeyKbdinputassistNextgroup, - KEY_KBDINPUTASSIST_ACCEPT as KeyKbdinputassistAccept, - KEY_KBDINPUTASSIST_CANCEL as KeyKbdinputassistCancel, - -- BTN_TRIGGER_HAPPY as BtnTriggerHappy, (alias of BTN_TRIGGER_HAPPY1) - BTN_TRIGGER_HAPPY1 as BtnTriggerHappy1, - BTN_TRIGGER_HAPPY2 as BtnTriggerHappy2, - BTN_TRIGGER_HAPPY3 as BtnTriggerHappy3, - BTN_TRIGGER_HAPPY4 as BtnTriggerHappy4, - BTN_TRIGGER_HAPPY5 as BtnTriggerHappy5, - BTN_TRIGGER_HAPPY6 as BtnTriggerHappy6, - BTN_TRIGGER_HAPPY7 as BtnTriggerHappy7, - BTN_TRIGGER_HAPPY8 as BtnTriggerHappy8, - BTN_TRIGGER_HAPPY9 as BtnTriggerHappy9, - BTN_TRIGGER_HAPPY10 as BtnTriggerHappy10, - BTN_TRIGGER_HAPPY11 as BtnTriggerHappy11, - BTN_TRIGGER_HAPPY12 as BtnTriggerHappy12, - BTN_TRIGGER_HAPPY13 as BtnTriggerHappy13, - BTN_TRIGGER_HAPPY14 as BtnTriggerHappy14, - BTN_TRIGGER_HAPPY15 as BtnTriggerHappy15, - BTN_TRIGGER_HAPPY16 as BtnTriggerHappy16, - BTN_TRIGGER_HAPPY17 as BtnTriggerHappy17, - BTN_TRIGGER_HAPPY18 as BtnTriggerHappy18, - BTN_TRIGGER_HAPPY19 as BtnTriggerHappy19, - BTN_TRIGGER_HAPPY20 as BtnTriggerHappy20, - BTN_TRIGGER_HAPPY21 as BtnTriggerHappy21, - BTN_TRIGGER_HAPPY22 as BtnTriggerHappy22, - BTN_TRIGGER_HAPPY23 as BtnTriggerHappy23, - BTN_TRIGGER_HAPPY24 as BtnTriggerHappy24, - BTN_TRIGGER_HAPPY25 as BtnTriggerHappy25, - BTN_TRIGGER_HAPPY26 as BtnTriggerHappy26, - BTN_TRIGGER_HAPPY27 as BtnTriggerHappy27, - BTN_TRIGGER_HAPPY28 as BtnTriggerHappy28, - BTN_TRIGGER_HAPPY29 as BtnTriggerHappy29, - BTN_TRIGGER_HAPPY30 as BtnTriggerHappy30, - BTN_TRIGGER_HAPPY31 as BtnTriggerHappy31, - BTN_TRIGGER_HAPPY32 as BtnTriggerHappy32, - BTN_TRIGGER_HAPPY33 as BtnTriggerHappy33, - BTN_TRIGGER_HAPPY34 as BtnTriggerHappy34, - BTN_TRIGGER_HAPPY35 as BtnTriggerHappy35, - BTN_TRIGGER_HAPPY36 as BtnTriggerHappy36, - BTN_TRIGGER_HAPPY37 as BtnTriggerHappy37, - BTN_TRIGGER_HAPPY38 as BtnTriggerHappy38, - BTN_TRIGGER_HAPPY39 as BtnTriggerHappy39, - BTN_TRIGGER_HAPPY40 as BtnTriggerHappy40} - deriving (Bounded, Eq, Ord, Read, Show) #} - -pattern KeyHanguel :: Key -pattern KeyHanguel = KeyHangeul - -pattern KeyCoffee :: Key -pattern KeyCoffee = KeyScreenlock - -pattern KeyDirection :: Key -pattern KeyDirection = KeyRotateDisplay - -pattern KeyBrightnessZero :: Key -pattern KeyBrightnessZero = KeyBrightnessAuto - -pattern KeyWimax :: Key -pattern KeyWimax = KeyWwan - -pattern BtnMisc :: Key -pattern BtnMisc = Btn0 - -pattern BtnMouse :: Key -pattern BtnMouse = BtnLeft - -pattern BtnTrigger :: Key -pattern BtnTrigger = BtnJoystick - -pattern BtnGamepad :: Key -pattern BtnGamepad = BtnA - -pattern BtnSouth :: Key -pattern BtnSouth = BtnA - -pattern BtnEast :: Key -pattern BtnEast = BtnB - -pattern BtnNorth :: Key -pattern BtnNorth = BtnX - -pattern BtnWest :: Key -pattern BtnWest = BtnY - -pattern BtnDigi :: Key -pattern BtnDigi = BtnToolPen - -pattern BtnWheel :: Key -pattern BtnWheel = BtnGearDown - -pattern KeyBrightnessToggle :: Key -pattern KeyBrightnessToggle = KeyDisplaytoggle - -pattern BtnTriggerHappy :: Key -pattern BtnTriggerHappy = BtnTriggerHappy1 - --- | Relative changes -#if defined(REL_WHEEL_HI_RES) -{#enum define RelativeAxis { - REL_X as RelX, - REL_Y as RelY, - REL_Z as RelZ, - REL_RX as RelRx, - REL_RY as RelRy, - REL_RZ as RelRz, - REL_HWHEEL as RelHwheel, - REL_DIAL as RelDial, - REL_WHEEL as RelWheel, - REL_MISC as RelMisc, - REL_RESERVED as RelReserved, - REL_WHEEL_HI_RES as RelWheelHiRes, - REL_HWHEEL_HI_RES as RelHWheelHiRes} - deriving (Bounded, Eq, Ord, Read, Show) #} -# else -{#enum define RelativeAxis { - REL_X as RelX, - REL_Y as RelY, - REL_Z as RelZ, - REL_RX as RelRx, - REL_RY as RelRy, - REL_RZ as RelRz, - REL_HWHEEL as RelHwheel, - REL_DIAL as RelDial, - REL_WHEEL as RelWheel, - REL_MISC as RelMisc, - REL_RESERVED as RelReserved} - deriving (Bounded, Eq, Ord, Read, Show) #} -#endif - --- | Absolute changes -{#enum define AbsoluteAxis { - ABS_X as AbsX, - ABS_Y as AbsY, - ABS_Z as AbsZ, - ABS_RX as AbsRx, - ABS_RY as AbsRy, - ABS_RZ as AbsRz, - ABS_THROTTLE as AbsThrottle, - ABS_RUDDER as AbsRudder, - ABS_WHEEL as AbsWheel, - ABS_GAS as AbsGas, - ABS_BRAKE as AbsBrake, - ABS_HAT0X as AbsHat0x, - ABS_HAT0Y as AbsHat0y, - ABS_HAT1X as AbsHat1x, - ABS_HAT1Y as AbsHat1y, - ABS_HAT2X as AbsHat2x, - ABS_HAT2Y as AbsHat2y, - ABS_HAT3X as AbsHat3x, - ABS_HAT3Y as AbsHat3y, - ABS_PRESSURE as AbsPressure, - ABS_DISTANCE as AbsDistance, - ABS_TILT_X as AbsTiltX, - ABS_TILT_Y as AbsTiltY, - ABS_TOOL_WIDTH as AbsToolWidth, - ABS_VOLUME as AbsVolume, - ABS_MISC as AbsMisc, - ABS_RESERVED as AbsReserved, - ABS_MT_SLOT as AbsMtSlot, - ABS_MT_TOUCH_MAJOR as AbsMtTouchMajor, - ABS_MT_TOUCH_MINOR as AbsMtTouchMinor, - ABS_MT_WIDTH_MAJOR as AbsMtWidthMajor, - ABS_MT_WIDTH_MINOR as AbsMtWidthMinor, - ABS_MT_ORIENTATION as AbsMtOrientation, - ABS_MT_POSITION_X as AbsMtPositionX, - ABS_MT_POSITION_Y as AbsMtPositionY, - ABS_MT_TOOL_TYPE as AbsMtToolType, - ABS_MT_BLOB_ID as AbsMtBlobId, - ABS_MT_TRACKING_ID as AbsMtTrackingId, - ABS_MT_PRESSURE as AbsMtPressure, - ABS_MT_DISTANCE as AbsMtDistance, - ABS_MT_TOOL_X as AbsMtToolX, - ABS_MT_TOOL_Y as AbsMtToolY} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | Stateful binary switches -{#enum define SwitchEvent { - SW_LID as SwLid, - SW_TABLET_MODE as SwTabletMode, - SW_HEADPHONE_INSERT as SwHeadphoneInsert, - SW_RFKILL_ALL as SwRfkillAll, - SW_RADIO as SwRadio, - SW_MICROPHONE_INSERT as SwMicrophoneInsert, - SW_DOCK as SwDock, - SW_LINEOUT_INSERT as SwLineoutInsert, - SW_JACK_PHYSICAL_INSERT as SwJackPhysicalInsert, - SW_VIDEOOUT_INSERT as SwVideooutInsert, - SW_CAMERA_LENS_COVER as SwCameraLensCover, - SW_KEYPAD_SLIDE as SwKeypadSlide, - SW_FRONT_PROXIMITY as SwFrontProximity, - SW_ROTATE_LOCK as SwRotateLock, - SW_LINEIN_INSERT as SwLineinInsert, - SW_MUTE_DEVICE as SwMuteDevice} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | Miscellaneous -{#enum define MiscEvent { - MSC_SERIAL as MscSerial, - MSC_PULSELED as MscPulseled, - MSC_GESTURE as MscGesture, - MSC_RAW as MscRaw, - MSC_SCAN as MscScan, - MSC_TIMESTAMP as MscTimestamp} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | LEDs -{#enum define LEDEvent { - LED_NUML as LedNuml, - LED_CAPSL as LedCapsl, - LED_SCROLLL as LedScrolll, - LED_COMPOSE as LedCompose, - LED_KANA as LedKana, - LED_SLEEP as LedSleep, - LED_SUSPEND as LedSuspend, - LED_MUTE as LedMute, - LED_MISC as LedMisc, - LED_MAIL as LedMail, - LED_CHARGING as LedCharging} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | Specifying autorepeating events -{#enum define RepeatEvent { - REP_DELAY as RepDelay, - REP_PERIOD as RepPeriod} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | For simple sound output devices -{#enum define SoundEvent { - SND_CLICK as SndClick, - SND_BELL as SndBell, - SND_TONE as SndTone} - deriving (Bounded, Eq, Ord, Read, Show) #} - --- | Device properties -{#enum define DeviceProperty { - INPUT_PROP_POINTER as InputPropPointer, - INPUT_PROP_DIRECT as InputPropDirect, - INPUT_PROP_BUTTONPAD as InputPropButtonpad, - INPUT_PROP_SEMI_MT as InputPropSemiMt, - INPUT_PROP_TOPBUTTONPAD as InputPropTopbuttonpad, - INPUT_PROP_POINTING_STICK as InputPropPointingStick, - INPUT_PROP_ACCELEROMETER as InputPropAccelerometer} - deriving (Bounded, Eq, Ord, Read, Show) #} diff --git a/evdev/src/Evdev/Codes.hs b/evdev/src/Evdev/Codes.hs new file mode 100644 index 0000000..28f216a --- /dev/null +++ b/evdev/src/Evdev/Codes.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | Datatypes corresponding to the constants in [input-event-codes.h](https://github.com/torvalds/linux/blob/master/include/uapi/linux/input-event-codes.h). +See [the Linux Kernel documentation](https://www.kernel.org/doc/html/latest/input/event-codes.html) for full details, noting that all names have been mechanically transformed into CamelCase. +-} +module Evdev.Codes where + +import Control.Monad +import Evdev.Codes.Generator +import Language.Haskell.TH +import System.Directory +import System.Environment +import System.FilePath +import Util + +-- TODO `hs-bindgen` has no support for macro-based enums like `c2hs` does +-- ideally we'd just add `hashInclude "linux/input-event-codes.h"` to our `hs-bindgen` invocation and totally avoid this +$( do + candidates <- + runIO $ + map (<> "/linux/input-event-codes.h") + . (<> ["/usr/include"]) + . maybe [] splitSearchPath + <$> lookupEnv "C_INCLUDE_PATH" + runIO (filterM doesFileExist candidates) >>= \case + d : _ -> generateCodes d + [] -> error $ "Could not find input-event-codes.h. Install Linux headers or try setting C_INCLUDE_PATH." + ) diff --git a/evdev/src/Evdev/Codes/Generator.hs b/evdev/src/Evdev/Codes/Generator.hs new file mode 100644 index 0000000..3395964 --- /dev/null +++ b/evdev/src/Evdev/Codes/Generator.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Evdev.Codes.Generator (generateCodes) where + +import Data.Bifunctor +import Data.Char +import Data.Either +import Data.Foldable +import Data.Functor +import Data.List +import Data.List.Extra +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map.Ordered qualified as OMap +import Data.Map.Strict qualified as Map +import Data.Maybe +import Language.Haskell.TH +import Text.Read + +data CodeType + = EventType + | SyncEvent + | Key + | RelativeAxis + | AbsoluteAxis + | SwitchEvent + | MiscEvent + | LEDEvent + | RepeatEvent + | SoundEvent + | DeviceProperty + deriving (Eq, Ord, Show, Enum, Bounded) +codeTypePrefixes :: CodeType -> [String] +codeTypePrefixes = \case + EventType -> ["EV"] + SyncEvent -> ["SYN"] + Key -> ["KEY", "BTN"] + RelativeAxis -> ["REL"] + AbsoluteAxis -> ["ABS"] + SwitchEvent -> ["SW"] + MiscEvent -> ["MSC"] + LEDEvent -> ["LED"] + RepeatEvent -> ["REP"] + SoundEvent -> ["SND"] + DeviceProperty -> ["INPUT_PROP"] +codeTypeDoc :: CodeType -> String +codeTypeDoc = \case + EventType -> + """ + Each of these corresponds to one of the constructors of 'Evdev.EventData'. + So you're unlikely to need to use these directly (C doesn't have ADTs - we do). + """ + SyncEvent -> "Synchronization events" + Key -> "Keys and buttons" + RelativeAxis -> "Relative changes" + AbsoluteAxis -> "Absolute changes" + SwitchEvent -> "Stateful binary switches" + MiscEvent -> "Miscellaneous" + LEDEvent -> "LEDs" + RepeatEvent -> "Specifying autorepeating events" + SoundEvent -> "For simple sound output devices" + DeviceProperty -> "Device properties" + +data Define = Define + { name :: MacroName + , value :: Either Integer MacroName + } + +parseDefineLine :: String -> Maybe Define +parseDefineLine line = case words line of + ("#define" : k@(MacroName -> name) : v : _) + | any (`isSuffixOf` k) metaSuffices -> Nothing + | Just n <- readMaybe v -> Just Define{name, value = Left n} + | otherwise -> Just Define{name, value = Right $ MacroName v} + _ -> Nothing + where + metaSuffices = + [ "_MAX" + , "_CNT" + , "_MIN_INTERESTING" + ] + +parseHeader :: String -> [(CodeType, [Define])] +parseHeader input = + Map.toList + . foldr (uncurry $ Map.adjust . (:)) (Map.fromList $ map (,[]) enumerate) + . map (\d@Define{name = MacroName name} -> (d, snd . unwrap name $ find ((`isPrefixOf` name) . fst) prefixes)) + . mapMaybe parseDefineLine + $ lines input + where + unwrap name = fromMaybe (error $ "no prefix matched: " <> show name) + prefixes = concatMap (\t -> (,t) <$> codeTypePrefixes t) enumerate + +processType :: [Define] -> [(ConstructorName, (Integer, [PatternName]))] +processType defs = + map (first toConstructorName) . OMap.assocs $ + foldl' + (flip \(alias, target) -> OMap.alter (fmap $ second (toPatternName alias :)) target) + litsByPrimary + aliasMacros + where + (litMacros, aliasMacros) = partitionEithers $ defs <&> \Define{name, value} -> bimap (name,) (name,) value + litsByValue = foldl' (flip \(name, value) -> Map.insertWith ((<>)) value (pure name)) Map.empty litMacros + -- when multiple literal macros point to the same value, turn all but the first in to pattern synonyms + litsByPrimary = OMap.fromList . map (\(n, k :| as) -> (k, (n, map toPatternName as))) $ Map.toList litsByValue + +newtype MacroName = MacroName String deriving newtype (Eq, Ord, Show) +newtype TypeName = TypeName Name deriving newtype (Eq, Ord, Show) +newtype ConstructorName = ConstructorName Name deriving newtype (Eq, Ord, Show) +newtype PatternName = PatternName Name deriving newtype (Eq, Ord, Show) + +generateCodes :: FilePath -> Q [Dec] +generateCodes path = do + contents <- runIO $ readFile path + pure + . concatMap + ( uncurry (uncurry . generateType) + . bimap + (TypeName . mkName . show) + (foldMap (\(k, (n, as)) -> (([(k, n)], map (,k) as))) . processType) + ) + $ parseHeader contents + +generateType :: TypeName -> [(ConstructorName, Integer)] -> [(PatternName, ConstructorName)] -> [Dec] +generateType name constructors patterns = + [ dataType name $ map fst constructors + , simpleEnumInstance name constructors + ] + <> concatMap (uncurry $ patternSynonym name) patterns + +dataType :: TypeName -> [ConstructorName] -> Dec +dataType (TypeName tyName) conNames = + DataD + [] + tyName + [] + Nothing + (conNames <&> \(ConstructorName s) -> NormalC s []) + [DerivClause Nothing (map ConT [''Eq, ''Ord, ''Read, ''Show])] + +simpleEnumInstance :: TypeName -> [(ConstructorName, Integer)] -> Dec +simpleEnumInstance (TypeName tyName) conNames = + InstanceD + Nothing + [] + (AppT (ConT (mkName "SimpleEnum")) (ConT tyName)) + [ FunD + (mkName "enumerate'") + [ Clause + [] + (NormalB (ListE $ conNames <&> \(ConstructorName s, _) -> ConE s)) + [] + ] + , FunD + (mkName "toEnum'") + [ let n = mkName "n" + in Clause + [VarP n] + ( GuardedB + ( map + ( \(ConstructorName con, val) -> + ( NormalG + ( InfixE + (Just (VarE n)) + (VarE '(==)) + (Just (LitE (IntegerL val))) + ) + , AppE (ConE 'Just) (ConE con) + ) + ) + conNames + <> [(NormalG (VarE 'otherwise), ConE 'Nothing)] + ) + ) + [] + ] + , FunD + (mkName "fromEnum'") + [ Clause + [] + ( NormalB + ( LamCaseE + ( map + ( \(ConstructorName con, val) -> + Match + (ConP con [] []) + (NormalB (LitE (IntegerL val))) + [] + ) + conNames + ) + ) + ) + [] + ] + ] + +patternSynonym :: TypeName -> PatternName -> ConstructorName -> [Dec] +patternSynonym (TypeName tyName) (PatternName pat) (ConstructorName con) = + [ PatSynSigD pat (ConT tyName) + , PatSynD pat (PrefixPatSyn []) ImplBidir (ConP con [] []) + ] + +-- KEY_LEFT_SHIFT -> KeyLeftShift +toConstructorName :: MacroName -> ConstructorName +toPatternName :: MacroName -> PatternName +(toConstructorName, toPatternName) = (f ConstructorName, f PatternName) + where + f c (MacroName s) = c . mkName . concatMap titleCase . splitOn "_" $ s + titleCase = \case + [] -> [] + c : cs -> toUpper c : map toLower cs diff --git a/evdev/src/Evdev/LowLevel.chs b/evdev/src/Evdev/LowLevel.chs deleted file mode 100644 index e99c365..0000000 --- a/evdev/src/Evdev/LowLevel.chs +++ /dev/null @@ -1,205 +0,0 @@ -module Evdev.LowLevel where - -import Control.Monad (join) -import Data.ByteString (ByteString,packCString,useAsCString) -import Data.Coerce (coerce) -import Data.Int (Int32,Int64) -import Data.Word (Word16, Word32) -import Foreign (Ptr,allocaBytes,mallocBytes,mallocForeignPtrBytes,newForeignPtr_,nullPtr,peek,withForeignPtr) -import Foreign.C (CInt(..),CLong(..),CUInt(..),CUShort(..),CString) -import Foreign.C.Error (Errno(Errno), eOK, eAGAIN) -import System.Posix.Types (Fd(Fd)) - -import Evdev.Codes - -#include -#include -#include -#include - -{#enum libevdev_read_flag as ReadFlag { - LIBEVDEV_READ_FLAG_SYNC as Sync, - LIBEVDEV_READ_FLAG_NORMAL as Normal, - LIBEVDEV_READ_FLAG_FORCE_SYNC as ForceSync, - LIBEVDEV_READ_FLAG_BLOCKING as Blocking } - deriving (Eq,Ord,Show) #} - -{#enum libevdev_grab_mode as GrabMode { underscoreToCase } deriving (Show) #} - -{#pointer *libevdev as Device foreign finalizer libevdev_hs_close newtype #} ---TODO any reason c2hs doesn't allow a haskell function as the finalizer? - -- failing that, any reason not to have actual inline c? ---TODO expose this directly, seeing as the GC makes no guarantees of promptness -#c -void libevdev_hs_close(struct libevdev *dev); -#endc - -{#pointer *libevdev_uinput as UDevice foreign finalizer libevdev_uinput_destroy newtype #} - ---TODO '{#enum libevdev_uinput_open_mode {} #}' results in malformed output - c2hs bug -{#enum libevdev_uinput_open_mode as UInputOpenMode {LIBEVDEV_UINPUT_OPEN_MANAGED as UOMManaged} #} - - -data CEvent = CEvent - { cEventType :: Word16 - , cEventCode :: Word16 - , cEventValue :: Int32 - , cEventTime :: CTimeVal - } - deriving (Eq, Ord, Read, Show) - -data CTimeVal = CTimeVal - { tvSec :: Int64 - , tvUsec :: Int64 - } - deriving (Eq, Ord, Read, Show) - - -{- Complex stuff -} - -{#fun libevdev_next_event { `Device', `CUInt', `Ptr ()' } -> `Errno' Errno #} -nextEvent :: Device -> CUInt -> IO (Errno, CEvent) -nextEvent dev flags = allocaBytes {#sizeof input_event #} $ \evPtr -> - (,) <$> libevdev_next_event dev flags evPtr <*> getEvent evPtr -nextEventMay :: Device -> CUInt -> IO (Errno, Maybe CEvent) -nextEventMay dev flags = allocaBytes {#sizeof input_event #} $ \evPtr -> do - err <- libevdev_next_event dev flags evPtr - if err /= eOK - then return - ( if negateErrno err == eAGAIN then eOK else err - , Nothing - ) - else (eOK,) . Just <$> getEvent evPtr -getEvent :: Ptr () -> IO CEvent -getEvent evPtr = CEvent - <$> (coerce <$> {#get input_event->type #} evPtr) - <*> (coerce <$> {#get input_event->code #} evPtr) - <*> (coerce <$> {#get input_event->value #} evPtr) - <*> ( CTimeVal - <$> (coerce <$> {#get input_event->time.tv_sec #} evPtr) - <*> (coerce <$> {#get input_event->time.tv_usec #} evPtr) - ) - -{#fun libevdev_grab { `Device', `GrabMode' } -> `Errno' Errno #} -grabDevice :: Device -> GrabMode -> IO Errno -grabDevice = libevdev_grab - ---TODO use 'libevdev_new_from_fd' when https://github.com/haskell/c2hs/issues/236 fixed -{#fun libevdev_new {} -> `Device' #} -{#fun libevdev_set_fd { `Device', unFd `Fd' } -> `Errno' Errno #} -newDeviceFromFd :: Fd -> IO (Errno, Device) -newDeviceFromFd fd = libevdev_new >>= \dev -> (, dev) <$> libevdev_set_fd dev fd - ---TODO 'useAsCString' copies, which seems unnecessary due to the 'const' in the C function -{#fun libevdev_set_name { `Device', `CString' } -> `()' #} -setDeviceName :: Device -> ByteString -> IO () -setDeviceName dev name = useAsCString name $ libevdev_set_name dev -{#fun libevdev_set_phys { `Device', `CString' } -> `()' #} -setDevicePhys :: Device -> ByteString -> IO () -setDevicePhys dev phys = useAsCString phys $ libevdev_set_phys dev -{#fun libevdev_set_uniq { `Device', `CString' } -> `()' #} -setDeviceUniq :: Device -> ByteString -> IO () -setDeviceUniq dev uniq = useAsCString uniq $ libevdev_set_uniq dev - ---TODO c2hs can't seem to help us here due to the nested pointer -foreign import ccall safe "Evdev/LowLevel.chs.h libevdev_uinput_create_from_device" - libevdev_uinput_create_from_device :: Ptr Device -> CInt -> Ptr (Ptr UDevice) -> IO CInt -createFromDevice :: Device -> Fd -> IO (Errno, UDevice) -createFromDevice dev (Fd fd) = withDevice dev $ \devP -> do - devFPP <- mallocForeignPtrBytes 0 - (e,x) <- withForeignPtr devFPP $ \devPP -> - (,) <$> libevdev_uinput_create_from_device devP fd devPP <*> peek devPP - devFP <- newForeignPtr_ x - return (Errno e, UDevice devFP) - ---TODO since the same technique produces just one 'IO' for 'deviceName', is this another c2hs bug? -{#fun libevdev_uinput_get_syspath { `UDevice' } -> `IO (Maybe ByteString)' packCString' #} -getSyspath :: UDevice -> IO (Maybe ByteString) -getSyspath = join . libevdev_uinput_get_syspath -{#fun libevdev_uinput_get_devnode { `UDevice' } -> `IO (Maybe ByteString)' packCString' #} -getDevnode :: UDevice -> IO (Maybe ByteString) -getDevnode = join . libevdev_uinput_get_devnode - -data AbsInfo = AbsInfo - { absValue :: Int32 - , absMinimum :: Int32 - , absMaximum :: Int32 - , absFuzz :: Int32 - , absFlat :: Int32 - , absResolution :: Int32 - } - deriving (Show) -withAbsInfo :: AbsInfo -> (Ptr () -> IO a) -> IO a -withAbsInfo AbsInfo{..} f = do - p <- mallocBytes {#sizeof input_absinfo#} - {#set input_absinfo.value#} p $ CInt absValue - {#set input_absinfo.minimum#} p $ CInt absMinimum - {#set input_absinfo.maximum#} p $ CInt absMaximum - {#set input_absinfo.fuzz#} p $ CInt absFuzz - {#set input_absinfo.flat#} p $ CInt absFlat - {#set input_absinfo.resolution#} p $ CInt absResolution - pf <- newForeignPtr_ p - withForeignPtr pf f - ---TODO can c2hs make this simpler at all? -foreign import ccall safe "Evdev/LowLevel.chs.h libevdev_get_abs_info" - libevdev_get_abs_info :: Ptr Device -> CUInt -> IO (Ptr ()) -getAbsInfo :: Device -> Word32 -> IO (Maybe AbsInfo) -getAbsInfo dev x = withDevice dev \devPtr -> - libevdev_get_abs_info devPtr (CUInt x) >>= handleNull (pure Nothing) \absinfoPtr -> do - CInt absValue <- {#get input_absinfo.value#} absinfoPtr - CInt absMinimum <- {#get input_absinfo.minimum#} absinfoPtr - CInt absMaximum <- {#get input_absinfo.maximum#} absinfoPtr - CInt absFuzz <- {#get input_absinfo.fuzz#} absinfoPtr - CInt absFlat <- {#get input_absinfo.flat#} absinfoPtr - CInt absResolution <- {#get input_absinfo.resolution#} absinfoPtr - pure $ Just AbsInfo{..} - - -{- Simpler functions -} - -{#fun libevdev_has_property as hasProperty { `Device', convertEnum `DeviceProperty' } -> `Bool' #} -{#fun libevdev_has_event_type as hasEventType { `Device', convertEnum `EventType' } -> `Bool' #} -{#fun libevdev_has_event_code as hasEventCode { `Device', `Word16', `Word16' } -> `Bool' #} -{#fun libevdev_get_fd as deviceFd { `Device' } -> `Fd' Fd #} -{#fun libevdev_get_name as deviceName { `Device' } -> `IO ByteString' packCString #} -{#fun libevdev_get_phys as devicePhys { `Device' } -> `IO (Maybe ByteString)' packCString' #} -{#fun libevdev_get_uniq as deviceUniq { `Device' } -> `IO (Maybe ByteString)' packCString' #} -{#fun libevdev_get_id_product as deviceProduct { `Device' } -> `Int' #} -{#fun libevdev_get_id_vendor as deviceVendor { `Device' } -> `Int' #} -{#fun libevdev_get_id_bustype as deviceBustype { `Device' } -> `Int' #} -{#fun libevdev_get_id_version as deviceVersion { `Device' } -> `Int' #} -{#fun libevdev_set_id_product { `Device', `Int' } -> `()' #} -{#fun libevdev_set_id_vendor { `Device', `Int' } -> `()' #} -{#fun libevdev_set_id_bustype { `Device', `Int' } -> `()' #} -{#fun libevdev_set_id_version { `Device', `Int' } -> `()' #} -{#fun libevdev_enable_event_type as enableType { `Device', `Word16' } -> `Errno' Errno #} -{#fun libevdev_enable_event_code as enableCode { `Device', `Word16', `Word16', `Ptr ()' } -> `Errno' Errno #} -{#fun libevdev_uinput_write_event as writeEvent { `UDevice', `Word16', `Word16', `Int32' } -> `Errno' Errno #} - --- | LEDs values -{#enum define LEDValue { - LIBEVDEV_LED_ON as LedOn, - LIBEVDEV_LED_OFF as LedOff} - deriving (Bounded, Eq, Ord, Read, Show) #} -{#fun libevdev_kernel_set_led_value { `Device', convertEnum `LEDEvent', `LEDValue' } -> `Errno' Errno #} - -{- Util -} - -convertEnum :: (Enum a, Integral b) => a -> b -convertEnum = fromIntegral . fromEnum - -(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -(.:) = (.) . (.) - -unFd :: Fd -> CInt -unFd (Fd n) = n - -handleNull :: b -> (Ptr a -> b) -> Ptr a -> b -handleNull def f p = if p == nullPtr then def else f p - -packCString' :: CString -> IO (Maybe ByteString) -packCString' = handleNull (return Nothing) (fmap Just . packCString) - -negateErrno :: Errno -> Errno -negateErrno (Errno cint) = Errno (-cint) diff --git a/evdev/src/Evdev/Raw.hs b/evdev/src/Evdev/Raw.hs new file mode 100644 index 0000000..7d2a4e0 --- /dev/null +++ b/evdev/src/Evdev/Raw.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Evdev.Raw where + +import Data.Char +import Data.List +import Data.Maybe +import Foreign +import HsBindgen.Runtime.LibC qualified +import HsBindgen.TH +import Language.Haskell.TH +import System.Process + +do + libevdev <- + dropWhileEnd isSpace + . fromMaybe (error "bad pkg-config response") + . stripPrefix "-I" + <$> runIO (readProcess "pkg-config" ["--cflags-only-I", "libevdev"] "") + withHsBindgen + def + { clang = def{extraIncludeDirs = [Dir libevdev]} + , fieldNamingStrategy = OmitFieldPrefixes + , programSlicing = EnableProgramSlicing + } + def + { categoryChoice = + def + { cUnsafe = ExcludeCategory + , cFunPtr = IncludeTermCategory $ RenameTerm (<> "_funptr") + } + } + do + hashInclude "libevdev/libevdev.h" + hashInclude "libevdev/libevdev-uinput.h" + +foreign import ccall "&libevdev_hs_close" libevdev_hs_close :: FinalizerPtr Libevdev diff --git a/evdev/src/Evdev/Uinput.hs b/evdev/src/Evdev/Uinput.hs index c609767..0008ab0 100644 --- a/evdev/src/Evdev/Uinput.hs +++ b/evdev/src/Evdev/Uinput.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + -- | Create virtual input devices. module Evdev.Uinput ( Device, @@ -22,18 +24,22 @@ module Evdev.Uinput ( import Control.Monad import Control.Monad.State import Data.Foldable -import Data.Tuple.Extra +import Data.Function import Foreign +import Foreign.C +import Foreign.C.ConstPtr +import Data.ByteString (useAsCString) import Data.ByteString.Char8 (ByteString) +import Data.Coerce (coerce) import Evdev hiding (Device, newDevice) import Evdev.Codes -import qualified Evdev.LowLevel as LL +import qualified Evdev.Raw as Raw import Util -- | A `uinput` device. -newtype Device = Device LL.UDevice +newtype Device = Device (ForeignPtr Raw.Libevdev_uinput) -- | Create a new `uinput` device. newDevice :: @@ -42,52 +48,61 @@ newDevice :: DeviceOpts -> IO Device newDevice name DeviceOpts{..} = do - dev <- LL.libevdev_new - LL.setDeviceName dev name - - let maybeSet :: (LL.Device -> a -> IO ()) -> Maybe a -> IO () - maybeSet = maybe mempty . ($ dev) - maybeSet LL.setDevicePhys phys - maybeSet LL.setDeviceUniq uniq - maybeSet LL.libevdev_set_id_product idProduct - maybeSet LL.libevdev_set_id_vendor idVendor - maybeSet LL.libevdev_set_id_bustype idBustype - maybeSet LL.libevdev_set_id_version idVersion - - let enable :: Ptr () -> EventType -> [Word16] -> IO () - enable ptr t cs = do - unless (null cs) $ cec $ LL.enableType dev t' - forM_ cs $ \c -> cec $ LL.enableCode dev t' c ptr + dev <- newForeignPtr Raw.libevdev_hs_close =<< Raw.libevdev_new + withForeignPtr dev \p -> useAsCString name $ Raw.libevdev_set_name p . ConstPtr + + for_ phys \x -> withForeignPtr dev \p -> useAsCString x $ Raw.libevdev_set_phys p . ConstPtr + for_ uniq \x -> withForeignPtr dev \p -> useAsCString x $ Raw.libevdev_set_uniq p . ConstPtr + for_ idProduct \x -> withForeignPtr dev \p -> Raw.libevdev_set_id_product p $ fromIntegral x + for_ idVendor \x -> withForeignPtr dev \p -> Raw.libevdev_set_id_vendor p $ fromIntegral x + for_ idBustype \x -> withForeignPtr dev \p -> Raw.libevdev_set_id_bustype p $ fromIntegral x + for_ idVersion \x -> withForeignPtr dev \p -> Raw.libevdev_set_id_version p $ fromIntegral x + + let enable (dataPtr :: Maybe (Either (Ptr Raw.Input_absinfo) (Ptr CInt))) t cs = do + unless (null cs) $ cec $ withForeignPtr dev \devPtr -> + Errno <$> Raw.libevdev_enable_event_type devPtr t' + forM_ cs $ \c -> cec $ withForeignPtr dev \devPtr -> + Errno <$> Raw.libevdev_enable_event_code devPtr t' (fromIntegral @Word16 @CUInt $ coerce c) + (ConstPtr $ maybe nullPtr (either castPtr castPtr) dataPtr) where t' = fromEnum' t mapM_ - (uncurry $ enable nullPtr) - [ (EvKey, map fromEnum' keys) - , (EvRel, map fromEnum' relAxes) - , (EvMsc, map fromEnum' miscs) - , (EvSw, map fromEnum' switchs) - , (EvLed, map fromEnum' leds) - , (EvSnd, map fromEnum' sounds) - , (EvFf, map fromEnum' ffs) - , (EvPwr, map fromEnum' powers) - , (EvFfStatus, map fromEnum' ffStats) + (uncurry $ enable Nothing) + [ (EvKey, map (EventCode . fromEnum') keys) + , (EvRel, map (EventCode . fromEnum') relAxes) + , (EvMsc, map (EventCode . fromEnum') miscs) + , (EvSw, map (EventCode . fromEnum') switchs) + , (EvLed, map (EventCode . fromEnum') leds) + , (EvSnd, map (EventCode . fromEnum') sounds) + , (EvFf, ffs) + , (EvPwr, powers) + , (EvFfStatus, ffStats) ] - forM_ reps $ \(rep, n) -> do - pf <- mallocForeignPtr - withForeignPtr pf \p -> do - poke p n - enable (castPtr p) EvRep [fromEnum' rep] - - forM_ absAxes $ \(axis, absInfo) -> - LL.withAbsInfo absInfo $ \ptr -> - enable ptr EvAbs [fromEnum' axis] - - fmap Device $ cec $ LL.createFromDevice dev $ fromEnum' LL.UOMManaged + forM_ reps \(rep, n) -> with (fromIntegral n) \p -> + enable (Just $ Right p) EvRep [EventCode $ fromEnum' rep] + + forM_ absAxes \(axis, AbsInfo{..}) -> + Raw.Input_absinfo + { value = coerce absValue + , minimum = coerce absMinimum + , maximum = coerce absMaximum + , fuzz = coerce absFuzz + , flat = coerce absFlat + , resolution = coerce absResolution + } + & flip with \ptr -> enable (Just $ Left ptr) EvAbs [EventCode $ fromEnum' axis] + + withForeignPtr dev \devPtr -> alloca \pp -> do + cec $ Errno <$> Raw.libevdev_uinput_create_from_device + (ConstPtr devPtr) + (coerce (Raw.LIBEVDEV_UINPUT_OPEN_MANAGED).unwrap) + pp + fmap Device . newForeignPtr Raw.libevdev_uinput_destroy_funptr =<< peek pp where cec :: CErrCall a => IO a -> IO (CErrCallRes a) - cec = cErrCall "newDevice" () + cec = cErrCall "newDevice" mempty data DeviceOpts = DeviceOpts { phys :: Maybe ByteString @@ -98,7 +113,7 @@ data DeviceOpts = DeviceOpts , idVersion :: Maybe Int , keys :: [Key] , relAxes :: [RelativeAxis] - , absAxes :: [(AbsoluteAxis, LL.AbsInfo)] + , absAxes :: [(AbsoluteAxis, AbsInfo)] , miscs :: [MiscEvent] , switchs :: [SwitchEvent] , leds :: [LEDEvent] @@ -132,8 +147,12 @@ defaultDeviceOpts = -- | Write a single event. Doesn't issue a sync event, so: @writeEvent dev e /= writeBatch dev [e]@. writeEvent :: Device -> EventData -> IO () -writeEvent (Device dev) e = do - cErrCall "writeEvent" dev $ uncurry3 (LL.writeEvent dev) $ toCEventData e +writeEvent (Device dev) e = + withForeignPtr dev \devPtr -> cErrCall "writeEvent" (deviceSyspath $ Device dev) $ + Errno <$> Raw.libevdev_uinput_write_event (ConstPtr devPtr) (fromIntegral t) (fromIntegral c) (fromIntegral v) + where + (t, c, v) = toCEventData e + -- | Write several events followed by a 'SynReport'. writeBatch :: Foldable t => Device -> t EventData -> IO () @@ -142,9 +161,9 @@ writeBatch dev es = do writeEvent dev $ SyncEvent SynReport deviceSyspath :: Device -> IO (Maybe ByteString) -deviceSyspath = LL.getSyspath . \(Device d) -> d +deviceSyspath (Device dev) = withForeignPtr dev $ packCString' . unConstPtr <=< Raw.libevdev_uinput_get_syspath deviceDevnode :: Device -> IO (Maybe ByteString) -deviceDevnode = LL.getDevnode . \(Device d) -> d +deviceDevnode (Device dev) = withForeignPtr dev $ packCString' . unConstPtr <=< Raw.libevdev_uinput_get_devnode -- | Make options for a device capable of precisely the events in the list. deviceOptsFromEvents :: diff --git a/evdev/src/Util.hs b/evdev/src/Util.hs index 269cf4e..6d5f9d8 100644 --- a/evdev/src/Util.hs +++ b/evdev/src/Util.hs @@ -1,31 +1,42 @@ module Util where +import Data.ByteString (ByteString, packCString) import qualified Data.ByteString.Char8 as BS +import Data.Tuple (swap) +import Foreign (Ptr, nullPtr) +import Foreign.C (CString) import Foreign.C.Error (Errno (Errno), errnoToIOError) import System.Posix.ByteString (RawFilePath) -import qualified Evdev.LowLevel as LL +{- | A modified form of `Enum`. +Older versions of this library had some odd c2hs-based `Enum` instances. +This was introduced to avoid silently breaking code which used those old versions. +This type class is also easier to write instances for, particularly via code generation. +-} +class SimpleEnum a where + enumerate' :: [a] + -- | Returns `Nothing` when input is out of bounds. + toEnum' :: (Integral n) => n -> Maybe a + -- | Instances will typically use `fromInteger`, so e.g. will wrap around when converting a large enum to a `Word8`. + fromEnum' :: (Num n) => a -> n -fromEnum' :: (Num c, Enum a) => a -> c -fromEnum' = fromIntegral . fromEnum +handleNull :: b -> (Ptr a -> b) -> Ptr a -> b +handleNull def f p = if p == nullPtr then def else f p + +packCString' :: CString -> IO (Maybe ByteString) +packCString' = handleNull (return Nothing) (fmap Just . packCString) + +toBool :: (Eq a, Num a) => a -> Bool +toBool = (/= 0) --TODO careful - for some C calls (eg. libevdev_enable_event_code), -- int returned doesn't necessarily correspond to a particular error number --TODO this kinda seems like overkill, but things were getting ugly without it... -class CErrInfo a where - cErrInfo :: a -> IO (Maybe RawFilePath) -instance CErrInfo () where - cErrInfo () = return Nothing -instance CErrInfo RawFilePath where - cErrInfo = pure . pure -instance CErrInfo LL.UDevice where - cErrInfo = LL.getSyspath - -- for c actions which return an error value (0 for success) -- run the action, throwing a relevant exception if the C errno is not 0 class CErrCall a where type CErrCallRes a - cErrCall :: CErrInfo info => String -> info -> IO a -> IO (CErrCallRes a) + cErrCall :: String -> IO (Maybe RawFilePath) -> IO a -> IO (CErrCallRes a) instance CErrCall Errno where type CErrCallRes Errno = () cErrCall func path x = cErrCall func path $ (,()) <$> x @@ -36,5 +47,8 @@ instance CErrCall (Errno, a) where case errno of Errno 0 -> return res Errno n -> do - path' <- cErrInfo info + path' <- info ioError $ errnoToIOError func (Errno $ abs n) Nothing $ BS.unpack <$> path' +instance CErrCall (IO a, Errno) where + type CErrCallRes (IO a, Errno) = a + cErrCall func info x = cErrCall @(Errno, a) func info $ sequence =<< swap <$> x diff --git a/evdev/test/Test.hs b/evdev/test/Test.hs index f68aecf..2fb5773 100644 --- a/evdev/test/Test.hs +++ b/evdev/test/Test.hs @@ -11,13 +11,15 @@ import Data.Maybe import Data.Time import Evdev import Evdev.Codes -import qualified Evdev.Uinput as Uinput +import Evdev.Uinput qualified as Uinput +import Foreign.C import RawFilePath import System.FilePath.ByteString import System.IO.Error import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import Util main :: IO () main = defaultMain $ testGroup "Tests" [smoke, inverses] @@ -29,8 +31,9 @@ smoke :: TestTree smoke = testCase "Smoke" do start <- newEmptyMVar let duName = "evdev-test-device" - keys = [Key1 .. Key0] + keys = mapMaybe (toEnum' @_ @Integer) [fromEnum' Key1 .. fromEnum' Key0] evs = concatMap ((<$> [Pressed, Released]) . KeyEvent) keys + assertEqual "10 keys" 10 $ length keys du <- Uinput.newDevice duName Uinput.defaultDeviceOpts{Uinput.keys} void $ forkIO do takeMVar start -- wait until reading device is initialised @@ -44,7 +47,7 @@ smoke = testCase "Smoke" do putMVar start () (@?= Nothing) =<< devicePhys d (@?= Nothing) =<< deviceUniq d - (@?= [EvSyn, EvKey]) =<< deviceEventTypes d + (@?= [EvKey, EvSyn]) =<< deviceEventTypes d evs' <- whileJust ((\x -> guard (x /= last evs) $> x) . eventData <$> nextEvent d) pure filter (/= SyncEvent SynReport) evs' @?= init evs @@ -54,12 +57,14 @@ inverses = [ testGroup "TimeVal" [ testProperty "1" \(s, us) -> - let tv = CTimeVal s us + let tv = Timeval (fromIntegral @CLong s) (fromIntegral @CLong us) in s < 0 || us < 0 || us >= 1_000_000 || toCTimeVal (fromCTimeVal tv) == tv , testProperty "2" \n -> - let -- 'toCTimeVal' goes from picoseconds to microseconds + let + -- 'toCTimeVal' goes from picoseconds to microseconds resolutionFactor = 1_000_000 - in abs (diffTimeToPicoseconds (fromCTimeVal . toCTimeVal $ picosecondsToDiffTime n) - n) + in + abs (diffTimeToPicoseconds (fromCTimeVal . toCTimeVal $ picosecondsToDiffTime n) - n) < resolutionFactor ] , testProperty "EventData" \x@(t, c, _v) -> @@ -68,15 +73,15 @@ inverses = -- 'toCEventData' takes all values for sync events to 0 - fine as they don't mean anything and [ t == t' - , fromEnum t == fromEnum EvSyn + , t == fromEnum' EvSyn , c == c' , v' == 0 ] in x' == x || syncValueZero ] ---TODO make delay and max retries configurable, add to library? -retryIf :: forall a e. Exception e => (e -> Bool) -> IO a -> IO a +-- TODO make delay and max retries configurable, add to library? +retryIf :: forall a e. (Exception e) => (e -> Bool) -> IO a -> IO a retryIf p x = go 100 where go :: Word -> IO a diff --git a/flake.nix b/flake.nix index 844e269..6f2c575 100644 --- a/flake.nix +++ b/flake.nix @@ -10,6 +10,12 @@ haskell-nix.overlay (final: prev: { myHaskellProject = + let + addIncludeDir = + '' + export C_INCLUDE_PATH="${final.stdenv.cc.libc.dev}/include''${C_INCLUDE_PATH:+:$C_INCLUDE_PATH}" + ''; + in final.haskell-nix.hix.project { src = ./.; compiler-nix-name = "ghc912"; @@ -18,10 +24,27 @@ shell.tools.cabal = "latest"; shell.tools.haskell-language-server = "latest"; shell.withHoogle = false; + shell.shellHook = addIncludeDir; + modules = [{ + packages.libclang-bindings.components.library = { + build-tools = [ final.llvmPackages.llvm ]; + libs = [ final.llvmPackages.libclang ]; + }; + packages.evdev.components.library.preBuild = addIncludeDir; + }]; }; }) ]; pkgs = import nixpkgs { inherit system overlays; inherit (haskell-nix) config; }; + flake = pkgs.myHaskellProject.flake { }; in - pkgs.myHaskellProject.flake { }); + flake // { + packages = flake.packages // { + ci = pkgs.linkFarm "ci" ( + pkgs.lib.mapAttrsToList (name: drv: { inherit name; path = drv; }) + flake.ciJobs.packages + ); + }; + } + ); }