diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,47 @@ -import Distribution.Simple +#! /usr/bin/env runhaskell -main = defaultMain +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} + +module Main (main) where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- from base +import Control.Monad ( (>>), return ) +import System.IO ( IO ) + +-- from cabal +import Distribution.Simple ( defaultMainWithHooks + , simpleUserHooks + , UserHooks(haddockHook) + , Args + ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program ( userSpecifyArgs ) +import Distribution.Simple.Setup ( HaddockFlags ) +import Distribution.PackageDescription ( PackageDescription(..) ) + + +------------------------------------------------------------------------------- +-- Cabal setup program with support for 'cabal test' and +-- which sets the CPP define '__HADDOCK __' when haddock is run. +------------------------------------------------------------------------------- + +main ∷ IO () +main = defaultMainWithHooks hooks + where + hooks = simpleUserHooks { haddockHook = haddockHook' } + +-- Define __HADDOCK__ for CPP when running haddock. +haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO () +haddockHook' pkg lbi = + haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) + where + p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) + + +-- The End --------------------------------------------------------------------- diff --git a/System/USB/IO/Synchronous.hs b/System/USB/IO/Synchronous.hs --- a/System/USB/IO/Synchronous.hs +++ b/System/USB/IO/Synchronous.hs @@ -18,8 +18,12 @@ , Size -- * Control transfers + , ControlAction , RequestType(..) , Recipient(..) + , Request + , Value + , Index , control , readControl diff --git a/System/USB/IO/Synchronous/Enumerator.hs b/System/USB/IO/Synchronous/Enumerator.hs --- a/System/USB/IO/Synchronous/Enumerator.hs +++ b/System/USB/IO/Synchronous/Enumerator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, ScopedTypeVariables #-} +{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-} -------------------------------------------------------------------------------- -- | @@ -22,21 +22,17 @@ -------------------------------------------------------------------------------- -- from base: -import Prelude ( fromIntegral ) +import Prelude ( fromInteger, fromIntegral ) import Data.Function ( ($) ) -import Data.Int ( Int ) +import Data.Word ( Word8 ) import Data.Maybe ( Maybe(Nothing, Just) ) -import Control.Monad ( Monad, return, (>>=), fail ) -import System.IO ( IO ) +import Control.Monad ( return, (>>=), fail ) import Text.Show ( show ) -import Foreign.Marshal.Alloc ( malloc, mallocBytes, free ) -import Foreign.Storable ( Storable, peek, sizeOf ) -import Foreign.Ptr ( Ptr, castPtr ) +import Foreign.Storable ( peek ) +import Foreign.Ptr ( castPtr ) -- from base-unicode-symbols: -import Prelude.Unicode ( (⋅), (⊥) ) -import Data.Function.Unicode ( (∘) ) -import Data.Eq.Unicode ( (≢) ) +import Data.Eq.Unicode ( (≡), (≢) ) import Data.Bool.Unicode ( (∧) ) -- from bindings-libusb: @@ -48,8 +44,11 @@ import Control.Monad.IO.Class ( liftIO ) -- from MonadCatchIO-transformers: -import Control.Monad.CatchIO ( MonadCatchIO, bracket ) +import Control.Monad.CatchIO ( MonadCatchIO ) +-- from MonadCatchIO-transformers-foreign: +import Control.Monad.CatchIO.Foreign ( alloca, allocaBytes ) + -- from iteratee: import Data.Iteratee.Base ( EnumeratorGM , StreamG(Chunk) @@ -58,40 +57,45 @@ , enumErr , throwErr ) -import Data.Iteratee.Base.StreamChunk ( ReadableChunk (readFromPtr) ) +import Data.Iteratee.Base.StreamChunk ( ReadableChunk(readFromPtr) ) -- from myself: import System.USB.DeviceHandling ( DeviceHandle ) import System.USB.Descriptors ( EndpointAddress ) import System.USB.IO.Synchronous ( Timeout, Size ) + import System.USB.Internal ( C'TransferFunc , getDevHndlPtr , marshalEndpointAddress , convertUSBException ) +#ifdef __HADDOCK__ +import System.USB.Descriptors ( maxPacketSize, endpointMaxPacketSize ) +#endif + -------------------------------------------------------------------------------- -- Enumerators -------------------------------------------------------------------------------- -enumReadBulk ∷ (ReadableChunk s el, MonadCatchIO m) +enumReadBulk ∷ (ReadableChunk s Word8, MonadCatchIO m) ⇒ DeviceHandle -- ^ A handle for the device to communicate with. → EndpointAddress -- ^ The address of a valid 'In' and 'Bulk' -- endpoint to communicate with. Make sure the -- endpoint belongs to the current alternate -- setting of a claimed interface which belongs -- to the device. + → Size -- ^ Chunk size. A good value for this would be + -- the @'maxPacketSize' . 'endpointMaxPacketSize'@. → Timeout -- ^ Timeout (in milliseconds) that this function -- should wait for each chunk before giving up -- due to no response being received. For no -- timeout, use value 0. - → Size -- ^ Chunk size. A good value for this would be - -- the 'endpointMaxPacketSize'. - → EnumeratorGM s el m α + → EnumeratorGM s Word8 m α enumReadBulk = enumRead c'libusb_bulk_transfer -enumReadInterrupt ∷ (ReadableChunk s el, MonadCatchIO m) +enumReadInterrupt ∷ (ReadableChunk s Word8, MonadCatchIO m) ⇒ DeviceHandle -- ^ A handle for the device to communicate -- with. → EndpointAddress -- ^ The address of a valid 'In' and @@ -100,65 +104,54 @@ -- the current alternate setting of a -- claimed interface which belongs to the -- device. + → Size -- ^ Chunk size. A good value for this would + -- be the @'maxPacketSize' . 'endpointMaxPacketSize'@. → Timeout -- ^ Timeout (in milliseconds) that this -- function should wait for each chunk -- before giving up due to no response -- being received. For no timeout, use -- value 0. - → Size -- ^ Chunk size. A good value for this would - -- be the 'endpointMaxPacketSize'. - → EnumeratorGM s el m α + → EnumeratorGM s Word8 m α enumReadInterrupt = enumRead c'libusb_interrupt_transfer -------------------------------------------------------------------------------- -enumRead ∷ ∀ s el m α. (ReadableChunk s el, MonadCatchIO m) - ⇒ C'TransferFunc → DeviceHandle - → EndpointAddress - → Timeout - → Size - → EnumeratorGM s el m α -enumRead c'transfer devHndl - endpoint - timeout - chunkSize = \iter -> - genAlloca $ \transferredPtr → - let bufferSize = chunkSize ⋅ sizeOf ((⊥) ∷ el) - in genAllocaBytes bufferSize $ \dataPtr → - let loop i1 = do - err ← liftIO $ c'transfer (getDevHndlPtr devHndl) - (marshalEndpointAddress endpoint) - (castPtr dataPtr) - (fromIntegral bufferSize) - transferredPtr - (fromIntegral timeout) - if err ≢ c'LIBUSB_SUCCESS ∧ - err ≢ c'LIBUSB_ERROR_TIMEOUT - then enumErr (show $ convertUSBException err) i1 +enumRead ∷ (ReadableChunk s Word8, MonadCatchIO m) + ⇒ C'TransferFunc → ( DeviceHandle + → EndpointAddress + → Size + → Timeout + → EnumeratorGM s Word8 m α + ) +enumRead c'transfer = \devHndl + endpoint + chunkSize + timeout → \iter → + alloca $ \transferredPtr → + allocaBytes chunkSize $ \dataPtr → + let loop i1 = do + err ← liftIO $ c'transfer (getDevHndlPtr devHndl) + (marshalEndpointAddress endpoint) + (castPtr dataPtr) + (fromIntegral chunkSize) + transferredPtr + (fromIntegral timeout) + if err ≢ c'LIBUSB_SUCCESS ∧ + err ≢ c'LIBUSB_ERROR_TIMEOUT + then enumErr (show $ convertUSBException err) i1 + else do + t ← liftIO $ peek transferredPtr + if t ≡ 0 + then return i1 else do - t ← liftIO $ peek transferredPtr s ← liftIO $ readFromPtr dataPtr $ fromIntegral t r ← runIter i1 $ Chunk s case r of Done x _ → return $ return x Cont i2 Nothing → loop i2 Cont _ (Just e) → return $ throwErr e - in loop iter - - --------------------------------------------------------------------------------- --- Utilities --------------------------------------------------------------------------------- - -genAlloca ∷ (Storable α, MonadCatchIO m) ⇒ (Ptr α → m β) → m β -genAlloca = bracketIO malloc free - -genAllocaBytes ∷ (Storable α, MonadCatchIO m) ⇒ Int → (Ptr α → m β) → m β -genAllocaBytes n = bracketIO (mallocBytes n) free - -bracketIO ∷ MonadCatchIO m ⇒ IO α → (α → IO γ) → (α → m β) → m β -bracketIO before after = bracket (liftIO before) (liftIO ∘ after) + in loop iter -- The End --------------------------------------------------------------------- diff --git a/System/USB/Internal.hs b/System/USB/Internal.hs --- a/System/USB/Internal.hs +++ b/System/USB/Internal.hs @@ -1172,23 +1172,23 @@ {-| Handy type synonym for read transfers. -A @ReadAction@ is a function which takes a 'Timeout' and a 'Size' which defines -how many bytes to read. The function returns an 'IO' action which, when +A @ReadAction@ is a function which takes a 'Size' which defines how many bytes +to read and a 'Timeout'. The function returns an 'IO' action which, when executed, performs the actual read and returns the 'B.ByteString' that was read paired with a flag which indicates whether a transfer timed out. -} -type ReadAction = Timeout → Size → IO (B.ByteString, Bool) +type ReadAction = Size → Timeout → IO (B.ByteString, Bool) {-| Handy type synonym for write transfers. -A @WriteAction@ is a function which takes a 'Timeout' and the 'B.ByteString' to -write. The function returns an 'IO' action which, when exectued, returns the +A @WriteAction@ is a function which takes a 'B.ByteString' to write and a +'Timeout'. The function returns an 'IO' action which, when exectued, returns the number of bytes that were actually written paired with an flag which indicates whether a transfer timed out. -} -type WriteAction = Timeout → B.ByteString → IO (Size, Bool) +type WriteAction = B.ByteString → Timeout → IO (Size, Bool) --- | A timeout in millseconds. A timeout defines how long a transfer should wait +-- | A timeout in milliseconds. A timeout defines how long a transfer should wait -- before giving up due to no response being received. For no timeout, use value -- 0. type Timeout = Int @@ -1200,6 +1200,9 @@ -- ** Control transfers ------------------------------------------------------------------------------- +-- | Handy type synonym that names the parameters of a control transfer. +type ControlAction α = RequestType → Recipient → Request → Value → Index → α + data RequestType = Standard | Class | Vendor @@ -1211,13 +1214,19 @@ | ToOther deriving (Enum, Show, Eq, Data, Typeable) +type Request = Word8 + +-- | (Host-endian) +type Value = Word16 + +-- | (Host-endian) +type Index = Word16 + marshalRequestType ∷ RequestType → Recipient → Word8 marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r {-| Perform a USB /control/ request that does not transfer data. -The /value/ and /index/ values should be given in host-endian byte order. - Exceptions: * 'TimeoutException' if the transfer timed out. @@ -1228,17 +1237,8 @@ * Another 'USBException'. -} -control ∷ DeviceHandle -- ^ A handle for the device to communicate with. - → RequestType -- ^ The type of request. - → Recipient -- ^ The recipient of the request. - → Word8 -- ^ Request. - → Word16 -- ^ Value. - → Word16 -- ^ Index. - → Timeout -- ^ Timeout (in milliseconds) that this function should - -- wait before giving up due to no response being - -- received. For no timeout, use value 0. - → IO () -control devHndl reqType reqRecipient request value index timeout = +control ∷ DeviceHandle → ControlAction (Timeout → IO ()) +control devHndl = \reqType reqRecipient request value index → \timeout → void $ checkUSBException $ c'libusb_control_transfer (getDevHndlPtr devHndl) (marshalRequestType reqType reqRecipient) @@ -1251,8 +1251,6 @@ {-| Perform a USB /control/ read. -The /value/ and /index/ values should be given in host-endian byte order. - Exceptions: * 'PipeException' if the control request was not supported by the device @@ -1261,18 +1259,12 @@ * Another 'USBException'. -} -readControl ∷ DeviceHandle -- ^ A handle for the device to communicate with. - → RequestType -- ^ The type of request. - → Recipient -- ^ The recipient of the request. - → Word8 -- ^ Request. - → Word16 -- ^ Value. - → Word16 -- ^ Index. - → ReadAction -readControl devHndl reqType reqRecipient request value index = \timeout size → +readControl ∷ DeviceHandle → ControlAction ReadAction +readControl devHndl = \reqType reqRecipient request value index → \size timeout → BI.createAndTrim' size $ \dataPtr → do err ← c'libusb_control_transfer (getDevHndlPtr devHndl) - (setBit (marshalRequestType reqType reqRecipient) 7) + (marshalRequestType reqType reqRecipient `setBit` 7) request value index @@ -1286,8 +1278,6 @@ {-| Perform a USB /control/ write. -The /value/ and /index/ values should be given in host-endian byte order. - Exceptions: * 'PipeException' if the control request was not supported by the device @@ -1296,14 +1286,8 @@ * Another 'USBException'. -} -writeControl ∷ DeviceHandle -- ^ A handle for the device to communicate with. - → RequestType -- ^ The type of request. - → Recipient -- ^ The recipient of the request. - → Word8 -- ^ Request. - → Word16 -- ^ Value. - → Word16 -- ^ Index. - → WriteAction -writeControl devHndl reqType reqRecipient request value index = \timeout input → +writeControl ∷ DeviceHandle → ControlAction WriteAction +writeControl devHndl = \reqType reqRecipient request value index → \input timeout → input `writeWith` \size dataPtr → do err ← c'libusb_control_transfer (getDevHndlPtr devHndl) @@ -1382,11 +1366,8 @@ deriving (Show, Enum, Data, Typeable) -- | See: USB 2.0 Spec. section 9.4.4 -getInterfaceAltSetting ∷ DeviceHandle - → InterfaceNumber - → Timeout - → IO InterfaceAltSetting -getInterfaceAltSetting devHndl ifNum timeout = do +getInterfaceAltSetting ∷ DeviceHandle → InterfaceNumber → Timeout → IO InterfaceAltSetting +getInterfaceAltSetting devHndl ifNum = \timeout → do (bs, _) ← readControl devHndl Standard ToInterface @@ -1401,7 +1382,7 @@ -- | See: USB 2.0 Spec. section 9.4.5 getDeviceStatus ∷ DeviceHandle → Timeout → IO DeviceStatus -getDeviceStatus devHndl timeout = do +getDeviceStatus devHndl = \timeout → do (bs, _) ← readControl devHndl Standard ToDevice @@ -1421,11 +1402,8 @@ } -- | See: USB 2.0 Spec. section 9.4.5 -getEndpointStatus ∷ DeviceHandle - → EndpointAddress - → Timeout - → IO Bool -getEndpointStatus devHndl endpointAddr timeout = do +getEndpointStatus ∷ DeviceHandle → EndpointAddress → Timeout → IO Bool +getEndpointStatus devHndl endpointAddr = \timeout → do (bs, _) ← readControl devHndl Standard ToEndpoint @@ -1452,7 +1430,7 @@ -- | See: USB 2.0 Spec. section 9.4.11 synchFrame ∷ DeviceHandle → EndpointAddress → Timeout → IO Int -synchFrame devHndl endpointAddr timeout = do +synchFrame devHndl endpointAddr = \timeout → do (bs, _) ← readControl devHndl Standard ToEndpoint @@ -1577,8 +1555,8 @@ → CUInt -- timeout → IO CInt -- error -readTransfer ∷ C'TransferFunc → DeviceHandle → EndpointAddress → ReadAction -readTransfer c'transfer devHndl endpointAddr = \timeout size → +readTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → ReadAction) +readTransfer c'transfer = \devHndl endpointAddr → \size timeout → BI.createAndTrim' size $ \dataPtr → do (transferred, timedOut) ← transfer c'transfer devHndl @@ -1588,8 +1566,8 @@ dataPtr return (0, transferred, timedOut) -writeTransfer ∷ C'TransferFunc → DeviceHandle → EndpointAddress → WriteAction -writeTransfer c'transfer devHndl endpointAddr = \timeout input → +writeTransfer ∷ C'TransferFunc → (DeviceHandle → EndpointAddress → WriteAction) +writeTransfer c'transfer = \devHndl endpointAddr → \input timeout → input `writeWith` transfer c'transfer devHndl endpointAddr diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -1,7 +1,7 @@ name: usb -version: 0.3.1 +version: 0.4 cabal-version: >=1.6 -build-type: Simple +build-type: Custom license: BSD3 license-file: LICENSE copyright: 2009–2010 Bas van Dijk @@ -21,14 +21,15 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.3 - , base-unicode-symbols >= 0.1.1 && < 0.3 - , bindings-libusb >= 1.3 && < 1.5 - , bytestring >= 0.9 && < 0.10 - , text >= 0.5 && < 0.8 - , iteratee >= 0.3.5 && < 0.4 - , transformers >= 0.2 && < 0.3 - , MonadCatchIO-transformers >= 0.2 && < 0.3 + build-depends: base >= 4 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , bindings-libusb >= 1.3 && < 1.5 + , bytestring >= 0.9 && < 0.10 + , text >= 0.5 && < 0.8 + , iteratee >= 0.3.5 && < 0.4 + , transformers >= 0.2 && < 0.3 + , MonadCatchIO-transformers >= 0.2 && < 0.3 + , MonadCatchIO-transformers-foreign >= 0.1 && < 0.2 exposed-modules: System.USB System.USB.Initialization System.USB.Enumeration