usb 1.2 → 1.2.0.1
raw patch · 7 files changed
+505/−527 lines, 7 filesdep −base-unicode-symbolsdep ~basedep ~textsetup-changed
Dependencies removed: base-unicode-symbols
Dependency ranges changed: base, text
Files
- Poll.hsc +5/−7
- Setup.hs +3/−3
- System/USB/Base.hs +432/−426
- System/USB/IO/StandardDeviceRequests.hs +27/−32
- Timeval.hs +8/−10
- Utils.hs +27/−45
- usb.cabal +3/−4
Poll.hsc view
@@ -1,4 +1,4 @@-{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude #-} #include <poll.h> @@ -7,12 +7,10 @@ -- from base: import Data.Bits ( (.&.) ) import Data.Bool ( otherwise )+import Data.Eq ( (/=) ) import Data.Monoid ( mempty, mappend ) import Foreign.C.Types ( CShort ) --- from base-unicode-symbols:-import Data.Eq.Unicode ( (≢) )- -- from usb: -- I need to import GHC.Event or System.Event based on the version of base. -- However it's currently not possible to use cabal macros in .hsc files.@@ -20,10 +18,10 @@ -- So I use an intermediate module that makes the choice: import Event ( Event, evtRead, evtWrite ) -toEvent ∷ CShort → Event+toEvent :: CShort -> Event toEvent e = remap (#const POLLIN) evtRead `mappend` remap (#const POLLOUT) evtWrite where remap evt to- | e .&. evt ≢ 0 = to- | otherwise = mempty+ | e .&. evt /= 0 = to+ | otherwise = mempty
Setup.hs view
@@ -1,6 +1,6 @@ #! /usr/bin/env runhaskell -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-} module Main (main) where @@ -30,13 +30,13 @@ -- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run. ------------------------------------------------------------------------------- -main ∷ IO ()+main :: IO () main = defaultMainWithHooks hooks where hooks = simpleUserHooks { haddockHook = haddockHook' } -- Define __HADDOCK__ for CPP when running haddock.-haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()+haddockHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () haddockHook' pkg lbi = haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) where
System/USB/Base.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP- , UnicodeSyntax , NoImplicitPrelude , DeriveDataTypeable , BangPatterns@@ -31,23 +30,23 @@ import Foreign.C.String ( CStringLen ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray )-import Foreign.Storable ( Storable, peek, peekElemOff )+import Foreign.Storable ( peek, peekElemOff ) import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr ) import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr ) import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert )-import Control.Monad ( Monad, (=<<), return, when )+import Control.Monad ( (=<<), return, when ) import Control.Arrow ( (&&&) )-import Data.Function ( ($), on )+import Data.Function ( ($), (.), on ) import Data.Data ( Data ) import Data.Typeable ( Typeable ) import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe )-import Data.List ( lookup, map, (++) )+import Data.List ( lookup, (++) ) import Data.Int ( Int ) import Data.Word ( Word8, Word16 )-import Data.Eq ( Eq, (==) )+import Data.Eq ( Eq, (==), (/=) ) import Data.Ord ( Ord, (<), (>) )-import Data.Bool ( Bool(False, True), not, otherwise )-import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL )+import Data.Bool ( Bool(False, True), not, otherwise, (&&) )+import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL, shiftR ) import System.IO ( IO ) import System.IO.Unsafe ( unsafePerformIO ) import Text.Show ( Show, show )@@ -55,9 +54,9 @@ import Text.Printf ( printf ) #if MIN_VERSION_base(4,2,0)-import Data.Functor ( Functor, fmap, (<$>) )+import Data.Functor ( fmap, (<$>) ) #else-import Control.Monad ( Functor, fmap )+import Control.Monad ( fmap ) import Control.Applicative ( (<$>) ) #endif @@ -66,11 +65,6 @@ import Control.Monad ( (>>), fail ) #endif --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Data.Bool.Unicode ( (∧) )-import Data.Eq.Unicode ( (≢), (≡) )- -- from bytestring: import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length ) import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' )@@ -89,7 +83,7 @@ -- from usb (this package): import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray- , allocaPeek, ifM, decodeBCD, uncons+ , allocaPeek, ifM, uncons ) --------------------------------------------------------------------------------@@ -117,6 +111,9 @@ ( FdKey , registerFd, unregisterFd , registerTimeout, unregisterTimeout+#if MIN_VERSION_base(4,7,0)+ , getSystemTimerManager+#endif ) -- from containers:@@ -163,14 +160,14 @@ import Control.Exception ( blocked, block, unblock ) import Data.Function ( id ) -mask ∷ ((IO α → IO α) → IO β) → IO β+mask :: ((IO a -> IO a) -> IO b) -> IO b mask io = do b ← blocked if b then io id else block $ io unblock -mask_ ∷ IO α → IO α+mask_ :: IO a -> IO a mask_ = block #endif @@ -191,24 +188,24 @@ data Ctx = Ctx { #ifdef HAS_EVENT_MANAGER- ctxGetWait ∷ !(Maybe Wait),+ ctxGetWait :: !(Maybe Wait), #endif- getCtxFrgnPtr ∷ !(ForeignPtr C'libusb_context)+ getCtxFrgnPtr :: !(ForeignPtr C'libusb_context) } deriving Typeable instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr -withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α-withCtxPtr = withForeignPtr ∘ getCtxFrgnPtr+withCtxPtr :: Ctx -> (Ptr C'libusb_context -> IO a) -> IO a+withCtxPtr = withForeignPtr . getCtxFrgnPtr -libusb_init ∷ IO (Ptr C'libusb_context)-libusb_init = alloca $ \ctxPtrPtr → do+libusb_init :: IO (Ptr C'libusb_context)+libusb_init = alloca $ \ctxPtrPtr -> do handleUSBException $ c'libusb_init ctxPtrPtr peek ctxPtrPtr -newCtxNoEventManager ∷ (ForeignPtr C'libusb_context → Ctx) → IO Ctx+newCtxNoEventManager :: (ForeignPtr C'libusb_context -> Ctx) -> IO Ctx newCtxNoEventManager ctx = mask_ $ do- ctxPtr ← libusb_init+ ctxPtr <- libusb_init #ifdef mingw32_HOST_OS ctx <$> FC.newForeignPtr ctxPtr (c'libusb_exit ctxPtr)@@ -220,13 +217,13 @@ -- | Create and initialize a new USB context. -- -- This function may throw 'USBException's.-newCtx ∷ IO Ctx+newCtx :: IO Ctx newCtx = newCtxNoEventManager Ctx #else -------------------------------------------------------------------------------- -- | A function to wait for the termination of a submitted transfer.-type Wait = Timeout → Lock → Ptr C'libusb_transfer → IO ()+type Wait = Timeout -> Lock -> Ptr C'libusb_transfer -> IO () {-| Create and initialize a new USB context. @@ -237,54 +234,54 @@ print these errors to 'stderr'. If you need to handle the errors yourself (for example log them in an application specific way) please use 'newCtx''. -}-newCtx ∷ IO Ctx-newCtx = newCtx' $ \e → hPutStrLn stderr $+newCtx :: IO Ctx+newCtx = newCtx' $ \e -> hPutStrLn stderr $ thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e -- | Like 'newCtx' but enables you to specify the way errors should be handled -- that occur while handling @libusb@ events.-newCtx' ∷ (USBException → IO ()) → IO Ctx+newCtx' :: (USBException -> IO ()) -> IO Ctx newCtx' handleError = do- mbEvtMgr ← getSystemEventManager+ mbEvtMgr <- getSystemEventManager case mbEvtMgr of- Nothing → newCtxNoEventManager $ Ctx Nothing- Just evtMgr → mask_ $ do- ctxPtr ← libusb_init+ Nothing -> newCtxNoEventManager $ Ctx Nothing+ Just evtMgr -> mask_ $ do+ ctxPtr <- libusb_init let handleEvents = do- err ← withTimeval noTimeout $+ err <- withTimeval noTimeout $ c'libusb_handle_events_timeout ctxPtr- when (err ≢ c'LIBUSB_SUCCESS) $- if err ≡ c'LIBUSB_ERROR_INTERRUPTED+ when (err /= c'LIBUSB_SUCCESS) $+ if err == c'LIBUSB_ERROR_INTERRUPTED then handleEvents else handleError $ convertUSBException err - register ∷ CInt → CShort → IO FdKey- register fd evt = registerFd evtMgr (\_ _ → handleEvents)+ register :: CInt -> CShort -> IO FdKey+ register fd evt = registerFd evtMgr (\_ _ -> handleEvents) (Fd fd) (Poll.toEvent evt) -- Register initial libusb file descriptors with the event manager:- pollFdPtrLst ← c'libusb_get_pollfds ctxPtr- pollFdPtrs ← peekArray0 nullPtr pollFdPtrLst- fdKeys ← forM pollFdPtrs $ \pollFdPtr → do- C'libusb_pollfd fd evt ← peek pollFdPtr- fdKey ← register fd evt+ pollFdPtrLst <- c'libusb_get_pollfds ctxPtr+ pollFdPtrs <- peekArray0 nullPtr pollFdPtrLst+ fdKeys <- forM pollFdPtrs $ \pollFdPtr -> do+ C'libusb_pollfd fd evt <- peek pollFdPtr+ fdKey <- register fd evt return (fromIntegral fd, fdKey)- fdKeyMapRef ← newIORef $! (fromList fdKeys ∷ IntMap FdKey)+ fdKeyMapRef <- newIORef $! (fromList fdKeys :: IntMap FdKey) free pollFdPtrLst -- Be notified when libusb file descriptors are added or removed:- aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do- fdKey ← register fd evt- newFdKeyMap ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →+ aFP <- mk'libusb_pollfd_added_cb $ \fd evt _ -> mask_ $ do+ fdKey <- register fd evt+ newFdKeyMap <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> let newFdKeyMap = insert (fromIntegral fd) fdKey fdKeyMap in (newFdKeyMap, newFdKeyMap) newFdKeyMap `seq` return () - rFP ← mk'libusb_pollfd_removed_cb $ \fd _ → mask_ $ do- (newFdKeyMap, fdKey) ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →+ rFP <- mk'libusb_pollfd_removed_cb $ \fd _ -> mask_ $ do+ (newFdKeyMap, fdKey) <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> let (Just fdKey, newFdKeyMap) =- updateLookupWithKey (\_ _ → Nothing)+ updateLookupWithKey (\_ _ -> Nothing) (fromIntegral fd) fdKeyMap in (newFdKeyMap, (newFdKeyMap, fdKey))@@ -294,28 +291,34 @@ -- Check if we have to do our own timeout handling and construct the -- appropriate Wait function:- r ← c'libusb_pollfds_handle_timeouts ctxPtr+ r <- c'libusb_pollfds_handle_timeouts ctxPtr - let wait ∷ Wait- !wait | r ≡ 0 = manualTimeout- | otherwise = \_ → autoTimeout+#if MIN_VERSION_base(4,7,0)+ timerMgr <- getSystemTimerManager+#else+ let timerMgr = evtMgr+#endif + let wait :: Wait+ !wait | r == 0 = manualTimeout+ | otherwise = \_ -> autoTimeout+ manualTimeout timeout lock transPtr- | timeout ≡ noTimeout = autoTimeout lock transPtr+ | timeout == noTimeout = autoTimeout lock transPtr | otherwise = do- tk ← registerTimeout evtMgr (timeout * 1000) handleEvents+ tk <- registerTimeout timerMgr (timeout * 1000) handleEvents acquire lock `onException` (uninterruptibleMask_ $ do- unregisterTimeout evtMgr tk- _err ← c'libusb_cancel_transfer transPtr+ unregisterTimeout timerMgr tk+ _err <- c'libusb_cancel_transfer transPtr acquire lock) autoTimeout lock transPtr = acquire lock `onException` (uninterruptibleMask_ $ do- _err ← c'libusb_cancel_transfer transPtr+ _err <- c'libusb_cancel_transfer transPtr acquire lock) fmap (Ctx (Just wait)) $ FC.newForeignPtr ctxPtr $ do@@ -325,7 +328,7 @@ freeHaskellFunPtr rFP -- Unregister all registered file descriptors from the event manager:- readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) ∘ elems+ readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) . elems -- Finally deinitialize libusb: c'libusb_exit ctxPtr@@ -337,8 +340,8 @@ -- -- * @'Just' wait@ means that asynchronous I\/O is supported. The @wait@ -- function can be used to wait for submitted transfers.-getWait ∷ DeviceHandle → Maybe Wait-getWait = ctxGetWait ∘ getCtx ∘ getDevice+getWait :: DeviceHandle -> Maybe Wait+getWait = ctxGetWait . getCtx . getDevice #endif -------------------------------------------------------------------------------- @@ -363,8 +366,8 @@ If @libusb@ was compiled with verbose debug message logging, this function does nothing: you'll always get messages from all levels. -}-setDebug ∷ Ctx → Verbosity → IO ()-setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr →+setDebug :: Ctx -> Verbosity -> IO ()+setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr -> c'libusb_set_debug ctxPtr $ genFromEnum verbosity -- | Message verbosity@@ -395,11 +398,11 @@ using 'getDeviceDesc'. -} data Device = Device- { getCtx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't+ { getCtx :: !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't -- gets garbage collected. The finalizer @libusb_exit@ is -- run only when all references to 'Devices' are gone. - , getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device)+ , getDevFrgnPtr :: !(ForeignPtr C'libusb_device) } deriving Typeable instance Eq Device where (==) = (==) `on` getDevFrgnPtr@@ -408,9 +411,9 @@ instance Show Device where show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d) -withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α+withDevicePtr :: Device -> (Ptr C'libusb_device -> IO a) -> IO a withDevicePtr (Device ctx devFP ) f = do- x ← withForeignPtr devFP f+ x <- withForeignPtr devFP f touchForeignPtr $ getCtxFrgnPtr ctx return x @@ -441,20 +444,20 @@ v D -}-getDevices ∷ Ctx → IO (Vector Device)+getDevices :: Ctx -> IO (Vector Device) getDevices ctx =- withCtxPtr ctx $ \ctxPtr →- alloca $ \devPtrArrayPtr → mask $ \restore → do- numDevs ← checkUSBException $ c'libusb_get_device_list ctxPtr- devPtrArrayPtr- devPtrArray ← peek devPtrArrayPtr+ withCtxPtr ctx $ \ctxPtr ->+ alloca $ \devPtrArrayPtr -> mask $ \restore -> do+ numDevs <- checkUSBException $ c'libusb_get_device_list ctxPtr+ devPtrArrayPtr+ devPtrArray <- peek devPtrArrayPtr let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0- devs ← restore (mapPeekArray mkDev numDevs devPtrArray)+ devs <- restore (mapPeekArray mkDev numDevs devPtrArray) `onException` freeDevPtrArray freeDevPtrArray return devs where- mkDev ∷ Ptr C'libusb_device → IO Device+ mkDev :: Ptr C'libusb_device -> IO Device mkDev devPtr = Device ctx <$> #ifdef mingw32_HOST_OS FC.newForeignPtr devPtr@@ -467,11 +470,11 @@ -- structure. It's therefore safe to use unsafePerformIO: -- | The number of the bus that a device is connected to.-busNumber ∷ Device → Word8+busNumber :: Device -> Word8 busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number -- | The address of the device on the bus it is connected to.-deviceAddress ∷ Device → Word8+deviceAddress :: Device -> Word8 deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address --------------------------------------------------------------------------------@@ -490,10 +493,10 @@ a device handle you should close it by applying 'closeDevice' to it. -} data DeviceHandle = DeviceHandle- { getDevice ∷ !Device -- This reference is needed for keeping the 'Device'+ { getDevice :: !Device -- This reference is needed for keeping the 'Device' -- and therefor the 'Ctx' alive. -- ^ Retrieve the 'Device' from the 'DeviceHandle'.- , getDevHndlPtr ∷ !(Ptr C'libusb_device_handle)+ , getDevHndlPtr :: !(Ptr C'libusb_device_handle) } deriving Typeable instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr@@ -501,9 +504,9 @@ instance Show DeviceHandle where show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}" -withDevHndlPtr ∷ DeviceHandle → (Ptr C'libusb_device_handle → IO α) → IO α+withDevHndlPtr :: DeviceHandle -> (Ptr C'libusb_device_handle -> IO a) -> IO a withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do- x ← f devHndlPtr+ x <- f devHndlPtr touchForeignPtr devFrgnPtr touchForeignPtr $ getCtxFrgnPtr ctx return x@@ -527,9 +530,9 @@ * Another 'USBException'. -}-openDevice ∷ Device → IO DeviceHandle-openDevice dev = withDevicePtr dev $ \devPtr →- alloca $ \devHndlPtrPtr → do+openDevice :: Device -> IO DeviceHandle+openDevice dev = withDevicePtr dev $ \devPtr ->+ alloca $ \devHndlPtrPtr -> do handleUSBException $ c'libusb_open devPtr devHndlPtrPtr DeviceHandle dev <$> peek devHndlPtrPtr @@ -539,7 +542,7 @@ This is a non-blocking function; no requests are sent over the bus. -}-closeDevice ∷ DeviceHandle → IO ()+closeDevice :: DeviceHandle -> IO () closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close {-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes@@ -547,7 +550,7 @@ from @withDeviceHandle@ whether by normal termination or by raising an exception. -}-withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α+withDeviceHandle :: Device -> (DeviceHandle -> IO a) -> IO a withDeviceHandle dev = bracket (openDevice dev) closeDevice --------------------------------------------------------------------------------@@ -576,10 +579,10 @@ * Another 'USBException'. -}-getConfig ∷ DeviceHandle → IO (Maybe ConfigValue)+getConfig :: DeviceHandle -> IO (Maybe ConfigValue) getConfig devHndl =- alloca $ \configPtr → do- withDevHndlPtr devHndl $ \devHndlPtr →+ alloca $ \configPtr -> do+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr unmarshal <$> peek configPtr where@@ -622,9 +625,9 @@ * Another 'USBException'. -}-setConfig ∷ DeviceHandle → Maybe ConfigValue → IO ()+setConfig :: DeviceHandle -> Maybe ConfigValue -> IO () setConfig devHndl config =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_set_configuration devHndlPtr $ marshal config where@@ -666,9 +669,9 @@ * Another 'USBException'. -} -claimInterface ∷ DeviceHandle → InterfaceNumber → IO ()+claimInterface :: DeviceHandle -> InterfaceNumber -> IO () claimInterface devHndl ifNum =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_claim_interface devHndlPtr (fromIntegral ifNum) @@ -687,9 +690,9 @@ * Another 'USBException'. -}-releaseInterface ∷ DeviceHandle → InterfaceNumber → IO ()+releaseInterface :: DeviceHandle -> InterfaceNumber -> IO () releaseInterface devHndl ifNum =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_release_interface devHndlPtr (fromIntegral ifNum) @@ -697,7 +700,7 @@ executes the given computation. On exit from @withClaimedInterface@, the interface is released whether by normal termination or by raising an exception. -}-withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α+withClaimedInterface :: DeviceHandle -> InterfaceNumber -> IO a -> IO a withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum) (releaseInterface devHndl ifNum) @@ -729,12 +732,12 @@ * Another 'USBException'. -}-setInterfaceAltSetting ∷ DeviceHandle- → InterfaceNumber- → InterfaceAltSetting- → IO ()+setInterfaceAltSetting :: DeviceHandle+ -> InterfaceNumber+ -> InterfaceAltSetting+ -> IO () setInterfaceAltSetting devHndl ifNum alternateSetting =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_set_interface_alt_setting devHndlPtr (fromIntegral ifNum)@@ -762,9 +765,9 @@ * Another 'USBException'. -}-clearHalt ∷ DeviceHandle → EndpointAddress → IO ()+clearHalt :: DeviceHandle -> EndpointAddress -> IO () clearHalt devHndl endpointAddr =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr) @@ -788,9 +791,9 @@ * Another 'USBException'. -}-resetDevice ∷ DeviceHandle → IO ()+resetDevice :: DeviceHandle -> IO () resetDevice devHndl = withDevHndlPtr devHndl $- handleUSBException ∘ c'libusb_reset_device+ handleUSBException . c'libusb_reset_device -------------------------------------------------------------------------------- -- ** USB kernel drivers@@ -807,14 +810,14 @@ * Another 'USBException'. -}-kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool+kernelDriverActive :: DeviceHandle -> InterfaceNumber -> IO Bool kernelDriverActive devHndl ifNum =- withDevHndlPtr devHndl $ \devHndlPtr → do- r ← c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum)+ withDevHndlPtr devHndl $ \devHndlPtr -> do+ r <- c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum) case r of- 0 → return False- 1 → return True- _ → throwIO $ convertUSBException r+ 0 -> return False+ 1 -> return True+ _ -> throwIO $ convertUSBException r {-| Detach a kernel driver from an interface. @@ -830,9 +833,9 @@ * Another 'USBException'. -}-detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()+detachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO () detachKernelDriver devHndl ifNum =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr (fromIntegral ifNum) @@ -852,9 +855,9 @@ * Another 'USBException'. -}-attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()+attachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO () attachKernelDriver devHndl ifNum =- withDevHndlPtr devHndl $ \devHndlPtr →+ withDevHndlPtr devHndl $ \devHndlPtr -> handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr (fromIntegral ifNum) @@ -870,7 +873,7 @@ * Another 'USBException'. -}-withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α+withDetachedKernelDriver :: DeviceHandle -> InterfaceNumber -> IO a -> IO a withDetachedKernelDriver devHndl ifNum action = ifM (kernelDriverActive devHndl ifNum) (bracket_ (detachKernelDriver devHndl ifNum)@@ -894,42 +897,42 @@ -} data DeviceDesc = DeviceDesc { -- | USB specification release number.- deviceUSBSpecReleaseNumber ∷ !ReleaseNumber+ deviceUSBSpecReleaseNumber :: !ReleaseNumber -- | USB-IF class code for the device.- , deviceClass ∷ !Word8+ , deviceClass :: !Word8 -- | USB-IF subclass code for the device, qualified by the 'deviceClass' -- value.- , deviceSubClass ∷ !Word8+ , deviceSubClass :: !Word8 -- | USB-IF protocol code for the device, qualified by the 'deviceClass' -- and 'deviceSubClass' values.- , deviceProtocol ∷ !Word8+ , deviceProtocol :: !Word8 -- | Maximum packet size for endpoint 0.- , deviceMaxPacketSize0 ∷ !Word8+ , deviceMaxPacketSize0 :: !Word8 -- | USB-IF vendor ID.- , deviceVendorId ∷ !VendorId+ , deviceVendorId :: !VendorId -- | USB-IF product ID.- , deviceProductId ∷ !ProductId+ , deviceProductId :: !ProductId -- | Device release number.- , deviceReleaseNumber ∷ !ReleaseNumber+ , deviceReleaseNumber :: !ReleaseNumber -- | Optional index of string descriptor describing manufacturer.- , deviceManufacturerStrIx ∷ !(Maybe StrIx)+ , deviceManufacturerStrIx :: !(Maybe StrIx) -- | Optional index of string descriptor describing product.- , deviceProductStrIx ∷ !(Maybe StrIx)+ , deviceProductStrIx :: !(Maybe StrIx) -- | Optional index of string descriptor containing device serial number.- , deviceSerialNumberStrIx ∷ !(Maybe StrIx)+ , deviceSerialNumberStrIx :: !(Maybe StrIx) -- | Number of possible configurations.- , deviceNumConfigs ∷ !Word8+ , deviceNumConfigs :: !Word8 } deriving (COMMON_INSTANCES) type ReleaseNumber = (Int, Int, Int, Int)@@ -949,25 +952,25 @@ -} data ConfigDesc = ConfigDesc { -- | Identifier value for the configuration.- configValue ∷ !ConfigValue+ configValue :: !ConfigValue -- | Optional index of string descriptor describing the configuration.- , configStrIx ∷ !(Maybe StrIx)+ , configStrIx :: !(Maybe StrIx) -- | Configuration characteristics.- , configAttribs ∷ !ConfigAttribs+ , configAttribs :: !ConfigAttribs -- | Maximum power consumption of the USB device from the bus in the -- configuration when the device is fully operational. Expressed in 2 mA -- units (i.e., 50 = 100 mA).- , configMaxPower ∷ !Word8+ , configMaxPower :: !Word8 -- | Vector of interfaces supported by the configuration.- , configInterfaces ∷ !(Vector Interface)+ , configInterfaces :: !(Vector Interface) -- | Extra descriptors. If @libusb@ encounters unknown configuration -- descriptors, it will store them here, should you wish to parse them.- , configExtra ∷ !B.ByteString+ , configExtra :: !B.ByteString } deriving (COMMON_INSTANCES) @@ -980,11 +983,11 @@ type ConfigAttribs = DeviceStatus data DeviceStatus = DeviceStatus- { remoteWakeup ∷ !Bool -- ^ The Remote Wakeup field indicates whether the+ { remoteWakeup :: !Bool -- ^ The Remote Wakeup field indicates whether the -- device is currently enabled to request remote -- wakeup. The default mode for devices that -- support remote wakeup is disabled.- , selfPowered ∷ !Bool -- ^ The Self Powered field indicates whether the+ , selfPowered :: !Bool -- ^ The Self Powered field indicates whether the -- device is currently self-powered } deriving (COMMON_INSTANCES) @@ -1003,31 +1006,31 @@ -} data InterfaceDesc = InterfaceDesc { -- | Number of the interface.- interfaceNumber ∷ !InterfaceNumber+ interfaceNumber :: !InterfaceNumber -- | Value used to select the alternate setting for the interface.- , interfaceAltSetting ∷ !InterfaceAltSetting+ , interfaceAltSetting :: !InterfaceAltSetting -- | USB-IF class code for the interface.- , interfaceClass ∷ !Word8+ , interfaceClass :: !Word8 -- | USB-IF subclass code for the interface, qualified by the -- 'interfaceClass' value.- , interfaceSubClass ∷ !Word8+ , interfaceSubClass :: !Word8 -- | USB-IF protocol code for the interface, qualified by the -- 'interfaceClass' and 'interfaceSubClass' values.- , interfaceProtocol ∷ !Word8+ , interfaceProtocol :: !Word8 -- | Optional index of string descriptor describing the interface.- , interfaceStrIx ∷ !(Maybe StrIx)+ , interfaceStrIx :: !(Maybe StrIx) -- | Vector of endpoints supported by the interface.- , interfaceEndpoints ∷ !(Vector EndpointDesc)+ , interfaceEndpoints :: !(Vector EndpointDesc) -- | Extra descriptors. If @libusb@ encounters unknown interface -- descriptors, it will store them here, should you wish to parse them.- , interfaceExtra ∷ !B.ByteString+ , interfaceExtra :: !B.ByteString } deriving (COMMON_INSTANCES) --------------------------------------------------------------------------------@@ -1042,30 +1045,30 @@ -} data EndpointDesc = EndpointDesc { -- | The address of the endpoint described by the descriptor.- endpointAddress ∷ !EndpointAddress+ endpointAddress :: !EndpointAddress -- | Attributes which apply to the endpoint when it is configured using the -- 'configValue'.- , endpointAttribs ∷ !EndpointAttribs+ , endpointAttribs :: !EndpointAttribs -- | Maximum packet size the endpoint is capable of sending/receiving.- , endpointMaxPacketSize ∷ !MaxPacketSize+ , endpointMaxPacketSize :: !MaxPacketSize -- | Interval for polling endpoint for data transfers. Expressed in frames -- or microframes depending on the device operating speed (i.e., either 1 -- millisecond or 125 μs units).- , endpointInterval ∷ !Word8+ , endpointInterval :: !Word8 -- | /For audio devices only:/ the rate at which synchronization feedback -- is provided.- , endpointRefresh ∷ !Word8+ , endpointRefresh :: !Word8 -- | /For audio devices only:/ the address of the synch endpoint.- , endpointSynchAddress ∷ !Word8+ , endpointSynchAddress :: !Word8 -- | Extra descriptors. If @libusb@ encounters unknown endpoint descriptors, -- it will store them here, should you wish to parse them.- , endpointExtra ∷ !B.ByteString+ , endpointExtra :: !B.ByteString } deriving (COMMON_INSTANCES) --------------------------------------------------------------------------------@@ -1074,8 +1077,8 @@ -- | The address of an endpoint. data EndpointAddress = EndpointAddress- { endpointNumber ∷ !Int -- ^ Must be >= 0 and <= 15- , transferDirection ∷ !TransferDirection+ { endpointNumber :: !Int -- ^ Must be >= 0 and <= 15+ , transferDirection :: !TransferDirection } deriving (COMMON_INSTANCES) -- | The direction of data transfer relative to the host.@@ -1131,8 +1134,8 @@ -------------------------------------------------------------------------------- data MaxPacketSize = MaxPacketSize- { maxPacketSize ∷ !Size- , transactionOpportunities ∷ !TransactionOpportunities+ { maxPacketSize :: !Size+ , transactionOpportunities :: !TransactionOpportunities } deriving (COMMON_INSTANCES) -- | Number of additional transaction oppurtunities per microframe.@@ -1152,16 +1155,16 @@ This function is mainly useful for setting up /isochronous/ transfers. -}-maxIsoPacketSize ∷ EndpointDesc → Size+maxIsoPacketSize :: EndpointDesc -> Size maxIsoPacketSize epDesc | isochronousOrInterrupt = mps * (1 + fromEnum to) | otherwise = mps where MaxPacketSize mps to = endpointMaxPacketSize epDesc isochronousOrInterrupt = case endpointAttribs epDesc of- Isochronous _ _ → True- Interrupt → True- _ → False+ Isochronous _ _ -> True+ Interrupt -> True+ _ -> False -------------------------------------------------------------------------------- -- ** Retrieving and converting descriptors@@ -1172,13 +1175,13 @@ -- This is a non-blocking function; the device descriptor is cached in memory. -- -- This function may throw 'USBException's.-getDeviceDesc ∷ Device → IO DeviceDesc+getDeviceDesc :: Device -> IO DeviceDesc getDeviceDesc dev =- withDevicePtr dev $ \devPtr →+ withDevicePtr dev $ \devPtr -> convertDeviceDesc <$>- allocaPeek (handleUSBException ∘ c'libusb_get_device_descriptor devPtr)+ allocaPeek (handleUSBException . c'libusb_get_device_descriptor devPtr) -convertDeviceDesc ∷ C'libusb_device_descriptor → DeviceDesc+convertDeviceDesc :: C'libusb_device_descriptor -> DeviceDesc convertDeviceDesc d = DeviceDesc { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $ c'libusb_device_descriptor'bcdUSB d@@ -1203,14 +1206,17 @@ -- encoded as a -- <http://en.wikipedia.org/wiki/Binary-coded_decimal Binary Coded Decimal> -- using 4 bits for each of the 4 decimals.-unmarshalReleaseNumber ∷ Word16 → ReleaseNumber+unmarshalReleaseNumber :: Word16 -> ReleaseNumber unmarshalReleaseNumber abcd = (a, b, c, d) where- [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd+ a = fromIntegral $ abcd `shiftR` 12+ b = fromIntegral $ (abcd `shiftL` 4) `shiftR` 12+ c = fromIntegral $ (abcd `shiftL` 8) `shiftR` 12+ d = fromIntegral $ (abcd `shiftL` 12) `shiftR` 12 -- | Unmarshal an 8bit word to a string descriptor index. 0 denotes that a -- string descriptor is not available and unmarshals to 'Nothing'.-unmarshalStrIx ∷ Word8 → Maybe StrIx+unmarshalStrIx :: Word8 -> Maybe StrIx unmarshalStrIx 0 = Nothing unmarshalStrIx strIx = Just strIx @@ -1224,21 +1230,21 @@ -- * 'NotFoundException' if the configuration does not exist. -- -- * Another 'USBException'.-getConfigDesc ∷ Device → Word8 → IO ConfigDesc-getConfigDesc dev ix = withDevicePtr dev $ \devPtr →+getConfigDesc :: Device -> Word8 -> IO ConfigDesc+getConfigDesc dev ix = withDevicePtr dev $ \devPtr -> bracket (allocaPeek $ handleUSBException- ∘ c'libusb_get_config_descriptor devPtr ix)+ . c'libusb_get_config_descriptor devPtr ix) c'libusb_free_config_descriptor- ((convertConfigDesc =<<) ∘ peek)+ ((convertConfigDesc =<<) . peek) -convertConfigDesc ∷ C'libusb_config_descriptor → IO ConfigDesc+convertConfigDesc :: C'libusb_config_descriptor -> IO ConfigDesc convertConfigDesc c = do- interfaces ← mapPeekArray convertInterface- (fromIntegral $ c'libusb_config_descriptor'bNumInterfaces c)- (c'libusb_config_descriptor'interface c)+ interfaces <- mapPeekArray convertInterface+ (fromIntegral $ c'libusb_config_descriptor'bNumInterfaces c)+ (c'libusb_config_descriptor'interface c) - extra ← getExtra (c'libusb_config_descriptor'extra c)- (c'libusb_config_descriptor'extra_length c)+ extra <- getExtra (c'libusb_config_descriptor'extra c)+ (c'libusb_config_descriptor'extra_length c) return ConfigDesc { configValue = c'libusb_config_descriptor'bConfigurationValue c@@ -1251,30 +1257,30 @@ , configExtra = extra } -unmarshalConfigAttribs ∷ Word8 → ConfigAttribs+unmarshalConfigAttribs :: Word8 -> ConfigAttribs unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5 , selfPowered = testBit a 6 } -getExtra ∷ Ptr CUChar → CInt → IO B.ByteString+getExtra :: Ptr CUChar -> CInt -> IO B.ByteString getExtra extra extraLength = B.packCStringLen ( castPtr extra , fromIntegral extraLength ) -convertInterface ∷ C'libusb_interface → IO Interface+convertInterface :: C'libusb_interface -> IO Interface convertInterface i = mapPeekArray convertInterfaceDesc (fromIntegral $ c'libusb_interface'num_altsetting i) (c'libusb_interface'altsetting i) -convertInterfaceDesc ∷ C'libusb_interface_descriptor → IO InterfaceDesc+convertInterfaceDesc :: C'libusb_interface_descriptor -> IO InterfaceDesc convertInterfaceDesc i = do- endpoints ← mapPeekArray convertEndpointDesc- (fromIntegral $ c'libusb_interface_descriptor'bNumEndpoints i)- (c'libusb_interface_descriptor'endpoint i)+ endpoints <- mapPeekArray convertEndpointDesc+ (fromIntegral $ c'libusb_interface_descriptor'bNumEndpoints i)+ (c'libusb_interface_descriptor'endpoint i) - extra ← getExtra (c'libusb_interface_descriptor'extra i)- (c'libusb_interface_descriptor'extra_length i)+ extra <- getExtra (c'libusb_interface_descriptor'extra i)+ (c'libusb_interface_descriptor'extra_length i) return InterfaceDesc { interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i@@ -1288,10 +1294,10 @@ , interfaceExtra = extra } -convertEndpointDesc ∷ C'libusb_endpoint_descriptor → IO EndpointDesc+convertEndpointDesc :: C'libusb_endpoint_descriptor -> IO EndpointDesc convertEndpointDesc e = do- extra ← getExtra (c'libusb_endpoint_descriptor'extra e)- (c'libusb_endpoint_descriptor'extra_length e)+ extra <- getExtra (c'libusb_endpoint_descriptor'extra e)+ (c'libusb_endpoint_descriptor'extra_length e) return EndpointDesc { endpointAddress = unmarshalEndpointAddress $@@ -1308,7 +1314,7 @@ -- | Unmarshal an 8bit word as an endpoint address. This function is primarily -- used when unmarshalling USB descriptors.-unmarshalEndpointAddress ∷ Word8 → EndpointAddress+unmarshalEndpointAddress :: Word8 -> EndpointAddress unmarshalEndpointAddress a = EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a , transferDirection = if testBit a 7 then In else Out@@ -1316,24 +1322,24 @@ -- | Marshal an endpoint address so that it can be used by the @libusb@ transfer -- functions.-marshalEndpointAddress ∷ (Bits α, Num α) ⇒ EndpointAddress → α+marshalEndpointAddress :: (Bits a, Num a) => EndpointAddress -> a marshalEndpointAddress (EndpointAddress num transDir) = assert (between num 0 15) $ let n = fromIntegral num in case transDir of- Out → n- In → setBit n 7+ Out -> n+ In -> setBit n 7 -unmarshalEndpointAttribs ∷ Word8 → EndpointAttribs+unmarshalEndpointAttribs :: Word8 -> EndpointAttribs unmarshalEndpointAttribs a = case bits 0 1 a of- 0 → Control- 1 → Isochronous (genToEnum $ bits 2 3 a)- (genToEnum $ bits 4 5 a)- 2 → Bulk- 3 → Interrupt- _ → moduleError "unmarshalEndpointAttribs: this can't happen!"+ 0 -> Control+ 1 -> Isochronous (genToEnum $ bits 2 3 a)+ (genToEnum $ bits 4 5 a)+ 2 -> Bulk+ 3 -> Interrupt+ _ -> moduleError "unmarshalEndpointAttribs: this can't happen!" -unmarshalMaxPacketSize ∷ Word16 → MaxPacketSize+unmarshalMaxPacketSize :: Word16 -> MaxPacketSize unmarshalMaxPacketSize m = MaxPacketSize { maxPacketSize = fromIntegral $ bits 0 10 m@@ -1345,25 +1351,25 @@ -------------------------------------------------------------------------------- -- | The size in number of bytes of the header of string descriptors.-strDescHeaderSize ∷ Size+strDescHeaderSize :: Size strDescHeaderSize = 2 -- | Characters are encoded as UTF16LE so each character takes two bytes.-charSize ∷ Size+charSize :: Size charSize = 2 {-| Retrieve a vector of supported languages. This function may throw 'USBException's. -}-getLanguages ∷ DeviceHandle → IO (Vector LangId)-getLanguages devHndl = allocaArray maxSize $ \dataPtr → do- reportedSize ← write dataPtr+getLanguages :: DeviceHandle -> IO (Vector LangId)+getLanguages devHndl = allocaArray maxSize $ \dataPtr -> do+ reportedSize <- write dataPtr let strSize = (reportedSize - strDescHeaderSize) `div` charSize strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize - (VG.map unmarshalLangId ∘ VG.convert) <$> peekVector strSize strPtr+ (VG.map unmarshalLangId . VG.convert) <$> peekVector strSize strPtr where maxSize = 255 -- Some devices choke on size > 255 write = putStrDesc devHndl 0 0 maxSize@@ -1376,31 +1382,31 @@ is checked for correctness. If it's incorrect an 'IOException' is thrown. Finally, the size reported in the header is returned. -}-putStrDesc ∷ DeviceHandle- → StrIx- → Word16- → Size- → Ptr CUChar- → IO Size+putStrDesc :: DeviceHandle+ -> StrIx+ -> Word16+ -> Size+ -> Ptr CUChar+ -> IO Size putStrDesc devHndl strIx langId maxSize dataPtr = do- actualSize ← withDevHndlPtr devHndl $ \devHndlPtr →- checkUSBException $ c'libusb_get_string_descriptor- devHndlPtr- strIx- langId- dataPtr- (fromIntegral maxSize)+ actualSize <- withDevHndlPtr devHndl $ \devHndlPtr ->+ checkUSBException $ c'libusb_get_string_descriptor+ devHndlPtr+ strIx+ langId+ dataPtr+ (fromIntegral maxSize) when (actualSize < strDescHeaderSize) $ throwIO $ IOException "Incomplete header" - reportedSize ← peek dataPtr+ reportedSize <- peek dataPtr when (reportedSize > fromIntegral actualSize) $ throwIO $ IOException "Not enough space to hold data" - descType ← peekElemOff dataPtr 1+ descType <- peekElemOff dataPtr 1 - when (descType ≢ c'LIBUSB_DT_STRING) $+ when (descType /= c'LIBUSB_DT_STRING) $ throwIO $ IOException "Invalid header" return $ fromIntegral reportedSize@@ -1419,10 +1425,10 @@ type PrimaryLangId = Word16 type SubLangId = Word16 -unmarshalLangId ∷ Word16 → LangId+unmarshalLangId :: Word16 -> LangId unmarshalLangId = bits 0 9 &&& bits 10 15 -marshalLangId ∷ LangId → Word16+marshalLangId :: LangId -> Word16 marshalLangId (p, s) = p .|. s `shiftL`10 -- | Type of indici of string descriptors.@@ -1434,35 +1440,35 @@ This function may throw 'USBException's. -}-getStrDesc ∷ DeviceHandle- → StrIx- → LangId- → Int -- ^ Maximum number of characters in the requested string. An- -- 'IOException' will be thrown when the requested string is- -- larger than this number.- → IO Text-getStrDesc devHndl strIx langId nrOfChars = assert (strIx ≢ 0) $- fmap decode $ BI.createAndTrim size $ write ∘ castPtr+getStrDesc :: DeviceHandle+ -> StrIx+ -> LangId+ -> Int -- ^ Maximum number of characters in the requested string. An+ -- 'IOException' will be thrown when the requested string is+ -- larger than this number.+ -> IO Text+getStrDesc devHndl strIx langId nrOfChars = assert (strIx /= 0) $+ fmap decode $ BI.createAndTrim size $ write . castPtr where write = putStrDesc devHndl strIx (marshalLangId langId) size size = strDescHeaderSize + nrOfChars * charSize- decode = TE.decodeUtf16LE ∘ B.drop strDescHeaderSize+ decode = TE.decodeUtf16LE . B.drop strDescHeaderSize {-| Retrieve a string descriptor from a device using the first supported language. This function may throw 'USBException's. -}-getStrDescFirstLang ∷ DeviceHandle- → StrIx- → Int -- ^ Maximum number of characters in the requested- -- string. An 'IOException' will be thrown when the- -- requested string is larger than this number.- → IO Text+getStrDescFirstLang :: DeviceHandle+ -> StrIx+ -> Int -- ^ Maximum number of characters in the requested+ -- string. An 'IOException' will be thrown when the+ -- requested string is larger than this number.+ -> IO Text getStrDescFirstLang devHndl strIx nrOfChars = do- langIds ← getLanguages devHndl+ langIds <- getLanguages devHndl case uncons langIds of- Nothing → throwIO $ IOException "Zero languages"- Just (langId, _) → getStrDesc devHndl strIx langId nrOfChars+ Nothing -> throwIO $ IOException "Zero languages"+ Just (langId, _) -> getStrDesc devHndl strIx langId nrOfChars -------------------------------------------------------------------------------- -- * I/O@@ -1476,11 +1482,11 @@ paired with a 'Status' flag which indicates whether the transfer 'Completed' or 'TimedOut'. -}-type ReadAction = Size → Timeout → IO (B.ByteString, Status)+type ReadAction = Size -> Timeout -> IO (B.ByteString, Status) -- | Handy type synonym for read transfers that must exactly read the specified -- number of bytes. An 'incompleteReadException' is thrown otherwise.-type ReadExactAction = Size → Timeout → IO B.ByteString+type ReadExactAction = Size -> Timeout -> IO B.ByteString {-| Handy type synonym for write transfers. @@ -1489,11 +1495,11 @@ number of bytes that were actually written paired with a 'Status' flag which indicates whether the transfer 'Completed' or 'TimedOut'. -}-type WriteAction = B.ByteString → Timeout → IO (Size, Status)+type WriteAction = B.ByteString -> Timeout -> IO (Size, Status) -- | Handy type synonym for write transfers that must exactly write all the -- given bytes. An 'incompleteWriteException' is thrown otherwise.-type WriteExactAction = B.ByteString → Timeout → IO ()+type WriteExactAction = B.ByteString -> Timeout -> IO () -- | Number of bytes transferred. type Size = Int@@ -1504,7 +1510,7 @@ type Timeout = Int -- | A timeout of 0 denotes no timeout so: @noTimeout = 0@.-noTimeout ∷ Timeout+noTimeout :: Timeout noTimeout = 0 -- | Status of a terminated transfer.@@ -1519,7 +1525,7 @@ ------------------------------------------------------------------------------- -- | Handy type synonym that names the parameters of a control transfer.-type ControlAction α = RequestType → Recipient → Request → Value → Index → α+type ControlAction a = RequestType -> Recipient -> Request -> Value -> Index -> a data RequestType = Standard | Class@@ -1540,7 +1546,7 @@ -- | (Host-endian) type Index = Word16 -marshalRequestType ∷ RequestType → Recipient → Word8+marshalRequestType :: RequestType -> Recipient -> Word8 marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r --------------------------------------------------------------------------------@@ -1559,15 +1565,15 @@ * Another 'USBException'. -}-control ∷ DeviceHandle → ControlAction (Timeout → IO ())+control :: DeviceHandle -> ControlAction (Timeout -> IO ()) control devHndl reqType reqRecipient request value index timeout = do- (_, status) ← doControl- when (status ≡ TimedOut) $ throwIO TimeoutException+ (_, status) <- doControl+ when (status == TimedOut) $ throwIO TimeoutException where doControl #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl =- allocaBytes controlSetupSize $ \bufferPtr → do+ | Just wait <- getWait devHndl =+ allocaBytes controlSetupSize $ \bufferPtr -> do poke bufferPtr $ C'libusb_control_setup requestType request value index 0@@ -1597,25 +1603,25 @@ * Another 'USBException'. -}-readControl ∷ DeviceHandle → ControlAction ReadAction+readControl :: DeviceHandle -> ControlAction ReadAction readControl devHndl reqType reqRecipient request value index size timeout #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl = do+ | Just wait <- getWait devHndl = do let totalSize = controlSetupSize + size- allocaBytes totalSize $ \bufferPtr → do+ allocaBytes totalSize $ \bufferPtr -> do poke bufferPtr $ C'libusb_control_setup requestType request value index (fromIntegral size)- (transferred, status) ← transferAsync wait- c'LIBUSB_TRANSFER_TYPE_CONTROL- devHndl controlEndpoint- timeout- (bufferPtr, totalSize)- bs ← BI.create transferred $ \dataPtr →- copyArray dataPtr (bufferPtr `plusPtr` controlSetupSize) transferred+ (transferred, status) <- transferAsync wait+ c'LIBUSB_TRANSFER_TYPE_CONTROL+ devHndl controlEndpoint+ timeout+ (bufferPtr, totalSize)+ bs <- BI.create transferred $ \dataPtr ->+ copyArray dataPtr (bufferPtr `plusPtr` controlSetupSize) transferred return (bs, status) #endif- | otherwise = createAndTrimNoOffset size $ \dataPtr →+ | otherwise = createAndTrimNoOffset size $ \dataPtr -> controlTransferSync devHndl requestType request value index@@ -1627,14 +1633,14 @@ -- | A convenience function similar to 'readControl' which checks if the -- specified number of bytes to read were actually read. -- Throws an 'incompleteReadException' if this is not the case.-readControlExact ∷ DeviceHandle → ControlAction ReadExactAction+readControlExact :: DeviceHandle -> ControlAction ReadExactAction readControlExact devHndl reqType reqRecipient request value index size timeout = do- (bs, _) ← readControl devHndl- reqType reqRecipient request value index- size timeout- if B.length bs ≢ size+ (bs, _) <- readControl devHndl+ reqType reqRecipient request value index+ size timeout+ if B.length bs /= size then throwIO incompleteReadException else return bs @@ -1651,13 +1657,13 @@ * Another 'USBException'. -}-writeControl ∷ DeviceHandle → ControlAction WriteAction+writeControl :: DeviceHandle -> ControlAction WriteAction writeControl devHndl reqType reqRecipient request value index input timeout #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl =- BU.unsafeUseAsCStringLen input $ \(dataPtr, size) → do+ | Just wait <- getWait devHndl =+ BU.unsafeUseAsCStringLen input $ \(dataPtr, size) -> do let totalSize = controlSetupSize + size- allocaBytes totalSize $ \bufferPtr → do+ allocaBytes totalSize $ \bufferPtr -> do poke bufferPtr $ C'libusb_control_setup requestType request value index (fromIntegral size)@@ -1679,41 +1685,41 @@ -- | A convenience function similar to 'writeControl' which checks if the given -- bytes were actually fully written. -- Throws an 'incompleteWriteException' if this is not the case.-writeControlExact ∷ DeviceHandle → ControlAction WriteExactAction+writeControlExact :: DeviceHandle -> ControlAction WriteExactAction writeControlExact devHndl reqType reqRecipient request value index input timeout = do- (transferred, _) ← writeControl devHndl- reqType reqRecipient request value index- input timeout- when (transferred ≢ B.length input) $ throwIO incompleteWriteException+ (transferred, _) <- writeControl devHndl+ reqType reqRecipient request value index+ input timeout+ when (transferred /= B.length input) $ throwIO incompleteWriteException -------------------------------------------------------------------------------- #ifdef HAS_EVENT_MANAGER-controlSetupSize ∷ Size-controlSetupSize = sizeOf (undefined ∷ C'libusb_control_setup)+controlSetupSize :: Size+controlSetupSize = sizeOf (undefined :: C'libusb_control_setup) -controlEndpoint ∷ CUChar+controlEndpoint :: CUChar controlEndpoint = 0 #endif -controlTransferSync ∷ DeviceHandle- → Word8 → Request → Value → Index- → Timeout- → (Ptr byte, Size)- → IO (Size, Status)+controlTransferSync :: DeviceHandle+ -> Word8 -> Request -> Value -> Index+ -> Timeout+ -> (Ptr byte, Size)+ -> IO (Size, Status) controlTransferSync devHndl reqType request value index timeout (dataPtr, size) = do- err ← withDevHndlPtr devHndl $ \devHndlPtr →- c'libusb_control_transfer devHndlPtr- reqType request value index- (castPtr dataPtr) (fromIntegral size)- (fromIntegral timeout)- let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT- if err < 0 ∧ not timedOut+ err <- withDevHndlPtr devHndl $ \devHndlPtr ->+ c'libusb_control_transfer devHndlPtr+ reqType request value index+ (castPtr dataPtr) (fromIntegral size)+ (fromIntegral timeout)+ let timedOut = err == c'LIBUSB_ERROR_TIMEOUT+ if err < 0 && not timedOut then throwIO $ convertUSBException err else return ( fromIntegral err , if timedOut then TimedOut else Completed@@ -1737,10 +1743,10 @@ * Another 'USBException'. -}-readBulk ∷ DeviceHandle → EndpointAddress → ReadAction+readBulk :: DeviceHandle -> EndpointAddress -> ReadAction readBulk devHndl #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl =+ | Just wait <- getWait devHndl = readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl #endif | otherwise = readTransferSync c'libusb_bulk_transfer devHndl@@ -1759,10 +1765,10 @@ * Another 'USBException'. -}-writeBulk ∷ DeviceHandle → EndpointAddress → WriteAction+writeBulk :: DeviceHandle -> EndpointAddress -> WriteAction writeBulk devHndl #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl =+ | Just wait <- getWait devHndl = writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl #endif | otherwise = writeTransferSync c'libusb_bulk_transfer devHndl@@ -1785,10 +1791,10 @@ * Another 'USBException'. -}-readInterrupt ∷ DeviceHandle → EndpointAddress → ReadAction+readInterrupt :: DeviceHandle -> EndpointAddress -> ReadAction readInterrupt devHndl #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl =+ | Just wait <- getWait devHndl = readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl #endif | otherwise = readTransferSync c'libusb_interrupt_transfer devHndl@@ -1808,10 +1814,10 @@ * Another 'USBException'. -}-writeInterrupt ∷ DeviceHandle → EndpointAddress → WriteAction+writeInterrupt :: DeviceHandle -> EndpointAddress -> WriteAction writeInterrupt devHndl #ifdef HAS_EVENT_MANAGER- | Just wait ← getWait devHndl =+ | Just wait <- getWait devHndl = writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl #endif | otherwise = writeTransferSync c'libusb_interrupt_transfer devHndl@@ -1820,49 +1826,49 @@ -- | Handy type synonym for the @libusb@ transfer functions. type C'TransferFunc = Ptr C'libusb_device_handle -- devHndlPtr- → CUChar -- endpoint address- → Ptr CUChar -- dataPtr- → CInt -- size- → Ptr CInt -- transferredPtr- → CUInt -- timeout- → IO CInt -- error+ -> CUChar -- endpoint address+ -> Ptr CUChar -- dataPtr+ -> CInt -- size+ -> Ptr CInt -- transferredPtr+ -> CUInt -- timeout+ -> IO CInt -- error -readTransferSync ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → ReadAction)-readTransferSync c'transfer = \devHndl endpointAddr → \size timeout →- createAndTrimNoOffset size $ \dataPtr →+readTransferSync :: C'TransferFunc -> (DeviceHandle -> EndpointAddress -> ReadAction)+readTransferSync c'transfer = \devHndl endpointAddr -> \size timeout ->+ createAndTrimNoOffset size $ \dataPtr -> transferSync c'transfer devHndl endpointAddr timeout (castPtr dataPtr, size) -writeTransferSync ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction)-writeTransferSync c'transfer = \devHndl endpointAddr → \input timeout →+writeTransferSync :: C'TransferFunc -> (DeviceHandle -> EndpointAddress -> WriteAction)+writeTransferSync c'transfer = \devHndl endpointAddr -> \input timeout -> BU.unsafeUseAsCStringLen input $ transferSync c'transfer devHndl endpointAddr timeout -transferSync ∷ C'TransferFunc → DeviceHandle- → EndpointAddress- → Timeout- → CStringLen- → IO (Size, Status)+transferSync :: C'TransferFunc -> DeviceHandle+ -> EndpointAddress+ -> Timeout+ -> CStringLen+ -> IO (Size, Status) transferSync c'transfer devHndl endpointAddr timeout (dataPtr, size) =- alloca $ \transferredPtr → do- err ← withDevHndlPtr devHndl $ \devHndlPtr →- c'transfer devHndlPtr- (marshalEndpointAddress endpointAddr)- (castPtr dataPtr)- (fromIntegral size)- transferredPtr- (fromIntegral timeout)- let timedOut = err ≡ c'LIBUSB_ERROR_TIMEOUT- if err ≢ c'LIBUSB_SUCCESS ∧ not timedOut+ alloca $ \transferredPtr -> do+ err <- withDevHndlPtr devHndl $ \devHndlPtr ->+ c'transfer devHndlPtr+ (marshalEndpointAddress endpointAddr)+ (castPtr dataPtr)+ (fromIntegral size)+ transferredPtr+ (fromIntegral timeout)+ let timedOut = err == c'LIBUSB_ERROR_TIMEOUT+ if err /= c'LIBUSB_SUCCESS && not timedOut then throwIO $ convertUSBException err- else do transferred ← peek transferredPtr+ else do transferred <- peek transferredPtr return ( fromIntegral transferred , if timedOut then TimedOut else Completed )@@ -1870,21 +1876,21 @@ -------------------------------------------------------------------------------- #ifdef HAS_EVENT_MANAGER-readTransferAsync ∷ Wait- → C'TransferType- → DeviceHandle → EndpointAddress → ReadAction-readTransferAsync wait transType = \devHndl endpointAddr → \size timeout →- createAndTrimNoOffset size $ \bufferPtr →+readTransferAsync :: Wait+ -> C'TransferType+ -> DeviceHandle -> EndpointAddress -> ReadAction+readTransferAsync wait transType = \devHndl endpointAddr -> \size timeout ->+ createAndTrimNoOffset size $ \bufferPtr -> transferAsync wait transType devHndl (marshalEndpointAddress endpointAddr) timeout (bufferPtr, size) -writeTransferAsync ∷ Wait- → C'TransferType- → DeviceHandle → EndpointAddress → WriteAction-writeTransferAsync wait transType = \devHndl endpointAddr → \input timeout →+writeTransferAsync :: Wait+ -> C'TransferType+ -> DeviceHandle -> EndpointAddress -> WriteAction+writeTransferAsync wait transType = \devHndl endpointAddr -> \input timeout -> BU.unsafeUseAsCStringLen input $ transferAsync wait transType@@ -1895,12 +1901,12 @@ type C'TransferType = CUChar -transferAsync ∷ Wait- → C'TransferType- → DeviceHandle → CUChar -- ^ Encoded endpoint address- → Timeout- → (Ptr byte, Size)- → IO (Size, Status)+transferAsync :: Wait+ -> C'TransferType+ -> DeviceHandle -> CUChar -- ^ Encoded endpoint address+ -> Timeout+ -> (Ptr byte, Size)+ -> IO (Size, Status) transferAsync wait transType devHndl endpoint timeout bytes = withTerminatedTransfer wait transType@@ -1912,20 +1918,20 @@ (continue TimedOut) where continue status transPtr = do- n ← peek $ p'libusb_transfer'actual_length transPtr+ n <- peek $ p'libusb_transfer'actual_length transPtr return (fromIntegral n, status) -------------------------------------------------------------------------------- -withTerminatedTransfer ∷ Wait- → C'TransferType- → Storable.Vector C'libusb_iso_packet_descriptor- → DeviceHandle → CUChar -- ^ Encoded endpoint address- → Timeout- → (Ptr byte, Size)- → (Ptr C'libusb_transfer → IO α)- → (Ptr C'libusb_transfer → IO α)- → IO α+withTerminatedTransfer :: Wait+ -> C'TransferType+ -> Storable.Vector C'libusb_iso_packet_descriptor+ -> DeviceHandle -> CUChar -- ^ Encoded endpoint address+ -> Timeout+ -> (Ptr byte, Size)+ -> (Ptr C'libusb_transfer -> IO a)+ -> (Ptr C'libusb_transfer -> IO a)+ -> IO a withTerminatedTransfer wait transType isos@@ -1934,11 +1940,11 @@ (bufferPtr, size) onCompletion onTimeout =- withDevHndlPtr devHndl $ \devHndlPtr → do+ withDevHndlPtr devHndl $ \devHndlPtr -> do let nrOfIsos = VG.length isos- allocaTransfer nrOfIsos $ \transPtr → do- lock ← newLock- withCallback (\_ → release lock) $ \cbPtr → do+ allocaTransfer nrOfIsos $ \transPtr -> do+ lock <- newLock+ withCallback (\_ -> release lock) $ \cbPtr -> do poke (p'libusb_transfer'dev_handle transPtr) devHndlPtr poke (p'libusb_transfer'endpoint transPtr) endpoint poke (p'libusb_transfer'type transPtr) transType@@ -1954,21 +1960,21 @@ handleUSBException $ c'libusb_submit_transfer transPtr wait timeout lock transPtr - status ← peek $ p'libusb_transfer'status transPtr+ status <- peek $ p'libusb_transfer'status transPtr case status of- ts | ts ≡ c'LIBUSB_TRANSFER_COMPLETED → onCompletion transPtr- | ts ≡ c'LIBUSB_TRANSFER_TIMED_OUT → onTimeout transPtr+ ts | ts == c'LIBUSB_TRANSFER_COMPLETED -> onCompletion transPtr+ | ts == c'LIBUSB_TRANSFER_TIMED_OUT -> onTimeout transPtr - | ts ≡ c'LIBUSB_TRANSFER_ERROR → throwIO ioException- | ts ≡ c'LIBUSB_TRANSFER_NO_DEVICE → throwIO NoDeviceException- | ts ≡ c'LIBUSB_TRANSFER_OVERFLOW → throwIO OverflowException- | ts ≡ c'LIBUSB_TRANSFER_STALL → throwIO PipeException+ | ts == c'LIBUSB_TRANSFER_ERROR -> throwIO ioException+ | ts == c'LIBUSB_TRANSFER_NO_DEVICE -> throwIO NoDeviceException+ | ts == c'LIBUSB_TRANSFER_OVERFLOW -> throwIO OverflowException+ | ts == c'LIBUSB_TRANSFER_STALL -> throwIO PipeException - | ts ≡ c'LIBUSB_TRANSFER_CANCELLED →+ | ts == c'LIBUSB_TRANSFER_CANCELLED -> moduleError "transfer status can't be Cancelled!" - | otherwise → moduleError $ "Unknown transfer status: " ++- show ts ++ "!"+ | otherwise -> moduleError $ "Unknown transfer status: " +++ show ts ++ "!" -------------------------------------------------------------------------------- @@ -1977,12 +1983,12 @@ -- when the function terminates (whether normally or by raising an exception). -- -- A 'NoMemException' may be thrown.-allocaTransfer ∷ Int → (Ptr C'libusb_transfer → IO α) → IO α+allocaTransfer :: Int -> (Ptr C'libusb_transfer -> IO a) -> IO a allocaTransfer nrOfIsos = bracket mallocTransfer c'libusb_free_transfer where mallocTransfer = do- transPtr ← c'libusb_alloc_transfer (fromIntegral nrOfIsos)- when (transPtr ≡ nullPtr) (throwIO NoMemException)+ transPtr <- c'libusb_alloc_transfer (fromIntegral nrOfIsos)+ when (transPtr == nullPtr) (throwIO NoMemException) return transPtr --------------------------------------------------------------------------------@@ -1990,9 +1996,9 @@ -- | Create a 'FunPtr' to the given transfer callback function and pass it to -- the continuation function. The 'FunPtr' is automatically freed when the -- continuation terminates (whether normally or by raising an exception).-withCallback ∷ (Ptr C'libusb_transfer → IO ())- → (C'libusb_transfer_cb_fn → IO α)- → IO α+withCallback :: (Ptr C'libusb_transfer -> IO ())+ -> (C'libusb_transfer_cb_fn -> IO a)+ -> IO a withCallback cb = bracket (mk'libusb_transfer_cb_fn cb) freeHaskellFunPtr --------------------------------------------------------------------------------@@ -2001,7 +2007,7 @@ newtype Lock = Lock (MVar ()) deriving Eq -- | Create a lock in the \"unlocked\" state.-newLock ∷ IO Lock+newLock :: IO Lock newLock = Lock <$> newEmptyMVar {-|@@ -2015,7 +2021,7 @@ another thread wakes the calling thread. Upon awakening it will change the state to \"locked\". -}-acquire ∷ Lock → IO ()+acquire :: Lock -> IO () acquire (Lock mv) = takeMVar mv {-|@@ -2026,7 +2032,7 @@ If there are any threads blocked on 'acquire' the thread that first called @acquire@ will be woken up. -}-release ∷ Lock → IO ()+release :: Lock -> IO () release (Lock mv) = putMVar mv () --------------------------------------------------------------------------------@@ -2050,17 +2056,17 @@ * Another 'USBException'. -}-readIsochronous ∷ DeviceHandle- → EndpointAddress- → Unboxed.Vector Size -- ^ Sizes of isochronous packets- → Timeout- → IO (Vector B.ByteString)+readIsochronous :: DeviceHandle+ -> EndpointAddress+ -> Unboxed.Vector Size -- ^ Sizes of isochronous packets+ -> Timeout+ -> IO (Vector B.ByteString) readIsochronous devHndl endpointAddr sizes timeout- | Just wait ← getWait devHndl = do+ | Just wait <- getWait devHndl = do let totalSize = VG.sum sizes nrOfIsos = VG.length sizes isos = VG.map initIsoPacketDesc $ VG.convert sizes- allocaBytes totalSize $ \bufferPtr →+ allocaBytes totalSize $ \bufferPtr -> withTerminatedTransfer wait c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS@@ -2070,20 +2076,20 @@ timeout (bufferPtr, totalSize) (getPackets nrOfIsos bufferPtr)- (\_ → throwIO TimeoutException)+ (\_ -> throwIO TimeoutException) | otherwise = needThreadedRTSError "readIsochronous" -getPackets ∷ Int → Ptr Word8 → Ptr C'libusb_transfer → IO (Vector B.ByteString)+getPackets :: Int -> Ptr Word8 -> Ptr C'libusb_transfer -> IO (Vector B.ByteString) getPackets nrOfIsos bufferPtr transPtr = do- mv ← VGM.unsafeNew nrOfIsos+ mv <- VGM.unsafeNew nrOfIsos let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr go ix ptr | ix < nrOfIsos = do let isoPtr = advancePtr isoArrayPtr ix- l ← peek (p'libusb_iso_packet_descriptor'length isoPtr)- a ← peek (p'libusb_iso_packet_descriptor'actual_length isoPtr)+ l <- peek (p'libusb_iso_packet_descriptor'length isoPtr)+ a <- peek (p'libusb_iso_packet_descriptor'actual_length isoPtr) let transferred = fromIntegral a- bs ← BI.create transferred $ \p → copyArray p ptr transferred+ bs <- BI.create transferred $ \p -> copyArray p ptr transferred VGM.unsafeWrite mv ix bs go (ix+1) (ptr `plusPtr` fromIntegral l) | otherwise = VG.unsafeFreeze mv@@ -2108,18 +2114,18 @@ * Another 'USBException'. -}-writeIsochronous ∷ DeviceHandle- → EndpointAddress- → Vector B.ByteString- → Timeout- → IO (Unboxed.Vector Size)+writeIsochronous :: DeviceHandle+ -> EndpointAddress+ -> Vector B.ByteString+ -> Timeout+ -> IO (Unboxed.Vector Size) writeIsochronous devHndl endpointAddr isoPackets timeout- | Just wait ← getWait devHndl = do+ | Just wait <- getWait devHndl = do let sizes = VG.map B.length isoPackets nrOfIsos = VG.length sizes totalSize = VG.sum sizes isos = VG.convert $ VG.map initIsoPacketDesc sizes- allocaBytes totalSize $ \bufferPtr → do+ allocaBytes totalSize $ \bufferPtr -> do copyIsos (castPtr bufferPtr) isoPackets withTerminatedTransfer wait@@ -2130,31 +2136,31 @@ timeout (bufferPtr, totalSize) (getSizes nrOfIsos)- (\_ → throwIO TimeoutException)+ (\_ -> throwIO TimeoutException) | otherwise = needThreadedRTSError "writeIsochronous" -getSizes ∷ Int → Ptr C'libusb_transfer → IO (Unboxed.Vector Size)+getSizes :: Int -> Ptr C'libusb_transfer -> IO (Unboxed.Vector Size) getSizes nrOfIsos transPtr = do- mv ← VGM.unsafeNew nrOfIsos+ mv <- VGM.unsafeNew nrOfIsos let isoArrayPtr = p'libusb_transfer'iso_packet_desc transPtr go ix | ix < nrOfIsos = do let isoPtr = advancePtr isoArrayPtr ix- a ← peek (p'libusb_iso_packet_descriptor'actual_length isoPtr)+ a <- peek (p'libusb_iso_packet_descriptor'actual_length isoPtr) let transferred = fromIntegral a VGM.unsafeWrite mv ix transferred go (ix+1) | otherwise = VG.unsafeFreeze mv go 0 -copyIsos ∷ Ptr CChar → Vector B.ByteString → IO ()-copyIsos = VG.foldM_ $ \bufferPtr bs →- BU.unsafeUseAsCStringLen bs $ \(ptr, len) → do+copyIsos :: Ptr CChar -> Vector B.ByteString -> IO ()+copyIsos = VG.foldM_ $ \bufferPtr bs ->+ BU.unsafeUseAsCStringLen bs $ \(ptr, len) -> do copyArray bufferPtr ptr len return $ bufferPtr `plusPtr` len -- | An isochronous packet descriptor with all fields zero except for the length.-initIsoPacketDesc ∷ Size → C'libusb_iso_packet_descriptor+initIsoPacketDesc :: Size -> C'libusb_iso_packet_descriptor initIsoPacketDesc size = C'libusb_iso_packet_descriptor { c'libusb_iso_packet_descriptor'length = fromIntegral size@@ -2165,9 +2171,9 @@ -------------------------------------------------------------------------------- -createAndTrimNoOffset ∷ Size → (Ptr Word8 → IO (Size, α)) → IO (B.ByteString, α)-createAndTrimNoOffset size f = BI.createAndTrim' size $ \ptr → do- (l, x) ← f ptr+createAndTrimNoOffset :: Size -> (Ptr Word8 -> IO (Size, a)) -> IO (B.ByteString, a)+createAndTrimNoOffset size f = BI.createAndTrim' size $ \ptr -> do+ (l, x) <- f ptr return (offset, l, x) where offset = 0@@ -2179,23 +2185,23 @@ -- | @handleUSBException action@ executes @action@. If @action@ returned an -- error code other than 'c\'LIBUSB_SUCCESS', the error is converted to a -- 'USBException' and thrown.-handleUSBException ∷ IO CInt → IO ()-handleUSBException action = do err ← action- when (err ≢ c'LIBUSB_SUCCESS)+handleUSBException :: IO CInt -> IO ()+handleUSBException action = do err <- action+ when (err /= c'LIBUSB_SUCCESS) (throwIO $ convertUSBException err) -- | @checkUSBException action@ executes @action@. If @action@ returned a -- negative integer the integer is converted to a 'USBException' and thrown. If -- not, the integer is returned.-checkUSBException ∷ (Integral α, Show α) ⇒ IO α → IO Int-checkUSBException action = do r ← action+checkUSBException :: (Integral a, Show a) => IO a -> IO Int+checkUSBException action = do r <- action if r < 0 then throwIO $ convertUSBException r else return $ fromIntegral r -- | Convert a @C'libusb_error@ to a 'USBException'. If the @C'libusb_error@ is -- unknown an 'error' is thrown.-convertUSBException ∷ (Num α, Eq α, Show α) ⇒ α → USBException+convertUSBException :: (Num a, Eq a, Show a) => a -> USBException convertUSBException err = fromMaybe unknownLibUsbError $ lookup err libusb_error_to_USBException where@@ -2203,7 +2209,7 @@ moduleError $ "Unknown libusb error code: " ++ show err ++ "!" -- | Association list mapping 'C'libusb_error's to 'USBException's.-libusb_error_to_USBException ∷ Num α ⇒ [(α, USBException)]+libusb_error_to_USBException :: Num a => [(a, USBException)] libusb_error_to_USBException = [ (c'LIBUSB_ERROR_IO, ioException) , (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)@@ -2246,32 +2252,32 @@ instance Exception USBException -- | A general 'IOException'.-ioException ∷ USBException+ioException :: USBException ioException = IOException "" -- | 'IOException' that is thrown when the number of bytes /read/ -- doesn't equal the requested number.-incompleteReadException ∷ USBException+incompleteReadException :: USBException incompleteReadException = incompleteException "read" -- | 'IOException' that is thrown when the number of bytes /written/ -- doesn't equal the requested number.-incompleteWriteException ∷ USBException+incompleteWriteException :: USBException incompleteWriteException = incompleteException "written" -incompleteException ∷ String → USBException+incompleteException :: String -> USBException incompleteException rw = IOException $ "The number of bytes " ++ rw ++ " doesn't equal the requested number!" -------------------------------------------------------------------------------- -moduleError ∷ String → error+moduleError :: String -> error moduleError msg = error $ thisModule ++ ": " ++ msg -thisModule ∷ String+thisModule :: String thisModule = "System.USB.Base" -needThreadedRTSError ∷ String → error+needThreadedRTSError :: String -> error needThreadedRTSError msg = moduleError $ msg ++ " is only supported when using the threaded runtime. " ++ "Please build your program with -threaded."
System/USB/IO/StandardDeviceRequests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, NoImplicitPrelude, UnicodeSyntax, DeriveDataTypeable #-}+{-# LANGUAGE CPP, NoImplicitPrelude, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-}@@ -41,13 +41,13 @@ import Data.Bits ( testBit, shiftL ) import Data.Bool ( Bool ) import Data.Data ( Data )-import Data.Eq ( Eq )-import Data.Function ( ($) )+import Data.Eq ( Eq, (==) )+import Data.Function ( ($), (.) ) import Data.Functor ( fmap ) import Data.Maybe ( Maybe(Nothing, Just), maybe ) import Data.Typeable ( Typeable ) import Data.Word ( Word8, Word16 )-import Prelude ( (+), fromIntegral, Enum )+import Prelude ( (+), (*), fromIntegral, Enum ) import System.IO ( IO ) import Text.Read ( Read ) import Text.Show ( Show )@@ -57,11 +57,6 @@ import Data.Eq ( (==) ) #endif --- from base-unicode-symbols:-import Data.Eq.Unicode ( (≡) )-import Data.Function.Unicode ( (∘) )-import Prelude.Unicode ( (⋅) )- -- from bytestring: import qualified Data.ByteString as B ( ByteString, head, unpack ) @@ -112,13 +107,13 @@ -- Standard Feature Selectors: -- See: USB 2.0 Spec. table 9-6-haltFeature, remoteWakeupFeature, testModeFeature ∷ Value+haltFeature, remoteWakeupFeature, testModeFeature :: Value haltFeature = 0 remoteWakeupFeature = 1 testModeFeature = 2 -- | See: USB 2.0 Spec. section 9.4.9-setHalt ∷ DeviceHandle → EndpointAddress → (Timeout → IO ())+setHalt :: DeviceHandle -> EndpointAddress -> (Timeout -> IO ()) setHalt devHndl endpointAddr = control devHndl Standard ToEndpoint@@ -133,7 +128,7 @@ -- You should normally use @System.USB.DeviceHandling.'USB.setConfig'@ because -- that function notifies the underlying operating system about the changed -- configuration.-setConfig ∷ DeviceHandle → Maybe ConfigValue → (Timeout → IO ())+setConfig :: DeviceHandle -> Maybe ConfigValue -> (Timeout -> IO ()) setConfig devHndl mbConfigValue = control devHndl Standard ToDevice@@ -141,7 +136,7 @@ (marshal mbConfigValue) 0 where- marshal ∷ Maybe ConfigValue → Value+ marshal :: Maybe ConfigValue -> Value marshal = maybe 0 fromIntegral -- | See: USB 2.0 Spec. section 9.4.2@@ -150,9 +145,9 @@ -- -- You should normally use @System.USB.DeviceHandling.'USB.getConfig'@ because -- that functon may exploit operating system caches (no I/O involved).-getConfig ∷ DeviceHandle → (Timeout → IO (Maybe ConfigValue))-getConfig devHndl = fmap (unmarshal ∘ B.head)- ∘ readControlExact devHndl+getConfig :: DeviceHandle -> (Timeout -> IO (Maybe ConfigValue))+getConfig devHndl = fmap (unmarshal . B.head)+ . readControlExact devHndl Standard ToDevice c'LIBUSB_REQUEST_GET_CONFIGURATION@@ -160,12 +155,12 @@ 0 1 where- unmarshal ∷ Word8 → Maybe ConfigValue+ unmarshal :: Word8 -> Maybe ConfigValue unmarshal 0 = Nothing unmarshal n = Just $ fromIntegral n -- | See: USB 2.0 Spec. section 9.4.1-clearRemoteWakeup ∷ DeviceHandle → (Timeout → IO ())+clearRemoteWakeup :: DeviceHandle -> (Timeout -> IO ()) clearRemoteWakeup devHndl = control devHndl Standard@@ -175,7 +170,7 @@ 0 -- | See: USB 2.0 Spec. section 9.4.9-setRemoteWakeup ∷ DeviceHandle → (Timeout → IO ())+setRemoteWakeup :: DeviceHandle -> (Timeout -> IO ()) setRemoteWakeup devHndl = control devHndl Standard@@ -186,7 +181,7 @@ -- | See: USB 2.0 Spec. section 9.4.9 -- TODO: What about vendor-specific test modes?-setStandardTestMode ∷ DeviceHandle → TestMode → (Timeout → IO ())+setStandardTestMode :: DeviceHandle -> TestMode -> (Timeout -> IO ()) setStandardTestMode devHndl testMode = control devHndl Standard@@ -204,9 +199,9 @@ deriving (Eq, Show, Read, Enum, Data, Typeable) -- | See: USB 2.0 Spec. section 9.4.4-getInterfaceAltSetting ∷ DeviceHandle → InterfaceNumber → (Timeout → IO InterfaceAltSetting)+getInterfaceAltSetting :: DeviceHandle -> InterfaceNumber -> (Timeout -> IO InterfaceAltSetting) getInterfaceAltSetting devHndl ifNum =- fmap B.head ∘ readControlExact devHndl+ fmap B.head . readControlExact devHndl Standard ToInterface c'LIBUSB_REQUEST_GET_INTERFACE@@ -215,9 +210,9 @@ 1 -- | See: USB 2.0 Spec. section 9.4.5-getDeviceStatus ∷ DeviceHandle → (Timeout → IO DeviceStatus)+getDeviceStatus :: DeviceHandle -> (Timeout -> IO DeviceStatus) getDeviceStatus devHndl =- fmap (unmarshal ∘ B.head) ∘ readControlExact devHndl+ fmap (unmarshal . B.head) . readControlExact devHndl Standard ToDevice c'LIBUSB_REQUEST_GET_STATUS@@ -225,15 +220,15 @@ 0 2 where- unmarshal ∷ Word8 → DeviceStatus+ unmarshal :: Word8 -> DeviceStatus unmarshal a = DeviceStatus { remoteWakeup = testBit a 1 , selfPowered = testBit a 0 } -- | See: USB 2.0 Spec. section 9.4.5-getEndpointStatus ∷ DeviceHandle → EndpointAddress → (Timeout → IO Bool)+getEndpointStatus :: DeviceHandle -> EndpointAddress -> (Timeout -> IO Bool) getEndpointStatus devHndl endpointAddr =- fmap ((1 ≡) ∘ B.head) ∘ readControlExact devHndl+ fmap ((1 ==) . B.head) . readControlExact devHndl Standard ToEndpoint c'LIBUSB_REQUEST_GET_STATUS@@ -242,7 +237,7 @@ 2 -- | See: USB 2.0 Spec. section 9.4.6-setDeviceAddress ∷ DeviceHandle → Word16 → (Timeout → IO ())+setDeviceAddress :: DeviceHandle -> Word16 -> (Timeout -> IO ()) setDeviceAddress devHndl deviceAddr = control devHndl Standard ToDevice@@ -274,9 +269,9 @@ See: USB 2.0 Spec. section 9.4.11 -}-synchFrame ∷ DeviceHandle → EndpointAddress → (Timeout → IO FrameNumber)+synchFrame :: DeviceHandle -> EndpointAddress -> (Timeout -> IO FrameNumber) synchFrame devHndl endpointAddr =- fmap unmarshal ∘ readControlExact devHndl+ fmap unmarshal . readControlExact devHndl Standard ToEndpoint c'LIBUSB_REQUEST_SYNCH_FRAME@@ -284,8 +279,8 @@ (marshalEndpointAddress endpointAddr) 2 where- unmarshal ∷ B.ByteString → FrameNumber+ unmarshal :: B.ByteString -> FrameNumber unmarshal bs = let [h, l] = B.unpack bs- in fromIntegral h ⋅ 256 + fromIntegral l+ in fromIntegral h * 256 + fromIntegral l type FrameNumber = Word16
Timeval.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | A short module to work with C's struct timeval. @@ -12,6 +12,7 @@ -- from base: import Control.Monad ( return )+import Data.Function ( (.) ) import Foreign.C.Types ( CLong ) import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr, castPtr )@@ -19,9 +20,6 @@ import Prelude ( (*), quotRem, fromIntegral, undefined, Int ) import System.IO ( IO ) --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )- -- from bindings-libusb: import Bindings.Libusb.PollingAndTiming ( C'timeval ) @@ -32,11 +30,11 @@ data CTimeval = MkCTimeval CLong CLong instance Storable CTimeval where- sizeOf _ = (sizeOf (undefined ∷ CLong)) * 2- alignment _ = alignment (undefined ∷ CLong)+ sizeOf _ = (sizeOf (undefined :: CLong)) * 2+ alignment _ = alignment (undefined :: CLong) peek p = do- s ← peekElemOff (castPtr p) 0- mus ← peekElemOff (castPtr p) 1+ s <- peekElemOff (castPtr p) 0+ mus <- peekElemOff (castPtr p) 1 return (MkCTimeval s mus) poke p (MkCTimeval s mus) = do pokeElemOff (castPtr p) 0 s@@ -44,9 +42,9 @@ -- Every things done so far in libusb was in milliseconds. So this -- function should accept a time in milliseconds too !-withTimeval ∷ Int → (Ptr C'timeval → IO α) → IO α+withTimeval :: Int -> (Ptr C'timeval -> IO α) -> IO α withTimeval milliseconds action = let (seconds, mseconds) = milliseconds `quotRem` 1000 timeval = MkCTimeval (fromIntegral seconds) (fromIntegral (1000 * mseconds)) -- micro-seconds- in with timeval (action ∘ castPtr)+ in with timeval (action . castPtr)
Utils.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP , NoImplicitPrelude- , UnicodeSyntax , BangPatterns , ScopedTypeVariables #-}@@ -28,9 +27,10 @@ import Foreign.Storable ( Storable, peek, sizeOf ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Utils ( copyBytes )-import Data.Bool ( Bool, otherwise )-import Data.Ord ( Ord, (>) )-import Data.Bits ( Bits, shiftL, shiftR, bitSize, (.&.) )+import Data.Bool ( Bool, otherwise, (&&) )+import Data.Ord ( Ord, (<=), (>=) )+import Data.Bits ( Bits, shiftL, shiftR, (.&.) )+import Data.Function ( (.) ) import Data.Int ( Int ) import Data.Maybe ( Maybe(Nothing, Just) ) import System.IO ( IO )@@ -45,75 +45,57 @@ ) import qualified Data.Vector.Generic as VG ( Vector, mapM, convert ) --- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )-import Data.Ord.Unicode ( (≥), (≤) )-import Data.Bool.Unicode ( (∧) ) - -------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- -- | @bits s e b@ extract bit @s@ to @e@ (including) from @b@.-bits ∷ (Bits α, Num α) ⇒ Int → Int → α → α+bits :: (Bits a, Num a) => Int -> Int -> a -> a bits s e b = ((1 `shiftL` (e - s + 1)) - 1) .&. (b `shiftR` s) -- | @between n b e@ tests if @n@ is between the given bounds @b@ and @e@ -- (including).-between ∷ Ord α ⇒ α → α → α → Bool-between n b e = n ≥ b ∧ n ≤ e+between :: Ord a => a -> a -> a -> Bool+between n b e = n >= b && n <= e -- | A generalized 'toEnum' that works on any 'Integral' type.-genToEnum ∷ (Integral i, Enum e) ⇒ i → e-genToEnum = toEnum ∘ fromIntegral+genToEnum :: (Integral i, Enum e) => i -> e+genToEnum = toEnum . fromIntegral -- | A generalized 'fromEnum' that returns any 'Integral' type.-genFromEnum ∷ (Integral i, Enum e) ⇒ e → i-genFromEnum = fromIntegral ∘ fromEnum+genFromEnum :: (Integral i, Enum e) => e -> i+genFromEnum = fromIntegral . fromEnum -- | @mapPeekArray f n a@ applies the monadic function @f@ to each of the @n@ -- elements of the array @a@ and returns the results in a list.-mapPeekArray ∷ (Storable a, VG.Vector v a, VG.Vector v b) ⇒ (a → IO b) → Int → Ptr a → IO (v b)-mapPeekArray f n a = peekVector n a >>= VG.mapM f ∘ VG.convert+mapPeekArray :: (Storable a, VG.Vector v a, VG.Vector v b)+ => (a -> IO b) -> Int -> Ptr a -> IO (v b)+mapPeekArray f n a = peekVector n a >>= VG.mapM f . VG.convert -peekVector ∷ forall a. (Storable a) ⇒ Int → Ptr a → IO (VS.Vector a)+peekVector :: forall a. (Storable a) => Int -> Ptr a -> IO (VS.Vector a) peekVector size ptr- | size ≤ 0 = return VS.empty+ | size <= 0 = return VS.empty | otherwise = do- let n = (size * sizeOf (undefined ∷ a))- fp ← mallocPlainForeignPtrBytes n- withForeignPtr fp $ \p → copyBytes p ptr n+ let n = (size * sizeOf (undefined :: a))+ fp <- mallocPlainForeignPtrBytes n+ withForeignPtr fp $ \p -> copyBytes p ptr n return $ VS.unsafeFromForeignPtr0 fp size -pokeVector ∷ forall a. Storable a ⇒ Ptr a → VS.Vector a → IO ()+pokeVector :: forall a. Storable a => Ptr a -> VS.Vector a -> IO () pokeVector ptr v | VS.null v = return ()- | otherwise = withForeignPtr fp $ \p →- copyBytes ptr p (size * sizeOf (undefined ∷ a))+ | otherwise = withForeignPtr fp $ \p ->+ copyBytes ptr p (size * sizeOf (undefined :: a)) where (fp, size) = VS.unsafeToForeignPtr0 v -allocaPeek ∷ Storable α ⇒ (Ptr α → IO ()) → IO α-allocaPeek f = alloca $ \ptr → f ptr >> peek ptr+allocaPeek :: Storable a => (Ptr a -> IO ()) -> IO a+allocaPeek f = alloca $ \ptr -> f ptr >> peek ptr -- | Monadic if...then...else...-ifM ∷ Monad m ⇒ m Bool → m α → m α → m α-ifM cM tM eM = cM >>= \c → if c then tM else eM--{-| @decodeBCD bitsInDigit bcd@ decodes the Binary Coded Decimal @bcd@ to a list-of its encoded digits. @bitsInDigit@, which is usually 4, is the number of bits-used to encode a single digit. See:-<http://en.wikipedia.org/wiki/Binary-coded_decimal>--}-decodeBCD ∷ Bits α ⇒ Int → α → [α]-decodeBCD bitsInDigit abcd = go 0- where- shftR = bitSize abcd - bitsInDigit-- go !shftL | shftL > shftR = []- | otherwise = let !d = (abcd `shiftL` shftL) `shiftR` shftR- in d : go (shftL + bitsInDigit)+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM cM tM eM = cM >>= \c -> if c then tM else eM -uncons ∷ Vector α → Maybe (α, Vector α)+uncons :: Vector a -> Maybe (a, Vector a) uncons v | V.null v = Nothing | otherwise = Just (V.unsafeHead v, V.unsafeTail v)
usb.cabal view
@@ -1,5 +1,5 @@ name: usb-version: 1.2+version: 1.2.0.1 cabal-version: >=1.6 build-type: Custom license: BSD3@@ -63,11 +63,10 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.7- , base-unicode-symbols >= 0.1.1 && < 0.3+ build-depends: base >= 4 && < 4.8 , bindings-libusb >= 1.4.4 && < 1.5 , bytestring >= 0.9 && < 0.11- , text >= 0.5 && < 0.12+ , text >= 0.5 && < 1.2 , vector >= 0.5 && < 0.11 exposed-modules: System.USB