diff --git a/Poll.hsc b/Poll.hsc --- a/Poll.hsc +++ b/Poll.hsc @@ -1,4 +1,4 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} #include @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/System/USB/Base.hs b/System/USB/Base.hs --- a/System/USB/Base.hs +++ b/System/USB/Base.hs @@ -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 -- -- 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." diff --git a/System/USB/IO/StandardDeviceRequests.hs b/System/USB/IO/StandardDeviceRequests.hs --- a/System/USB/IO/StandardDeviceRequests.hs +++ b/System/USB/IO/StandardDeviceRequests.hs @@ -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 diff --git a/Timeval.hs b/Timeval.hs --- a/Timeval.hs +++ b/Timeval.hs @@ -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) diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -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: - --} -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) diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -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