diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,5 +1,10 @@ -1.3 +1.3.0.1 + * Support GHC-7.10 + + +1.3.0.0 (Sun Dec 14 23:11:35 UTC 2014) + * Add hotplug support. * Add the System.USB.IO.Transfers module which separates the @@ -16,6 +21,7 @@ the hasCapability & libusbVersion functions. * Extended the Verbosity type with the PrintDebug constructor. + 1.2.0.1 (Fri May 23 21:50:20 UTC 2014) diff --git a/System/USB.hs b/System/USB.hs --- a/System/USB.hs +++ b/System/USB.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} #endif -------------------------------------------------------------------------------- diff --git a/System/USB/Base.hs b/System/USB/Base.hs --- a/System/USB/Base.hs +++ b/System/USB/Base.hs @@ -2,6 +2,7 @@ , NoImplicitPrelude , DeriveDataTypeable , BangPatterns + , ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 704 @@ -44,14 +45,18 @@ import Data.Typeable ( Typeable ) import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe ) import Data.Monoid ( Monoid, mempty, mappend ) -import Data.List ( map, lookup, (++), null ) +import Data.List 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 Data.Version ( Version(Version), versionBranch, versionTags ) +import Data.Version ( Version(..) +#if MIN_VERSION_base(4,8,0) + , makeVersion +#endif + ) import System.IO ( IO ) import System.IO.Unsafe ( unsafePerformIO ) import Text.Show ( Show, show ) @@ -91,9 +96,11 @@ -- from usb (this package): import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray - , allocaPeek, ifM, uncons + , allocaPeek, ifM ) +import qualified Utils as V ( uncons ) + -------------------------------------------------------------------------------- #ifdef HAS_EVENT_MANAGER @@ -104,14 +111,28 @@ import Foreign.Marshal.Array ( peekArray0, copyArray, advancePtr ) import Foreign.Storable ( Storable, sizeOf, poke, pokeElemOff ) import Foreign.Ptr ( nullFunPtr ) +#if MIN_VERSION_base(4,4,0) import Foreign.ForeignPtr.Unsafe ( unsafeForeignPtrToPtr ) +#else +import Foreign.ForeignPtr ( unsafeForeignPtrToPtr ) +#endif import Control.Monad ( mapM_, forM_, unless ) import Data.IORef ( IORef, newIORef, atomicModifyIORef, readIORef, writeIORef ) import System.Posix.Types ( Fd(Fd) ) import Control.Exception ( uninterruptibleMask_ ) -import Control.Concurrent.MVar ( newMVar, withMVar, withMVarMasked ) +import Control.Concurrent.MVar + ( newMVar + , withMVar +#if MIN_VERSION_base(4,7,0) + , withMVarMasked +#endif + ) import System.IO ( hPutStrLn, stderr ) +#if MIN_VERSION_base(4,8,0) +import Unsafe.Coerce ( unsafeCoerce ) +#endif + #if MIN_VERSION_base(4,4,0) import GHC.Event #else @@ -148,7 +169,7 @@ #include "EventConfig.h" #define HAVE_ONE_SHOT \ - (__GLASGOW_HASKELL__ >= 708 && \ + (__GLASGOW_HASKELL__ >= 708 && !MIN_VERSION_base(4,8,1) && \ !(defined(darwin_HOST_OS) || defined(ios_HOST_OS)) && \ (defined(HAVE_EPOLL) || defined(HAVE_KQUEUE))) @@ -293,10 +314,17 @@ wait <- determineWait - fmap (Ctx (Just wait)) $ FC.newForeignPtr ctxPtr $ do - finalizeRegisterPollFds - free zeroTimevalPtr - c'libusb_exit ctxPtr + let finalize :: IO () + finalize = do + finalizeRegisterPollFds + free zeroTimevalPtr + c'libusb_exit ctxPtr + + ctxFrgnPtr <- FC.newForeignPtr ctxPtr finalize + + return Ctx{ ctxGetWait = Just wait + , getCtxFrgnPtr = ctxFrgnPtr + } where registerPollFds :: IO (IO ()) registerPollFds = do @@ -310,7 +338,7 @@ unregisterAllPollFds fdKeyMapRef where -- Register initial libusb file descriptors with the event manager - -- and return the initial Fd to FdKey association: + -- and store the Fd to FdKey associations: registerInitialPollFds :: IORef (IntMap FdKey) -> IO () registerInitialPollFds fdKeyMapRef = do -- Get the initial file descriptors: @@ -367,6 +395,18 @@ registerAndInsert :: IO () registerAndInsert = do fdKey <- registerFd evtMgr callback (Fd fd) (Poll.toEvent evt) + -- In base-4.8 registerFd gains an additonal argument of type + -- Lifetime. However, because of an oversight, base-4.8 doesn't export + -- the constructors: OneShot | MultiShot. We therefor use the hack of + -- unsafely coercing a Bool to a Lifetime. +#if MIN_VERSION_base(4,8,1) + MultiShot +#elif MIN_VERSION_base(4,8,0) + -- We would like to use MultiShot (unsafeCoerce True) + -- registrations. However, base-4.8 has a bug in the MultiShot + -- implementation which means we have to fall back to OneShot. + (unsafeCoerce False) +#endif -- Associate the fd with the fdKey: newFdKeyMap <- atomicModifyIORef fdKeyMapRef $ \fdKeyMap -> @@ -377,11 +417,12 @@ callback :: IOCallback callback _fdKey _ev = do #if HAVE_ONE_SHOT - -- In GHC >= 7.8 the system event manager might have - -- one-shot semantics. One-shot semantics means that when an - -- event occurs on a registered fd the fd is unregistered - -- before the callback is called. This usb library only - -- works if registered fds stay registered until they are + -- In GHC >= 7.8 && <= 7.10.1 the system event manager might + -- have one-shot semantics. One-shot semantics means that + -- when an event occurs on a registered fd the fd is + -- unregistered before the callback is called. This usb + -- library only works with multi-shot semantics, + -- i.e. registered fds stay registered until they are -- explicitly unregistered. To work around the one-shot -- semantics we register the fd again when the callback -- fires: @@ -528,11 +569,19 @@ -- | Convert a 'LibusbVersion' to a 'Version' for easy comparison. toVersion :: LibusbVersion -> Version -toVersion (LibusbVersion maj min mic nan rcTag) = - Version { versionBranch = map fromIntegral [maj, min, mic, nan] - , versionTags = if null rcTag then [] else [rcTag] +toVersion (LibusbVersion maj min mic nan _rcTag) = +#if MIN_VERSION_base(4,8,0) + makeVersion branch +#else + Version { versionBranch = branch + , versionTags = if null _rcTag then [] else [_rcTag] } +#endif + where + branch :: [Int] + branch = map fromIntegral [maj, min, mic, nan] + -------------------------------------------------------------------------------- -- | Capabilities supported by an instance of @libusb@ on the current running @@ -708,10 +757,11 @@ -------------------------------------------------------------------------------- --- | Hotplug callback function type. +-- | Hotplug callback function type used in 'registerHotplugCallback'. -- --- @libusb@ will call this function later, when a matching event had happened on --- a matching device. +-- @libusb@ will call this function, once registered using +-- 'registerHotplugCallback', when a matching event has happened on a matching +-- device. -- -- This callback may be called by an internal event thread and as such it is -- recommended the callback do minimal processing before returning. In fact, it @@ -784,8 +834,8 @@ -- Register a hotplug callback function with the context. The callback will fire -- when a matching event occurs on a matching device. The callback is armed -- until either it is deregistered with 'deregisterHotplugCallback' or the --- supplied callback returns 'True' to indicate it is finished processing --- events. +-- supplied callback returns 'DeregisterThisCallback' to indicate it is finished +-- processing events. -- -- If the 'enumerate' flag is passed the callback will be called with a -- 'deviceArrived' for all devices already plugged into the machine. Note that @@ -793,7 +843,7 @@ -- calling hotplug callbacks from @libusb_handle_events()@, so it is possible -- for a device to already be present on, or removed from, its internal device -- list, while the hotplug callbacks still need to be dispatched. This means --- that when using the 'enumerate` flag, your callback may be called twice for +-- that when using the 'enumerate' flag, your callback may be called twice for -- the arrival of the same device, once from 'registerHotplugCallback' and once -- from @libusb_handle_events()@; and\/or your callback may be called for the -- removal of a device for which an arrived call was never made. @@ -813,7 +863,7 @@ mbProductId mbDevClass hotplugCallback = do - mbCbFnPtrMv <- newEmptyMVar + (mbCbFnPtrMv :: MVar (Maybe C'libusb_hotplug_callback_fn)) <- newEmptyMVar let cb :: Ptr C'libusb_context -> Ptr C'libusb_device @@ -833,7 +883,7 @@ return 1 withCtxPtr ctx $ \ctxPtr -> - alloca $ \hotplugCallbackHandlePtr -> + alloca $ \(hotplugCallbackHandlePtr :: Ptr C'libusb_hotplug_callback_handle) -> mask_ $ do -- We mask to ensure the freeing of cbFnPtr. cbFnPtr <- mk'libusb_hotplug_callback_fn cb putMVar mbCbFnPtrMv $ Just cbFnPtr @@ -1961,7 +2011,7 @@ -> IO Text getStrDescFirstLang devHndl strIx nrOfChars = do langIds <- getLanguages devHndl - case uncons langIds of + case V.uncons langIds of Nothing -> throwIO $ IOException "Zero languages" Just (langId, _) -> getStrDesc devHndl strIx langId nrOfChars @@ -2986,7 +3036,7 @@ bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) bs <- BI.create len $ \ptr -> - BI.memcpy ptr (bufferPtr `plusPtr` controlSetupSize) len + BI.memcpy ptr (bufferPtr `plusPtr` controlSetupSize) (fromIntegral len) return (bs, status) @@ -3203,7 +3253,7 @@ len <- fromIntegral <$> peek (p'libusb_transfer'actual_length transPtr) bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - bs <- BI.create len $ \ptr -> BI.memcpy ptr bufferPtr len + bs <- BI.create len $ \ptr -> BI.memcpy ptr bufferPtr (fromIntegral len) return (bs, status) @@ -3373,7 +3423,7 @@ withTransPtr transfer $ \transPtr -> do len <- fromIntegral <$> peek (p'libusb_transfer'length transPtr) bufferPtr <- castPtr <$> peek (p'libusb_transfer'buffer transPtr) - BI.create len $ \ptr -> BI.memcpy ptr bufferPtr len + BI.create len $ \ptr -> BI.memcpy ptr bufferPtr (fromIntegral len) -- | Retrieve the timeout of a bulk or interrupt write transfer. getWriteTransferTimeout :: WriteTransfer -> IO Timeout 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 @@ -58,7 +58,6 @@ #if __GLASGOW_HASKELL__ < 700 import Prelude ( fromInteger ) -import Data.Eq ( (==) ) #endif -- from bytestring: diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -18,7 +18,7 @@ ) #if __GLASGOW_HASKELL__ < 700 -import Prelude ( fromInteger ) +import Prelude ( fromInteger, fail ) #endif import Control.Monad ( Monad, return, (>>=), (>>) ) diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -1,14 +1,2 @@ -{ cabal, bindingsLibusb, text, vector }: - -cabal.mkDerivation (self: { - pname = "usb"; - version = "1.3.0.0"; - src = ./.; - buildDepends = [ bindingsLibusb text vector ]; - meta = { - homepage = "http://basvandijk.github.com/usb"; - description = "Communicate with USB devices"; - license = self.stdenv.lib.licenses.bsd3; - platforms = self.ghc.meta.platforms; - }; -}) +let pkgs = import {}; +in pkgs.haskellPackages.callPackage ./usb.nix {} diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -2,7 +2,7 @@ pkgs = import {}; haskellPackages = pkgs.haskellPackages.override { extension = self: super: { - usb = self.callPackage ./. {}; + usb = self.callPackage ./usb.nix {}; bindingsLibusb = self.callPackage ../bindings-libusb {}; }; }; @@ -10,9 +10,6 @@ in pkgs.myEnvFun { name = haskellPackages.usb.name; buildInputs = [ - #pkgs.curl - #pkgs.git - #pkgs.openssh pkgs.pkgconfig pkgs.libusb1 (haskellPackages.ghcWithPackages (hs: ([ diff --git a/usb.cabal b/usb.cabal --- a/usb.cabal +++ b/usb.cabal @@ -1,5 +1,5 @@ name: usb -version: 1.3.0.0 +version: 1.3.0.1 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -60,7 +60,7 @@ Library GHC-Options: -Wall - build-depends: base >= 4 && < 4.8 + build-depends: base >= 4 && < 4.9 , bindings-libusb >= 1.4.5 && < 1.5 , bytestring >= 0.9 && < 0.11 , text >= 0.5 && < 1.3 @@ -85,4 +85,4 @@ if impl(ghc >= 7.2.1) cpp-options: -DGENERICS - build-depends: ghc-prim >= 0.2 && < 0.4 + build-depends: ghc-prim >= 0.2 && < 0.5