diff --git a/System/USB/Safe.hs b/System/USB/Safe.hs --- a/System/USB/Safe.hs +++ b/System/USB/Safe.hs @@ -146,10 +146,10 @@ , ReadAction , WriteAction - , readEndpoint - , writeEndpoint + , ReadEndpoint(readEndpoint) + , WriteEndpoint(writeEndpoint) - , enumReadEndpoint + , EnumReadEndpoint(enumReadEndpoint) -- ** Control transfers , ControlAction @@ -178,12 +178,11 @@ -- from base: import Control.Concurrent.MVar ( MVar, newMVar, takeMVar, putMVar, withMVar ) import Control.Monad ( Monad, return, (>>=), (>>), liftM ) -import Control.Exception ( Exception, throwIO ) +import Control.Exception ( Exception, bracket_ ) import Data.Typeable ( Typeable ) import Data.Function ( ($) ) import Data.Word ( Word8 ) import Data.Int ( Int ) -import Data.Char ( String ) import Data.Bool ( Bool(True, False) ) import Data.List ( map, head, filter, find ) import Data.Maybe ( Maybe(Nothing, Just), fromJust ) @@ -203,13 +202,15 @@ -- from bytestring: import Data.ByteString ( ByteString ) +-- from text: +import Data.Text ( Text ) + -- from transformers: import Control.Monad.IO.Class ( MonadIO, liftIO ) --- from monad-peel: -import Control.Monad.IO.Peel ( MonadPeelIO ) -import Control.Exception.Peel ( bracket_, block ) -import qualified Control.Exception.Peel as P ( throwIO ) +-- from monad-control: +import Control.Monad.IO.Control ( MonadControlIO, liftIOOp_ ) +import Control.Exception.Control ( throwIO ) -- from regions: import Control.Monad.Trans.Region.OnExit ( FinalizerHandle, onExit ) @@ -238,7 +239,9 @@ , InterfaceNumber, claimInterface, releaseInterface , setInterfaceAltSetting , clearHalt, resetDevice - , kernelDriverActive, detachKernelDriver, attachKernelDriver + , kernelDriverActive + , detachKernelDriver, attachKernelDriver + , withDetachedKernelDriver ) import qualified System.USB.Descriptors as USB @@ -276,7 +279,15 @@ import qualified System.USB.IO.Synchronous.Enumerator as USB ( enumReadBulk, enumReadInterrupt ) +#if MIN_VERSION_base(4,3,0) +import Control.Exception.Control ( mask_ ) +#else +import Control.Exception.Control ( block ) +mask_ ∷ MonadControlIO m ⇒ m α → m α +mask_ = block +#endif + -------------------------------------------------------------------------------- -- ** Regional device handles -------------------------------------------------------------------------------- @@ -310,9 +321,9 @@ * Another 'USB.USBException'. -} -openDevice ∷ MonadPeelIO pr +openDevice ∷ MonadControlIO pr ⇒ USB.Device → RegionT s pr (RegionalDeviceHandle (RegionT s pr)) -openDevice dev = block $ do +openDevice dev = mask_ $ do h ← liftIO $ USB.openDevice dev mv ← liftIO $ newMVar False ch ← onExit $ USB.closeDevice h @@ -321,7 +332,7 @@ {-| Convenience function which opens the device, applies the given continuation function to the resulting regional device handle and runs the resulting region. -} -withDevice ∷ MonadPeelIO pr +withDevice ∷ MonadControlIO pr ⇒ USB.Device → (∀ s. RegionalDeviceHandle (RegionT s pr) → RegionT s pr α) → pr α @@ -344,7 +355,7 @@ * Another 'USB.USBException'. -} withDeviceWhich ∷ ∀ pr α - . MonadPeelIO pr + . MonadControlIO pr ⇒ USB.Ctx → (USB.DeviceDesc → Bool) -- ^ Predicate on the device descriptor. → (∀ s. RegionalDeviceHandle (RegionT s pr) → RegionT s pr α) @@ -360,7 +371,7 @@ -- See: http://thread.gmane.org/gmane.comp.lang.haskell.glasgow.user/19134/focus=19153 -- A solution is to just inline the code of useWhich: (I know this is ugly!) case find (p ∘ getDesc) devs of - Nothing → P.throwIO USB.NotFoundException + Nothing → throwIO USB.NotFoundException Just dev → withDevice dev f #endif @@ -376,7 +387,7 @@ → k -- ^ Continuation function → m α useWhich ds w p f = case find (p ∘ getDesc) ds of - Nothing → P.throwIO USB.NotFoundException + Nothing → throwIO USB.NotFoundException Just d → w d f -- | Internally used function for getting the actual USB device handle from a @@ -538,7 +549,7 @@ * Another 'USB.USBException'. -} setConfig ∷ ∀ pr cr α - . (pr `AncestorRegion` cr, MonadPeelIO cr) + . (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ Config pr -- ^ The configuration you wish to set. → (∀ sCfg. ConfigHandle sCfg → cr α) -- ^ Continuation function. → cr α @@ -551,20 +562,21 @@ -- the given @MVar@ was set. If the given @MVar@ wasn't set it will be set -- before the given computation is performed. When the computation terminates, -- wheter normally or by raising an exception, the @MVar@ will be unset again. -withUnsettedMVar ∷ MonadPeelIO m ⇒ MVar Bool → m α → m α -withUnsettedMVar mv = bracket_ (liftIO $ do alreadySet ← takeMVar mv - if alreadySet - then do putMVar mv alreadySet - throwIO SettingAlreadySet - else putMVar mv True) - (liftIO $ overwriteMVar mv False) +withUnsettedMVar ∷ MonadControlIO m ⇒ MVar Bool → m α → m α +withUnsettedMVar mv = liftIOOp_ $ bracket_ + (do alreadySet ← takeMVar mv + if alreadySet + then do putMVar mv alreadySet + throwIO SettingAlreadySet + else putMVar mv True) + (overwriteMVar mv False) -- | Internally used function which sets the @MVar@ before the computation is -- performed. When the computation terminates, wheter normally or by raising an -- exception, the @MVar@ will be unset again. -withSettedMVar ∷ MonadPeelIO m ⇒ MVar Bool → m α → m α -withSettedMVar mv = bracket_ (liftIO $ overwriteMVar mv True) - (liftIO $ overwriteMVar mv False) +withSettedMVar ∷ MonadControlIO m ⇒ MVar Bool → m α → m α +withSettedMVar mv = liftIOOp_ $ bracket_ (overwriteMVar mv True) + (overwriteMVar mv False) -- | Internally used function which overwrites the value in the @MVar@. -- @@ -605,7 +617,7 @@ * Another 'USB.USBException'. -} useActiveConfig ∷ ∀ pr cr α - . (pr `AncestorRegion` cr, MonadPeelIO cr) + . (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ RegionalDeviceHandle pr -- ^ Regional handle to the device -- from which you want to use the -- active configuration. @@ -615,7 +627,7 @@ withSettedMVar mv $ do mbActiveConfigValue ← liftIO $ USB.getConfig internalDevHndl case mbActiveConfigValue of - Nothing → P.throwIO NoActiveConfig + Nothing → throwIO NoActiveConfig Just activeConfigValue → let activeConfigHandle = ConfigHandle internalDevHndl activeConfigDesc activeConfigDesc = fromJust $ find isActive $ getConfigDescs internalDevHndl @@ -651,7 +663,7 @@ * Another 'USB.USBException'. -} setConfigWhich ∷ ∀ pr cr α - . (pr `AncestorRegion` cr, MonadPeelIO cr) + . (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ RegionalDeviceHandle pr -- ^ Regional handle to the device for -- which you want to set a -- configuration. @@ -737,19 +749,19 @@ * Another 'USB.USBException'. -} claim ∷ ∀ pr sCfg s - . MonadPeelIO pr + . MonadControlIO pr ⇒ Interface sCfg -- ^ Interface you wish to claim → RegionT s pr (RegionalInterfaceHandle sCfg (RegionT s pr)) -claim interface@(Interface internalDevHndl ifNum _) = block $ do +claim interface@(Interface internalDevHndl ifNum _) = mask_ $ do mv ← liftIO $ newMVar False liftIO $ USB.claimInterface internalDevHndl ifNum ch ← onExit $ USB.releaseInterface internalDevHndl ifNum return $ RegionalInterfaceHandle interface mv ch withInterface ∷ ∀ pr sCfg α - . MonadPeelIO pr + . MonadControlIO pr ⇒ Interface sCfg -- ^ The interface you wish to claim. → (∀ s. RegionalInterfaceHandle sCfg (RegionT s pr) → RegionT s pr α @@ -774,7 +786,7 @@ -} withInterfaceWhich ∷ ∀ pr sCfg α - . MonadPeelIO pr + . MonadControlIO pr ⇒ ConfigHandle sCfg -- ^ Handle to a configuration of which -- you want to claim an interface. → (USB.Interface → Bool) -- ^ Predicate on the interface descriptors. @@ -854,7 +866,7 @@ * Another 'USB.USBException'. -} setAlternate ∷ ∀ pr cr sCfg α - . (pr `AncestorRegion` cr, MonadPeelIO cr) + . (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ Alternate sCfg pr -- ^ The alternate you wish to set. → (∀ sAlt. AlternateHandle sAlt pr → cr α) -- ^ Continuation function. → cr α @@ -885,7 +897,7 @@ * Another 'USB.USBException'. -} useActiveAlternate ∷ ∀ pr cr sCfg α - . (pr `AncestorRegion` cr, MonadPeelIO cr) + . (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ RegionalInterfaceHandle sCfg pr -- ^ Regional handle to the -- interface from which you want -- to use the active alternate. @@ -924,7 +936,7 @@ * Another 'USB.USBException'. -} setAlternateWhich ∷ ∀ pr cr sCfg α - . (pr `AncestorRegion` cr, MonadPeelIO cr) + . (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ RegionalInterfaceHandle sCfg pr -- ^ Regional handle to the -- interface for which you want -- to set an alternate. @@ -1159,7 +1171,7 @@ class EnumReadEndpoint transType where -- | An enumerator for an 'In' endpoint -- with either a 'Bulk' or 'Interrupt' transfer type. - enumReadEndpoint ∷ ( pr `AncestorRegion` cr, MonadPeelIO cr, ReadableChunk s Word8 + enumReadEndpoint ∷ ( pr `AncestorRegion` cr, MonadControlIO cr, ReadableChunk s Word8 #if MIN_VERSION_iteratee(0,4,0) , NullPoint s #endif @@ -1332,10 +1344,6 @@ {-| 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 'USB.USBException's. /TODO: The following can be made more type-safe!/ @@ -1352,16 +1360,11 @@ → Int -- ^ Maximum number of characters in the requested string. An -- 'USB.IOException' will be thrown when the requested -- string is larger than this number. - → cr String + → cr Text getStrDesc devHndl strIx langId size = liftIO $ USB.getStrDesc (getInternalDevHndl devHndl) strIx langId size -{-| Retrieve a string descriptor from a device -using the first supported language. - -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. +{-| Retrieve a string descriptor from a device using the first supported language. This function may throw 'USB.USBException's. -} @@ -1371,7 +1374,7 @@ → Int -- ^ Maximum number of characters in the requested -- string. An 'USB.IOException' will be thrown when -- the requested string is larger than this number. - → cr String + → cr Text getStrDescFirstLang devHndl descStrIx size = liftIO $ USB.getStrDescFirstLang (getInternalDevHndl devHndl) descStrIx size @@ -1448,29 +1451,15 @@ * Another 'USB.USBException'. -} -withDetachedKernelDriver ∷ (pr `AncestorRegion` cr, MonadPeelIO cr) +withDetachedKernelDriver ∷ (pr `AncestorRegion` cr, MonadControlIO cr) ⇒ RegionalDeviceHandle pr → USB.InterfaceNumber → cr α → cr α -withDetachedKernelDriver regionalDevHndl ifNum action = - ifM (kernelDriverActive regionalDevHndl ifNum) - (bracket_ (detachKernelDriver regionalDevHndl ifNum) - (attachKernelDriver regionalDevHndl ifNum) - action) - action - - --------------------------------------------------------------------------------- --- * Utils --------------------------------------------------------------------------------- - --- | Monadic @if ... then ... else ...@ -ifM ∷ Monad m ⇒ m Bool → m α → m α → m α -ifM cM tM eM = do c ← cM - if c - then tM - else eM +withDetachedKernelDriver regionalDevHndl ifNum = + liftIOOp_ $ USB.withDetachedKernelDriver + (getInternalDevHndl regionalDevHndl) + ifNum -- The End --------------------------------------------------------------------- diff --git a/usb-safe.cabal b/usb-safe.cabal --- a/usb-safe.cabal +++ b/usb-safe.cabal @@ -1,5 +1,5 @@ name: usb-safe -version: 0.11.0.2 +version: 0.12 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -71,11 +71,12 @@ GHC-Options: -Wall -fno-warn-orphans build-depends: base >= 4 && < 4.4 , base-unicode-symbols >= 0.1.1 && < 0.3 - , usb >= 0.5 && < 0.8 - , usb-enumerator >= 0.2 && < 0.3 - , iteratee >= 0.3.5 && < 0.8 + , usb >= 0.8 && < 0.9 + , usb-enumerator >= 0.3 && < 0.4 + , iteratee >= 0.3.5 && < 0.9 , bytestring >= 0.9 && < 0.10 - , regions >= 0.8 && < 0.9 + , text >= 0.5 && < 0.12 + , regions >= 0.9 && < 0.10 , transformers >= 0.2 && < 0.3 - , monad-peel >= 0.1 && < 0.2 + , monad-control >= 0.2 && < 0.3 exposed-modules: System.USB.Safe