#if __GLASGOW_HASKELL__ >= 704
#endif
#ifdef HAS_EVENT_MANAGER
#endif
#ifdef GENERICS
#endif
module System.USB.Base where
import Prelude ( Num, (+), (), (*), Integral, fromIntegral, div
, Enum, fromEnum, error, String, ($!), seq
)
import Foreign.C.Types ( CUChar, CInt, CUInt )
import Foreign.C.String ( CStringLen )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
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 ( (=<<), return, when )
import Control.Arrow ( (&&&) )
import Data.Function ( ($), (.), on )
import Data.Data ( Data )
import Data.Typeable ( Typeable )
import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe )
import Data.List ( lookup, (++) )
import Data.Int ( Int )
import Data.Word ( Word8, Word16 )
import Data.Eq ( Eq, (==), (/=) )
import Data.Ord ( Ord, (<), (>) )
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 )
import Text.Read ( Read )
import Text.Printf ( printf )
#if MIN_VERSION_base(4,2,0)
import Data.Functor ( fmap, (<$>) )
#else
import Control.Monad ( fmap )
import Control.Applicative ( (<$>) )
#endif
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger, negate )
import Control.Monad ( (>>), fail )
#endif
import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length )
import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' )
import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen )
import Data.Text ( Text )
import qualified Data.Text.Encoding as TE ( decodeUtf16LE )
import Data.Vector ( Vector )
import qualified Data.Vector.Generic as VG ( convert, map )
import Bindings.Libusb
import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray
, allocaPeek, ifM, uncons
)
#ifdef HAS_EVENT_MANAGER
import Prelude ( undefined )
import Foreign.C.Types ( CShort, CChar )
import Foreign.Marshal.Alloc ( allocaBytes, free )
import Foreign.Marshal.Array ( peekArray0, copyArray, advancePtr )
import Foreign.Storable ( sizeOf, poke )
import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr )
import Control.Monad ( (>>=), mapM_, forM )
import Data.IORef ( newIORef, atomicModifyIORef, readIORef )
import System.Posix.Types ( Fd(Fd) )
import Control.Exception ( uninterruptibleMask_ )
import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )
import System.IO ( hPutStrLn, stderr )
#if MIN_VERSION_base(4,4,0)
import GHC.Event
#else
import System.Event
#endif
( FdKey
, registerFd, unregisterFd
, registerTimeout, unregisterTimeout
#if MIN_VERSION_base(4,7,0)
, getSystemTimerManager
#endif
)
import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems )
import qualified Data.ByteString.Internal as BI ( create )
import qualified Data.Vector.Unboxed as Unboxed ( Vector )
import qualified Data.Vector.Storable as Storable ( Vector )
import qualified Data.Vector.Generic as VG ( empty, length, sum, foldM_, unsafeFreeze)
import qualified Data.Vector.Generic.Mutable as VGM ( unsafeNew, unsafeWrite )
import Timeval ( withTimeval )
import qualified Poll ( toEvent )
import SystemEventManager ( getSystemEventManager )
import Utils ( pokeVector )
#endif
#if defined(HAS_EVENT_MANAGER) || defined(mingw32_HOST_OS)
import qualified Foreign.Concurrent as FC ( newForeignPtr )
#endif
#if !defined(mingw32_HOST_OS)
import Foreign.ForeignPtr ( newForeignPtr )
#endif
#ifdef GENERICS
import GHC.Generics ( Generic )
#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable, Generic
#else
#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable
#endif
#if MIN_VERSION_base(4,3,0)
import Control.Exception ( mask, mask_ )
#else
import Control.Exception ( blocked, block, unblock )
import Data.Function ( id )
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 a -> IO a
mask_ = block
#endif
data Ctx = Ctx
{
#ifdef HAS_EVENT_MANAGER
ctxGetWait :: !(Maybe Wait),
#endif
getCtxFrgnPtr :: !(ForeignPtr C'libusb_context)
} deriving Typeable
instance Eq Ctx where (==) = (==) `on` 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
handleUSBException $ c'libusb_init ctxPtrPtr
peek ctxPtrPtr
newCtxNoEventManager :: (ForeignPtr C'libusb_context -> Ctx) -> IO Ctx
newCtxNoEventManager ctx = mask_ $ do
ctxPtr <- libusb_init
#ifdef mingw32_HOST_OS
ctx <$> FC.newForeignPtr ctxPtr
(c'libusb_exit ctxPtr)
#else
ctx <$> newForeignPtr p'libusb_exit ctxPtr
#endif
#ifndef HAS_EVENT_MANAGER
newCtx :: IO Ctx
newCtx = newCtxNoEventManager Ctx
#else
type Wait = Timeout -> Lock -> Ptr C'libusb_transfer -> IO ()
newCtx :: IO Ctx
newCtx = newCtx' $ \e -> hPutStrLn stderr $
thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e
newCtx' :: (USBException -> IO ()) -> IO Ctx
newCtx' handleError = do
mbEvtMgr <- getSystemEventManager
case mbEvtMgr of
Nothing -> newCtxNoEventManager $ Ctx Nothing
Just evtMgr -> mask_ $ do
ctxPtr <- libusb_init
let handleEvents = do
err <- withTimeval noTimeout $
c'libusb_handle_events_timeout ctxPtr
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)
(Fd fd) (Poll.toEvent 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)
free pollFdPtrLst
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 ->
let (Just fdKey, newFdKeyMap) =
updateLookupWithKey (\_ _ -> Nothing)
(fromIntegral fd)
fdKeyMap
in (newFdKeyMap, (newFdKeyMap, fdKey))
newFdKeyMap `seq` unregisterFd evtMgr fdKey
c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr
r <- c'libusb_pollfds_handle_timeouts ctxPtr
#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
| otherwise = do
tk <- registerTimeout timerMgr (timeout * 1000) handleEvents
acquire lock
`onException`
(uninterruptibleMask_ $ do
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
acquire lock)
fmap (Ctx (Just wait)) $ FC.newForeignPtr ctxPtr $ do
c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr
freeHaskellFunPtr aFP
freeHaskellFunPtr rFP
readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) . elems
c'libusb_exit ctxPtr
getWait :: DeviceHandle -> Maybe Wait
getWait = ctxGetWait . getCtx . getDevice
#endif
setDebug :: Ctx -> Verbosity -> IO ()
setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr ->
c'libusb_set_debug ctxPtr $ genFromEnum verbosity
data Verbosity =
PrintNothing
| PrintErrors
| PrintWarnings
| PrintInfo
deriving (Enum, Ord, COMMON_INSTANCES)
data Device = Device
{ getCtx :: !Ctx
, getDevFrgnPtr :: !(ForeignPtr C'libusb_device)
} deriving Typeable
instance Eq Device where (==) = (==) `on` getDevFrgnPtr
instance Show Device where
show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d)
withDevicePtr :: Device -> (Ptr C'libusb_device -> IO a) -> IO a
withDevicePtr (Device ctx devFP ) f = do
x <- withForeignPtr devFP f
touchForeignPtr $ getCtxFrgnPtr ctx
return x
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
let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0
devs <- restore (mapPeekArray mkDev numDevs devPtrArray)
`onException` freeDevPtrArray
freeDevPtrArray
return devs
where
mkDev :: Ptr C'libusb_device -> IO Device
mkDev devPtr = Device ctx <$>
#ifdef mingw32_HOST_OS
FC.newForeignPtr devPtr
(c'libusb_unref_device devPtr)
#else
newForeignPtr p'libusb_unref_device devPtr
#endif
busNumber :: Device -> Word8
busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number
deviceAddress :: Device -> Word8
deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address
data DeviceHandle = DeviceHandle
{ getDevice :: !Device
, getDevHndlPtr :: !(Ptr C'libusb_device_handle)
} deriving Typeable
instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr
instance Show DeviceHandle where
show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}"
withDevHndlPtr :: DeviceHandle -> (Ptr C'libusb_device_handle -> IO a) -> IO a
withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do
x <- f devHndlPtr
touchForeignPtr devFrgnPtr
touchForeignPtr $ getCtxFrgnPtr ctx
return x
openDevice :: Device -> IO DeviceHandle
openDevice dev = withDevicePtr dev $ \devPtr ->
alloca $ \devHndlPtrPtr -> do
handleUSBException $ c'libusb_open devPtr devHndlPtrPtr
DeviceHandle dev <$> peek devHndlPtrPtr
closeDevice :: DeviceHandle -> IO ()
closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close
withDeviceHandle :: Device -> (DeviceHandle -> IO a) -> IO a
withDeviceHandle dev = bracket (openDevice dev) closeDevice
type ConfigValue = Word8
getConfig :: DeviceHandle -> IO (Maybe ConfigValue)
getConfig devHndl =
alloca $ \configPtr -> do
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr
unmarshal <$> peek configPtr
where
unmarshal 0 = Nothing
unmarshal n = Just $ fromIntegral n
setConfig :: DeviceHandle -> Maybe ConfigValue -> IO ()
setConfig devHndl config =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $ c'libusb_set_configuration devHndlPtr $
marshal config
where
marshal = maybe (1) fromIntegral
type InterfaceNumber = Word8
claimInterface :: DeviceHandle -> InterfaceNumber -> IO ()
claimInterface devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $ c'libusb_claim_interface devHndlPtr
(fromIntegral ifNum)
releaseInterface :: DeviceHandle -> InterfaceNumber -> IO ()
releaseInterface devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $ c'libusb_release_interface devHndlPtr
(fromIntegral ifNum)
withClaimedInterface :: DeviceHandle -> InterfaceNumber -> IO a -> IO a
withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum)
(releaseInterface devHndl ifNum)
type InterfaceAltSetting = Word8
setInterfaceAltSetting :: DeviceHandle
-> InterfaceNumber
-> InterfaceAltSetting
-> IO ()
setInterfaceAltSetting devHndl ifNum alternateSetting =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $
c'libusb_set_interface_alt_setting devHndlPtr
(fromIntegral ifNum)
(fromIntegral alternateSetting)
clearHalt :: DeviceHandle -> EndpointAddress -> IO ()
clearHalt devHndl endpointAddr =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $
c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr)
resetDevice :: DeviceHandle -> IO ()
resetDevice devHndl = withDevHndlPtr devHndl $
handleUSBException . c'libusb_reset_device
kernelDriverActive :: DeviceHandle -> InterfaceNumber -> IO Bool
kernelDriverActive devHndl 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
detachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO ()
detachKernelDriver devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr
(fromIntegral ifNum)
attachKernelDriver :: DeviceHandle -> InterfaceNumber -> IO ()
attachKernelDriver devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr ->
handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr
(fromIntegral ifNum)
withDetachedKernelDriver :: DeviceHandle -> InterfaceNumber -> IO a -> IO a
withDetachedKernelDriver devHndl ifNum action =
ifM (kernelDriverActive devHndl ifNum)
(bracket_ (detachKernelDriver devHndl ifNum)
(attachKernelDriver devHndl ifNum)
action)
action
data DeviceDesc = DeviceDesc
{
deviceUSBSpecReleaseNumber :: !ReleaseNumber
, deviceClass :: !Word8
, deviceSubClass :: !Word8
, deviceProtocol :: !Word8
, deviceMaxPacketSize0 :: !Word8
, deviceVendorId :: !VendorId
, deviceProductId :: !ProductId
, deviceReleaseNumber :: !ReleaseNumber
, deviceManufacturerStrIx :: !(Maybe StrIx)
, deviceProductStrIx :: !(Maybe StrIx)
, deviceSerialNumberStrIx :: !(Maybe StrIx)
, deviceNumConfigs :: !Word8
} deriving (COMMON_INSTANCES)
type ReleaseNumber = (Int, Int, Int, Int)
type VendorId = Word16
type ProductId = Word16
data ConfigDesc = ConfigDesc
{
configValue :: !ConfigValue
, configStrIx :: !(Maybe StrIx)
, configAttribs :: !ConfigAttribs
, configMaxPower :: !Word8
, configInterfaces :: !(Vector Interface)
, configExtra :: !B.ByteString
} deriving (COMMON_INSTANCES)
type ConfigAttribs = DeviceStatus
data DeviceStatus = DeviceStatus
{ remoteWakeup :: !Bool
, selfPowered :: !Bool
} deriving (COMMON_INSTANCES)
type Interface = Vector InterfaceDesc
data InterfaceDesc = InterfaceDesc
{
interfaceNumber :: !InterfaceNumber
, interfaceAltSetting :: !InterfaceAltSetting
, interfaceClass :: !Word8
, interfaceSubClass :: !Word8
, interfaceProtocol :: !Word8
, interfaceStrIx :: !(Maybe StrIx)
, interfaceEndpoints :: !(Vector EndpointDesc)
, interfaceExtra :: !B.ByteString
} deriving (COMMON_INSTANCES)
data EndpointDesc = EndpointDesc
{
endpointAddress :: !EndpointAddress
, endpointAttribs :: !EndpointAttribs
, endpointMaxPacketSize :: !MaxPacketSize
, endpointInterval :: !Word8
, endpointRefresh :: !Word8
, endpointSynchAddress :: !Word8
, endpointExtra :: !B.ByteString
} deriving (COMMON_INSTANCES)
data EndpointAddress = EndpointAddress
{ endpointNumber :: !Int
, transferDirection :: !TransferDirection
} deriving (COMMON_INSTANCES)
data TransferDirection = Out
| In
deriving (COMMON_INSTANCES)
type EndpointAttribs = TransferType
data TransferType =
Control
| Isochronous !Synchronization !Usage
| Bulk
| Interrupt
deriving (COMMON_INSTANCES)
data Synchronization =
NoSynchronization
| Asynchronous
| Adaptive
| Synchronous
deriving (Enum, COMMON_INSTANCES)
data Usage = Data
| Feedback
| Implicit
deriving (Enum, COMMON_INSTANCES)
data MaxPacketSize = MaxPacketSize
{ maxPacketSize :: !Size
, transactionOpportunities :: !TransactionOpportunities
} deriving (COMMON_INSTANCES)
data TransactionOpportunities = Zero
| One
| Two
deriving (Enum, Ord, COMMON_INSTANCES)
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
getDeviceDesc :: Device -> IO DeviceDesc
getDeviceDesc dev =
withDevicePtr dev $ \devPtr ->
convertDeviceDesc <$>
allocaPeek (handleUSBException . c'libusb_get_device_descriptor devPtr)
convertDeviceDesc :: C'libusb_device_descriptor -> DeviceDesc
convertDeviceDesc d = DeviceDesc
{ deviceUSBSpecReleaseNumber = unmarshalReleaseNumber $
c'libusb_device_descriptor'bcdUSB d
, deviceClass = c'libusb_device_descriptor'bDeviceClass d
, deviceSubClass = c'libusb_device_descriptor'bDeviceSubClass d
, deviceProtocol = c'libusb_device_descriptor'bDeviceProtocol d
, deviceMaxPacketSize0 = c'libusb_device_descriptor'bMaxPacketSize0 d
, deviceVendorId = c'libusb_device_descriptor'idVendor d
, deviceProductId = c'libusb_device_descriptor'idProduct d
, deviceReleaseNumber = unmarshalReleaseNumber $
c'libusb_device_descriptor'bcdDevice 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 = c'libusb_device_descriptor'bNumConfigurations d
}
unmarshalReleaseNumber :: Word16 -> ReleaseNumber
unmarshalReleaseNumber abcd = (a, b, c, d)
where
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
unmarshalStrIx :: Word8 -> Maybe StrIx
unmarshalStrIx 0 = Nothing
unmarshalStrIx strIx = Just strIx
getConfigDesc :: Device -> Word8 -> IO ConfigDesc
getConfigDesc dev ix = withDevicePtr dev $ \devPtr ->
bracket (allocaPeek $ handleUSBException
. c'libusb_get_config_descriptor devPtr ix)
c'libusb_free_config_descriptor
((convertConfigDesc =<<) . peek)
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)
extra <- getExtra (c'libusb_config_descriptor'extra c)
(c'libusb_config_descriptor'extra_length c)
return ConfigDesc
{ configValue = c'libusb_config_descriptor'bConfigurationValue c
, configStrIx = unmarshalStrIx $
c'libusb_config_descriptor'iConfiguration c
, configAttribs = unmarshalConfigAttribs $
c'libusb_config_descriptor'bmAttributes c
, configMaxPower = c'libusb_config_descriptor'MaxPower c
, configInterfaces = interfaces
, configExtra = extra
}
unmarshalConfigAttribs :: Word8 -> ConfigAttribs
unmarshalConfigAttribs a = DeviceStatus { remoteWakeup = testBit a 5
, selfPowered = testBit a 6
}
getExtra :: Ptr CUChar -> CInt -> IO B.ByteString
getExtra extra extraLength = B.packCStringLen ( castPtr extra
, fromIntegral extraLength
)
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 i = do
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)
return InterfaceDesc
{ interfaceNumber = c'libusb_interface_descriptor'bInterfaceNumber i
, interfaceAltSetting = c'libusb_interface_descriptor'bAlternateSetting i
, interfaceClass = c'libusb_interface_descriptor'bInterfaceClass i
, interfaceSubClass = c'libusb_interface_descriptor'bInterfaceSubClass i
, interfaceStrIx = unmarshalStrIx $
c'libusb_interface_descriptor'iInterface i
, interfaceProtocol = c'libusb_interface_descriptor'bInterfaceProtocol i
, interfaceEndpoints = endpoints
, interfaceExtra = extra
}
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)
return EndpointDesc
{ endpointAddress = unmarshalEndpointAddress $
c'libusb_endpoint_descriptor'bEndpointAddress e
, endpointAttribs = unmarshalEndpointAttribs $
c'libusb_endpoint_descriptor'bmAttributes e
, endpointMaxPacketSize = unmarshalMaxPacketSize $
c'libusb_endpoint_descriptor'wMaxPacketSize e
, endpointInterval = c'libusb_endpoint_descriptor'bInterval e
, endpointRefresh = c'libusb_endpoint_descriptor'bRefresh e
, endpointSynchAddress = c'libusb_endpoint_descriptor'bSynchAddress e
, endpointExtra = extra
}
unmarshalEndpointAddress :: Word8 -> EndpointAddress
unmarshalEndpointAddress a =
EndpointAddress { endpointNumber = fromIntegral $ bits 0 3 a
, transferDirection = if testBit a 7 then In else Out
}
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
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!"
unmarshalMaxPacketSize :: Word16 -> MaxPacketSize
unmarshalMaxPacketSize m =
MaxPacketSize
{ maxPacketSize = fromIntegral $ bits 0 10 m
, transactionOpportunities = genToEnum $ bits 11 12 m
}
strDescHeaderSize :: Size
strDescHeaderSize = 2
charSize :: Size
charSize = 2
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
where
maxSize = 255
write = putStrDesc devHndl 0 0 maxSize
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)
when (actualSize < strDescHeaderSize) $
throwIO $ IOException "Incomplete header"
reportedSize <- peek dataPtr
when (reportedSize > fromIntegral actualSize) $
throwIO $ IOException "Not enough space to hold data"
descType <- peekElemOff dataPtr 1
when (descType /= c'LIBUSB_DT_STRING) $
throwIO $ IOException "Invalid header"
return $ fromIntegral reportedSize
type LangId = (PrimaryLangId, SubLangId)
type PrimaryLangId = Word16
type SubLangId = Word16
unmarshalLangId :: Word16 -> LangId
unmarshalLangId = bits 0 9 &&& bits 10 15
marshalLangId :: LangId -> Word16
marshalLangId (p, s) = p .|. s `shiftL`10
type StrIx = Word8
getStrDesc :: DeviceHandle
-> StrIx
-> LangId
-> Int
-> 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
getStrDescFirstLang :: DeviceHandle
-> StrIx
-> Int
-> IO Text
getStrDescFirstLang devHndl strIx nrOfChars = do
langIds <- getLanguages devHndl
case uncons langIds of
Nothing -> throwIO $ IOException "Zero languages"
Just (langId, _) -> getStrDesc devHndl strIx langId nrOfChars
type ReadAction = Size -> Timeout -> IO (B.ByteString, Status)
type ReadExactAction = Size -> Timeout -> IO B.ByteString
type WriteAction = B.ByteString -> Timeout -> IO (Size, Status)
type WriteExactAction = B.ByteString -> Timeout -> IO ()
type Size = Int
type Timeout = Int
noTimeout :: Timeout
noTimeout = 0
data Status = Completed
| TimedOut
deriving (COMMON_INSTANCES)
type ControlAction a = RequestType -> Recipient -> Request -> Value -> Index -> a
data RequestType = Standard
| Class
| Vendor
deriving (Enum, COMMON_INSTANCES)
data Recipient = ToDevice
| ToInterface
| ToEndpoint
| ToOther
deriving (Enum, COMMON_INSTANCES)
type Request = Word8
type Value = Word16
type Index = Word16
marshalRequestType :: RequestType -> Recipient -> Word8
marshalRequestType t r = genFromEnum t `shiftL` 5 .|. genFromEnum r
control :: DeviceHandle -> ControlAction (Timeout -> IO ())
control devHndl reqType reqRecipient request value index timeout = do
(_, status) <- doControl
when (status == TimedOut) $ throwIO TimeoutException
where
doControl
#ifdef HAS_EVENT_MANAGER
| Just wait <- getWait devHndl =
allocaBytes controlSetupSize $ \bufferPtr -> do
poke bufferPtr $ C'libusb_control_setup requestType
request value index
0
transferAsync wait
c'LIBUSB_TRANSFER_TYPE_CONTROL
devHndl
controlEndpoint
timeout
(bufferPtr, controlSetupSize)
#endif
| otherwise = controlTransferSync devHndl
requestType
request value index
timeout
(nullPtr, 0)
requestType = marshalRequestType reqType reqRecipient
readControl :: DeviceHandle -> ControlAction ReadAction
readControl devHndl reqType reqRecipient request value index size timeout
#ifdef HAS_EVENT_MANAGER
| Just wait <- getWait devHndl = do
let totalSize = controlSetupSize + size
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
return (bs, status)
#endif
| otherwise = createAndTrimNoOffset size $ \dataPtr ->
controlTransferSync devHndl
requestType
request value index
timeout
(dataPtr, size)
where
requestType = marshalRequestType reqType reqRecipient `setBit` 7
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
then throwIO incompleteReadException
else return bs
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
let totalSize = controlSetupSize + size
allocaBytes totalSize $ \bufferPtr -> do
poke bufferPtr $ C'libusb_control_setup requestType
request value index
(fromIntegral size)
copyArray (bufferPtr `plusPtr` controlSetupSize) dataPtr size
transferAsync wait
c'LIBUSB_TRANSFER_TYPE_CONTROL
devHndl controlEndpoint
timeout
(bufferPtr, totalSize)
#endif
| otherwise = BU.unsafeUseAsCStringLen input $
controlTransferSync devHndl
requestType
request value index
timeout
where
requestType = marshalRequestType reqType reqRecipient
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
#ifdef HAS_EVENT_MANAGER
controlSetupSize :: Size
controlSetupSize = sizeOf (undefined :: C'libusb_control_setup)
controlEndpoint :: CUChar
controlEndpoint = 0
#endif
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
then throwIO $ convertUSBException err
else return ( fromIntegral err
, if timedOut then TimedOut else Completed
)
readBulk :: DeviceHandle -> EndpointAddress -> ReadAction
readBulk devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait <- getWait devHndl =
readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl
#endif
| otherwise = readTransferSync c'libusb_bulk_transfer devHndl
writeBulk :: DeviceHandle -> EndpointAddress -> WriteAction
writeBulk devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait <- getWait devHndl =
writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_BULK devHndl
#endif
| otherwise = writeTransferSync c'libusb_bulk_transfer devHndl
readInterrupt :: DeviceHandle -> EndpointAddress -> ReadAction
readInterrupt devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait <- getWait devHndl =
readTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl
#endif
| otherwise = readTransferSync c'libusb_interrupt_transfer devHndl
writeInterrupt :: DeviceHandle -> EndpointAddress -> WriteAction
writeInterrupt devHndl
#ifdef HAS_EVENT_MANAGER
| Just wait <- getWait devHndl =
writeTransferAsync wait c'LIBUSB_TRANSFER_TYPE_INTERRUPT devHndl
#endif
| otherwise = writeTransferSync c'libusb_interrupt_transfer devHndl
type C'TransferFunc = Ptr C'libusb_device_handle
-> CUChar
-> Ptr CUChar
-> CInt
-> Ptr CInt
-> CUInt
-> IO CInt
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 ->
BU.unsafeUseAsCStringLen input $
transferSync c'transfer
devHndl endpointAddr
timeout
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
then throwIO $ convertUSBException err
else do transferred <- peek transferredPtr
return ( fromIntegral transferred
, if timedOut then TimedOut else Completed
)
#ifdef HAS_EVENT_MANAGER
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 ->
BU.unsafeUseAsCStringLen input $
transferAsync wait
transType
devHndl (marshalEndpointAddress endpointAddr)
timeout
type C'TransferType = CUChar
transferAsync :: Wait
-> C'TransferType
-> DeviceHandle -> CUChar
-> Timeout
-> (Ptr byte, Size)
-> IO (Size, Status)
transferAsync wait transType devHndl endpoint timeout bytes =
withTerminatedTransfer wait
transType
VG.empty
devHndl endpoint
timeout
bytes
(continue Completed)
(continue TimedOut)
where
continue status transPtr = do
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
-> Timeout
-> (Ptr byte, Size)
-> (Ptr C'libusb_transfer -> IO a)
-> (Ptr C'libusb_transfer -> IO a)
-> IO a
withTerminatedTransfer wait
transType
isos
devHndl endpoint
timeout
(bufferPtr, size)
onCompletion
onTimeout =
withDevHndlPtr devHndl $ \devHndlPtr -> do
let nrOfIsos = VG.length isos
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
poke (p'libusb_transfer'timeout transPtr) (fromIntegral timeout)
poke (p'libusb_transfer'length transPtr) (fromIntegral size)
poke (p'libusb_transfer'callback transPtr) cbPtr
poke (p'libusb_transfer'buffer transPtr) (castPtr bufferPtr)
poke (p'libusb_transfer'num_iso_packets transPtr) (fromIntegral nrOfIsos)
pokeVector (p'libusb_transfer'iso_packet_desc transPtr) isos
mask_ $ do
handleUSBException $ c'libusb_submit_transfer transPtr
wait timeout lock 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 == 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 ->
moduleError "transfer status can't be Cancelled!"
| otherwise -> moduleError $ "Unknown transfer status: " ++
show ts ++ "!"
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)
return transPtr
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
newtype Lock = Lock (MVar ()) deriving Eq
newLock :: IO Lock
newLock = Lock <$> newEmptyMVar
acquire :: Lock -> IO ()
acquire (Lock mv) = takeMVar mv
release :: Lock -> IO ()
release (Lock mv) = putMVar mv ()
readIsochronous :: DeviceHandle
-> EndpointAddress
-> Unboxed.Vector Size
-> Timeout
-> IO (Vector B.ByteString)
readIsochronous devHndl endpointAddr sizes timeout
| Just wait <- getWait devHndl = do
let totalSize = VG.sum sizes
nrOfIsos = VG.length sizes
isos = VG.map initIsoPacketDesc $ VG.convert sizes
allocaBytes totalSize $ \bufferPtr ->
withTerminatedTransfer
wait
c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS
isos
devHndl
(marshalEndpointAddress endpointAddr)
timeout
(bufferPtr, totalSize)
(getPackets nrOfIsos bufferPtr)
(\_ -> throwIO TimeoutException)
| otherwise = needThreadedRTSError "readIsochronous"
getPackets :: Int -> Ptr Word8 -> Ptr C'libusb_transfer -> IO (Vector B.ByteString)
getPackets nrOfIsos bufferPtr transPtr = do
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)
let transferred = fromIntegral a
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
go 0 bufferPtr
writeIsochronous :: DeviceHandle
-> EndpointAddress
-> Vector B.ByteString
-> Timeout
-> IO (Unboxed.Vector Size)
writeIsochronous devHndl endpointAddr isoPackets timeout
| 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
copyIsos (castPtr bufferPtr) isoPackets
withTerminatedTransfer
wait
c'LIBUSB_TRANSFER_TYPE_ISOCHRONOUS
isos
devHndl
(marshalEndpointAddress endpointAddr)
timeout
(bufferPtr, totalSize)
(getSizes nrOfIsos)
(\_ -> throwIO TimeoutException)
| otherwise = needThreadedRTSError "writeIsochronous"
getSizes :: Int -> Ptr C'libusb_transfer -> IO (Unboxed.Vector Size)
getSizes nrOfIsos transPtr = do
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)
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
copyArray bufferPtr ptr len
return $ bufferPtr `plusPtr` len
initIsoPacketDesc :: Size -> C'libusb_iso_packet_descriptor
initIsoPacketDesc size =
C'libusb_iso_packet_descriptor
{ c'libusb_iso_packet_descriptor'length = fromIntegral size
, c'libusb_iso_packet_descriptor'actual_length = 0
, c'libusb_iso_packet_descriptor'status = 0
}
#endif
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
handleUSBException :: IO CInt -> IO ()
handleUSBException action = do err <- action
when (err /= c'LIBUSB_SUCCESS)
(throwIO $ convertUSBException err)
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
convertUSBException :: (Num a, Eq a, Show a) => a -> USBException
convertUSBException err = fromMaybe unknownLibUsbError $
lookup err libusb_error_to_USBException
where
unknownLibUsbError =
moduleError $ "Unknown libusb error code: " ++ show err ++ "!"
libusb_error_to_USBException :: Num a => [(a, USBException)]
libusb_error_to_USBException =
[ (c'LIBUSB_ERROR_IO, ioException)
, (c'LIBUSB_ERROR_INVALID_PARAM, InvalidParamException)
, (c'LIBUSB_ERROR_ACCESS, AccessException)
, (c'LIBUSB_ERROR_NO_DEVICE, NoDeviceException)
, (c'LIBUSB_ERROR_NOT_FOUND, NotFoundException)
, (c'LIBUSB_ERROR_BUSY, BusyException)
, (c'LIBUSB_ERROR_TIMEOUT, TimeoutException)
, (c'LIBUSB_ERROR_OVERFLOW, OverflowException)
, (c'LIBUSB_ERROR_PIPE, PipeException)
, (c'LIBUSB_ERROR_INTERRUPTED, InterruptedException)
, (c'LIBUSB_ERROR_NO_MEM, NoMemException)
, (c'LIBUSB_ERROR_NOT_SUPPORTED, NotSupportedException)
, (c'LIBUSB_ERROR_OTHER, OtherException)
]
data USBException =
IOException String
| InvalidParamException
| AccessException
| NoDeviceException
| NotFoundException
| BusyException
| TimeoutException
| OverflowException
| PipeException
| InterruptedException
| NoMemException
| NotSupportedException
| OtherException
deriving (COMMON_INSTANCES)
instance Exception USBException
ioException :: USBException
ioException = IOException ""
incompleteReadException :: USBException
incompleteReadException = incompleteException "read"
incompleteWriteException :: USBException
incompleteWriteException = incompleteException "written"
incompleteException :: String -> USBException
incompleteException rw = IOException $
"The number of bytes " ++ rw ++ " doesn't equal the requested number!"
moduleError :: String -> error
moduleError msg = error $ thisModule ++ ": " ++ msg
thisModule :: String
thisModule = "System.USB.Base"
needThreadedRTSError :: String -> error
needThreadedRTSError msg = moduleError $ msg ++
" is only supported when using the threaded runtime. " ++
"Please build your program with -threaded."