diff --git a/Data/BCD.hs b/Data/BCD.hs deleted file mode 100644 --- a/Data/BCD.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, BangPatterns #-} - -module Data.BCD ( BCD4, unmarshalBCD4, decodeBCD ) where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - --- from base: -import Prelude ( fromInteger, fromIntegral, (-) ) -import Control.Monad ( (>>) ) -import Data.Bits ( Bits, shiftL, shiftR, bitSize ) -import Data.Bool ( otherwise ) -import Data.Function ( ($) ) -import Data.List ( map ) -import Data.Ord ( (<) ) -import Data.Int ( Int ) -import Data.Word ( Word16 ) - - --------------------------------------------------------------------------------- --- Binary Coded Decimals --------------------------------------------------------------------------------- - --- | A decoded 16 bits Binary Coded Decimal using 4 bits for each digit. -type BCD4 = (Int, Int, Int, Int) - --- | Decode a @Word16@ as a Binary Coded Decimal using 4 bits per digit. -unmarshalBCD4 ∷ Word16 → BCD4 -unmarshalBCD4 abcd = (a, b, c, d) - where - [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd - -{-| @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 shftR [] - where - shftR = bitSize abcd - bitsInDigit - - go shftL ds | shftL < 0 = ds - | otherwise = let !d = (abcd `shiftL` shftL) `shiftR` shftR - in go (shftL - bitsInDigit) (d : ds) - - --- The End --------------------------------------------------------------------- diff --git a/System/USB/Descriptors.hs b/System/USB/Descriptors.hs --- a/System/USB/Descriptors.hs +++ b/System/USB/Descriptors.hs @@ -14,9 +14,8 @@ -- -- Where appropriate, descriptors contain references to string descriptors -- ('StrIx') that provide textual information describing a descriptor in --- human-readable form. The inclusion of string descriptors is optional. If a --- device does not support string descriptors, string reference fields must be --- reset to zero to indicate no string descriptor is available. +-- human-readable form. Note that the inclusion of string descriptors is +-- optional. -- -------------------------------------------------------------------------------- @@ -24,7 +23,7 @@ ( -- * Device descriptor DeviceDesc(..) - , BCD4 + , ReleaseNumber -- | For a database of USB vendors and products see the @usb-id-database@ -- package at: @@ -69,4 +68,3 @@ ) where import System.USB.Internal -import Data.BCD ( BCD4 ) diff --git a/System/USB/Internal.hs b/System/USB/Internal.hs --- a/System/USB/Internal.hs +++ b/System/USB/Internal.hs @@ -30,14 +30,14 @@ import Data.Functor ( Functor, fmap, (<$>) ) import Data.Data ( Data ) import Data.Typeable ( Typeable ) -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( Maybe(Nothing, Just), fromMaybe ) import Data.List ( lookup, map, (++) ) import Data.Int ( Int ) import Data.Word ( Word8, Word16 ) import Data.Char ( String ) import Data.Eq ( Eq, (==) ) import Data.Ord ( Ord, (<), (>) ) -import Data.Bool ( Bool(False, True), not ) +import Data.Bool ( Bool(False, True), not, otherwise ) import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL ) import System.IO ( IO ) import Text.Show ( Show, show ) @@ -50,20 +50,26 @@ import Data.Eq.Unicode ( (≢), (≡) ) -- from bytestring: -import qualified Data.ByteString as B ( ByteString, packCStringLen, drop ) +import qualified Data.ByteString as B ( ByteString, packCStringLen ) import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' ) import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen ) -- from text: -import qualified Data.Text as T ( unpack ) -import qualified Data.Text.Encoding as TE ( decodeUtf16LE ) +import qualified Data.Text.Foreign as T ( fromPtr ) +import qualified Data.Text as T ( unpack ) -- from bindings-libusb: import Bindings.Libusb -- from usb: -import Data.BCD ( BCD4, unmarshalBCD4 ) -import Utils ( bits, between, void, genToEnum, genFromEnum, mapPeekArray, ifM ) +import Utils ( bits + , between + , void + , genToEnum, genFromEnum + , mapPeekArray + , ifM + , decodeBCD + ) -------------------------------------------------------------------------------- @@ -154,13 +160,13 @@ @(==) = (==) \`on\` `deviceDesc`@ -} data Device = Device - { _ctx ∷ Ctx -- ^ This reference to the 'Ctx' is needed so that it won't - -- get garbage collected. The finalizer "p'libusb_exit" is - -- run only when all references to 'Devices' are gone. + { _ctx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't + -- get garbage collected. The finalizer "p'libusb_exit" is + -- run only when all references to 'Devices' are gone. - , getDevFrgnPtr ∷ ForeignPtr C'libusb_device + , getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device) - , deviceDesc ∷ DeviceDesc -- ^ Get the descriptor of the device. + , deviceDesc ∷ !DeviceDesc -- ^ Get the descriptor of the device. } deriving Typeable instance Eq Device where @@ -254,11 +260,11 @@ 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' - -- and therefor the 'Ctx' alive. - -- ^ Retrieve the 'Device' from the 'DeviceHandle'. - , getDevHndlPtr ∷ Ptr C'libusb_device_handle - -- ^ Retrieve the pointer to the @libusb@ device handle. + { 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) + -- ^ Retrieve the pointer to the @libusb@ device handle. } deriving Typeable instance Eq DeviceHandle where @@ -642,48 +648,50 @@ This structure can be retrieved by 'deviceDesc'. -} data DeviceDesc = DeviceDesc - { -- | USB specification release number in binary-coded decimal. - deviceUSBSpecReleaseNumber ∷ BCD4 + { -- | USB specification release number. + 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 in binary-coded decimal. - , deviceReleaseNumber ∷ BCD4 + -- | Device release number. + , deviceReleaseNumber ∷ !ReleaseNumber - -- | Index of string descriptor describing manufacturer. - , deviceManufacturerStrIx ∷ StrIx + -- | Optional index of string descriptor describing manufacturer. + , deviceManufacturerStrIx ∷ !(Maybe StrIx) - -- | Index of string descriptor describing product. - , deviceProductStrIx ∷ StrIx + -- | Optional index of string descriptor describing product. + , deviceProductStrIx ∷ !(Maybe StrIx) - -- | Index of string descriptor containing device serial number. - , deviceSerialNumberStrIx ∷ StrIx + -- | Optional index of string descriptor containing device serial number. + , deviceSerialNumberStrIx ∷ !(Maybe StrIx) -- | Number of possible configurations. - , deviceNumConfigs ∷ Word8 + , deviceNumConfigs ∷ !Word8 -- | List of configurations supported by the device. - , deviceConfigs ∷ [ConfigDesc] + , deviceConfigs ∷ ![ConfigDesc] } deriving (Show, Read, Eq, Data, Typeable) +type ReleaseNumber = (Int, Int, Int, Int) + type VendorId = Word16 type ProductId = Word16 @@ -699,29 +707,29 @@ -} data ConfigDesc = ConfigDesc { -- | Identifier value for the configuration. - configValue ∷ ConfigValue + configValue ∷ !ConfigValue - -- | Index of string descriptor describing the configuration. - , configStrIx ∷ StrIx + -- | Optional index of string descriptor describing the configuration. + , 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 -- | Number of interfaces supported by the configuration. - , configNumInterfaces ∷ Word8 + , configNumInterfaces ∷ !Word8 -- | List of interfaces supported by the configuration. Note that the -- length of this list should equal 'configNumInterfaces'. - , configInterfaces ∷ [Interface] + , configInterfaces ∷ ![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 (Show, Read, Eq, Data, Typeable) @@ -737,12 +745,12 @@ type ConfigAttribs = DeviceStatus data DeviceStatus = DeviceStatus - { 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 - -- device is currently self-powered + { 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 + -- device is currently self-powered } deriving (Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- @@ -757,31 +765,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 - -- | Index of string descriptor describing the interface. - , interfaceStrIx ∷ StrIx + -- | Optional index of string descriptor describing the interface. + , interfaceStrIx ∷ !(Maybe StrIx) -- | List of endpoints supported by the interface. - , interfaceEndpoints ∷ [EndpointDesc] + , interfaceEndpoints ∷ ![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 (Show, Read, Eq, Data, Typeable) @@ -796,30 +804,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 if 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 (Show, Read, Eq, Data, Typeable) -------------------------------------------------------------------------------- @@ -828,8 +836,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 (Show, Read, Eq, Data, Typeable) -- | The direction of data transfer relative to the host. @@ -854,7 +862,7 @@ Control -- | Isochronous transfers occur continuously and periodically. - | Isochronous Synchronization Usage + | Isochronous !Synchronization !Usage -- | Bulk transfers can be used for large bursty data. | Bulk @@ -880,8 +888,8 @@ -------------------------------------------------------------------------------- data MaxPacketSize = MaxPacketSize - { maxPacketSize ∷ Size - , transactionOpportunities ∷ TransactionOpportunities + { maxPacketSize ∷ !Size + , transactionOpportunities ∷ !TransactionOpportunities } deriving (Show, Read, Eq, Data, Typeable) -- | Number of additional transactions. @@ -906,7 +914,7 @@ configs ← forM [0..numConfigs-1] $ getConfigDesc devPtr return DeviceDesc - { deviceUSBSpecReleaseNumber = unmarshalBCD4 $ + { deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $ c'libusb_device_descriptor'bcdUSB d , deviceClass = c'libusb_device_descriptor'bDeviceClass d , deviceSubClass = c'libusb_device_descriptor'bDeviceSubClass d @@ -914,15 +922,27 @@ , deviceMaxPacketSize0 = c'libusb_device_descriptor'bMaxPacketSize0 d , deviceVendorId = c'libusb_device_descriptor'idVendor d , deviceProductId = c'libusb_device_descriptor'idProduct d - , deviceReleaseNumber = unmarshalBCD4 $ + , deviceReleaseNumber = unmarshalReleaseNumber $ c'libusb_device_descriptor'bcdDevice d - , deviceManufacturerStrIx = c'libusb_device_descriptor'iManufacturer d - , deviceProductStrIx = c'libusb_device_descriptor'iProduct d - , deviceSerialNumberStrIx = c'libusb_device_descriptor'iSerialNumber d + , deviceManufacturerStrIx = unmarshalStrIx $ + c'libusb_device_descriptor'iManufacturer d + , deviceProductStrIx = unmarshalStrIx $ + c'libusb_device_descriptor'iProduct d + , deviceSerialNumberStrIx = unmarshalStrIx $ + c'libusb_device_descriptor'iSerialNumber d , deviceNumConfigs = numConfigs , deviceConfigs = configs } +unmarshalReleaseNumber ∷ Word16 → ReleaseNumber +unmarshalReleaseNumber abcd = (a, b, c, d) + where + [a, b, c, d] = map fromIntegral $ decodeBCD 4 abcd + +unmarshalStrIx ∷ Word8 → Maybe StrIx +unmarshalStrIx strIx | strIx ≡ 0 = Nothing + | otherwise = Just strIx + getConfigDesc ∷ Ptr C'libusb_device → Word8 → IO ConfigDesc getConfigDesc devPtr ix = bracket getConfigDescPtr c'libusb_free_config_descriptor @@ -948,7 +968,8 @@ return ConfigDesc { configValue = c'libusb_config_descriptor'bConfigurationValue c - , configStrIx = c'libusb_config_descriptor'iConfiguration c + , configStrIx = unmarshalStrIx $ + c'libusb_config_descriptor'iConfiguration c , configAttribs = unmarshalConfigAttribs $ c'libusb_config_descriptor'bmAttributes c , configMaxPower = c'libusb_config_descriptor'MaxPower c @@ -989,7 +1010,8 @@ , interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i , interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i , interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i - , interfaceStrIx = c'libusb_interface_descriptor'iInterface i + , interfaceStrIx = unmarshalStrIx $ + c'libusb_interface_descriptor'iInterface i , interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i , interfaceEndpoints = endpoints , interfaceExtra = extra @@ -1049,62 +1071,72 @@ -- ** String descriptors -------------------------------------------------------------------------------- --- | The size in number of bytes of the header of string descriptors -strDescHeaderSize ∷ Size -strDescHeaderSize = 2 - {-| Retrieve a list of supported languages. This function may throw 'USBException's. -} getLanguages ∷ DeviceHandle → IO [LangId] -getLanguages devHndl = allocaArray maxSize $ \dataPtr → do - reportedSize ← write dataPtr +getLanguages devHndl = getStrDescUnmarshal devHndl 0 0 maxNrOfLangIds unmarshal + where + unmarshal strPtr strSize = map unmarshalLangId <$> peekArray strSize strPtr + maxNrOfLangIds = 148 -- Based on the number of language identifiers in: + -- http://www.usb.org/developers/docs/USB_LANGIDs.pdf - let strSize = (reportedSize - strDescHeaderSize) `div` 2 - strPtr = castPtr $ dataPtr `plusPtr` strDescHeaderSize +{-| Retrieve a string descriptor from a device. - map unmarshalLangId <$> peekArray strSize strPtr - where - maxSize = 255 -- Some devices choke on size > 255 - write = putStrDesc devHndl 0 0 maxSize +This is a convenience function which formulates the appropriate control message +to retrieve the descriptor. The string returned is Unicode, as detailed in the +USB specifications. -{-| @putStrDesc devHndl strIx langId maxSize dataPtr@ retrieves the -string descriptor @strIx@ in the language @langId@ from the @devHndl@ -and writes at most @maxSize@ bytes from that string descriptor to the -location that @dataPtr@ points to. So ensure there is at least space -for @maxSize@ bytes there. Next, the header of the string descriptor -is checked for correctness. If it's incorrect an 'IOException' is -thrown. Finally, the size reported in the header is returned. +This function may throw 'USBException's. -} -putStrDesc ∷ DeviceHandle - → StrIx - → Word16 - → Size - → Ptr CUChar - → IO Size -putStrDesc devHndl strIx langId maxSize dataPtr = do - actualSize ← checkUSBException $ c'libusb_get_string_descriptor - (getDevHndlPtr devHndl) - strIx - langId - dataPtr - (fromIntegral maxSize) - when (actualSize < strDescHeaderSize) $ - throwIO $ IOException "Incomplete header" +getStrDesc ∷ DeviceHandle + → StrIx -- ^ Should not be 0! + → LangId -- ^ Make sure this language is supported by the device + -- (See: 'getLanguages'). + → Int -- ^ Maximum number of characters in the requested string. + -- An 'IOException' will be thrown when the requested + -- string is larger than this number. + → IO String +getStrDesc devHndl strIx langId nrOfChars = assert (strIx ≢ 0) $ + getStrDescUnmarshal devHndl strIx (marshalLangId langId) nrOfChars unmarshal + where + unmarshal strPtr strSize = T.unpack <$> T.fromPtr strPtr strSize - reportedSize ← peek dataPtr +getStrDescUnmarshal ∷ DeviceHandle + → StrIx + → Word16 + → Int + → (Ptr Word16 → Int → IO α) + → IO α +getStrDescUnmarshal devHndl strIx langId nrOfWords unmarshal = do + let maxSize = headerSize + nrOfWords * 2 + headerSize = 2 + allocaArray maxSize $ \dataPtr → do + actualSize ← checkUSBException $ c'libusb_get_string_descriptor + (getDevHndlPtr devHndl) + strIx + langId + dataPtr + (fromIntegral maxSize) + when (actualSize < headerSize) $ + throwIO $ IOException "Incomplete header" - when (reportedSize > fromIntegral actualSize) $ - throwIO $ IOException "Not enough space to hold data" + reportedSize ← peek dataPtr - descType ← peekElemOff dataPtr 1 + when (reportedSize > fromIntegral actualSize) $ + throwIO $ IOException "Not enough space to hold data" - when (descType ≢ c'LIBUSB_DT_STRING) $ - throwIO $ IOException "Invalid header" + descType ← peekElemOff dataPtr 1 - return $ fromIntegral reportedSize + when (descType ≢ c'LIBUSB_DT_STRING) $ + throwIO $ IOException "Invalid header" + let strPtr = castPtr $ dataPtr `plusPtr` headerSize + strSize = (fromIntegral reportedSize - headerSize) `div` 2 + + unmarshal strPtr strSize + {-| The language ID consists of the primary language identifier and the sublanguage identififier as described in: @@ -1131,28 +1163,6 @@ -- Can be retrieved by all the *StrIx functions. type StrIx = Word8 -{-| Retrieve a string descriptor from a device. - -This is a convenience function which formulates the appropriate control message -to retrieve the descriptor. The string returned is Unicode, as detailed in the -USB specifications. - -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 String -getStrDesc devHndl strIx langId nrOfChars = - fmap decode $ BI.createAndTrim size $ write ∘ castPtr - where - write = putStrDesc devHndl strIx (marshalLangId langId) size - size = strDescHeaderSize + 2 * nrOfChars -- characters are 2 bytes - decode = T.unpack ∘ TE.decodeUtf16LE ∘ B.drop strDescHeaderSize - {-| Retrieve a string descriptor from a device using the first supported language. @@ -1163,10 +1173,11 @@ 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. + → StrIx -- ^ Should not be 0! + -- If so, an 'InvalidParamException' will be thrown. + → Int -- ^ Maximum number of characters in the requested + -- string. An 'IOException' will be thrown when the + -- requested string is larger than this number. → IO String getStrDescFirstLang devHndl strIx nrOfChars = do langIds ← getLanguages devHndl diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-} +{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax, BangPatterns #-} module Utils where @@ -12,13 +12,13 @@ , fromInteger , Integral, fromIntegral ) -import Control.Monad ( Monad, (>>=), fail, mapM ) +import Control.Monad ( Monad, (>>=), (>>), fail, mapM ) import Foreign.Ptr ( Ptr ) import Foreign.Storable ( Storable, ) import Foreign.Marshal.Array ( peekArray ) -import Data.Bool ( Bool ) -import Data.Ord ( Ord ) -import Data.Bits ( Bits, shiftR, (.&.) ) +import Data.Bool ( Bool, otherwise ) +import Data.Ord ( Ord, (<) ) +import Data.Bits ( Bits, shiftL, shiftR, bitSize, (.&.) ) import Data.Int ( Int ) import Data.Functor ( Functor, (<$)) import System.IO ( IO ) @@ -65,6 +65,20 @@ 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 shftR [] + where + shftR = bitSize abcd - bitsInDigit + + go shftL ds | shftL < 0 = ds + | otherwise = let !d = (abcd `shiftL` shftL) `shiftR` shftR + in go (shftL - bitsInDigit) (d : ds) -- The End --------------------------------------------------------------------- diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -1,5 +1,5 @@ name: usb -version: 0.5.0.1 +version: 0.6 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -74,5 +74,4 @@ System.USB.Exceptions System.USB.Unsafe other-modules: System.USB.Internal - Data.BCD Utils