ls-usb 0.1.0.12 → 0.1.0.13
raw patch · 3 files changed
+47/−35 lines, 3 filesdep +vectordep ~usb
Dependencies added: vector
Dependency ranges changed: usb
Files
- PrettyDevList.hs +23/−18
- ls-usb.cabal +3/−2
- ls-usb.hs +21/−15
PrettyDevList.hs view
@@ -14,7 +14,8 @@ Maintainer : Roel van Dijk <vandijk.roel@gmail.com> -} module PrettyDevList- ( PPStyle(..)+ ( DescribedDevice(..)+ , PPStyle(..) , brightStyle, darkStyle , ppDevices ) where@@ -35,7 +36,7 @@ , underline, white, yellow ) import "base" Control.Exception ( catch )-import "base" Control.Monad ( liftM, mapM, return )+import "base" Control.Monad ( (<=<), liftM, mapM, return ) import "base" Data.Bool ( Bool(False, True) ) import "base" Data.Char ( toLower ) import "base" Data.Function ( ($), id )@@ -45,7 +46,7 @@ ( intersperse, length, map, maximum, partition, transpose, zipWith ) import "base" Data.Maybe ( Maybe(Nothing, Just), maybe ) import "base" Data.Word ( Word8, Word16 )-import "base" Prelude ( String, (+), fromIntegral )+import "base" Prelude ( String, (+), (-), fromIntegral ) import "base" System.IO ( IO ) import "base" Text.Printf ( PrintfArg, printf ) import "base" Text.Show ( Show, show )@@ -63,7 +64,7 @@ import "usb" System.USB.Descriptors import "usb" System.USB.DeviceHandling ( withDeviceHandle ) import "usb" System.USB.Enumeration- ( Device, deviceDesc, busNumber, deviceAddress )+ ( Device, busNumber, deviceAddress ) import "usb" System.USB.Exceptions ( USBException ) import "usb-id-database" System.USB.IDDB ( IDDB@@ -71,7 +72,11 @@ , className, subClassName, protocolName , langName, subLangName )+import qualified "vector" Data.Vector as V ( length, toList ) +data DescribedDevice = DD { device ∷ Device+ , deviceDesc ∷ DeviceDesc+ } -------------------------------------------------------------------------------- -- Pretty printing styles@@ -261,14 +266,14 @@ ppLanguageList ∷ PPStyle → IDDB → Device → IO Doc ppLanguageList style db dev = catchUSBException ( withDeviceHandle dev- $ fmap (hsep ∘ punctuate (text ", ") ∘ map (ppLanguage style db))+ $ fmap (hsep ∘ punctuate (text ", ") ∘ map (ppLanguage style db) ∘ V.toList) ∘ getLanguages ) ( return ∘ ppError style "Couldn't retrieve language list" ) -ppDevices ∷ PPStyle → IDDB → Bool → [Device] → IO Doc+ppDevices ∷ PPStyle → IDDB → Bool → [DescribedDevice] → IO Doc ppDevices style db False = liftM vcat ∘ mapM (ppDeviceShort style db) ppDevices style db True = liftM (vcat ∘ intersperse (char ' ')) ∘ mapM (ppDevice style db)@@ -277,10 +282,9 @@ ppAddr style a = let toDoc = addrStyle style ∷ String → Doc in toDoc $ printf "%03d" a -ppDeviceShort ∷ PPStyle → IDDB → Device → IO Doc-ppDeviceShort style db dev = do- let desc = deviceDesc dev- vid = deviceVendorId desc+ppDeviceShort ∷ PPStyle → IDDB → DescribedDevice → IO Doc+ppDeviceShort style db (DD dev desc) = do+ let vid = deviceVendorId desc pid = deviceProductId desc busDoc = ppAddr style $ busNumber dev devAddrDoc = ppAddr style $ deviceAddress dev@@ -293,9 +297,8 @@ <+> ppVendorName style db vid (<+> ppProductName style db vid pid (char '-' <+>)) -ppDevice ∷ PPStyle → IDDB → Device → IO Doc-ppDevice style db dev = do- let desc = deviceDesc dev+ppDevice ∷ PPStyle → IDDB → DescribedDevice → IO Doc+ppDevice style db (DD dev desc) = do descDoc ← ppDeviceDesc style db dev desc langDoc ← ppLanguageList style db dev @@ -333,9 +336,10 @@ manufacturerDoc ← ppStringDesc style dev manufacturerIx productDoc ← ppStringDesc style dev productIx serialDoc ← ppStringDesc style dev serialIx- configDocs ← mapM (ppConfigDesc style db dev)- $ deviceConfigs desc + configDocs <- mapM (ppConfigDesc style db dev <=< getConfigDesc dev)+ [0..numConfigs-1]+ let classDoc = ppDevClass style db classId subClassDoc = ppDevSubClass style db classId subClassId protocolDoc = ppDevProtocol style db classId subClassId protocolId@@ -374,7 +378,8 @@ ifDescs = configInterfaces conf strDesc ← ppStringDesc style dev stringIx- ifDescDocs ← mapM (mapM $ ppInterfaceDesc style db dev) ifDescs+ ifDescDocs ← mapM (mapM (ppInterfaceDesc style db dev) ∘ V.toList) $+ V.toList ifDescs let vcatAlts = (<$>) (section style "Interface") ∘ indent 2@@ -388,7 +393,7 @@ , field' "Descriptor" [descrAddrStyle style stringIx, strDesc] , field' "Attributes" [pretty' style (configAttribs conf)] , field' "Max power" [usbNumStyle' (2 ⋅ configMaxPower conf) <+> text "mA"]- , field' "Num interfaces" [usbNumStyle' $ configNumInterfaces conf]+ , field' "Num interfaces" [usbNumStyle' $ fromIntegral $ V.length ifDescs] ] <$> vcat (map vcatAlts ifDescDocs) ppInterfaceDesc ∷ PPStyle → IDDB → Device → InterfaceDesc → IO Doc@@ -405,7 +410,7 @@ protocolDoc = ppProtocol style db classId subClassId protocolId (inEndpts, outEndpts) = partition ((In ≡) ∘ transferDirection ∘ endpointAddress)- $ interfaceEndpoints ifDesc+ $ V.toList $ interfaceEndpoints ifDesc strDesc ← ppStringDesc style dev stringIx
ls-usb.cabal view
@@ -1,5 +1,5 @@ name: ls-usb-version: 0.1.0.12+version: 0.1.0.13 cabal-version: >= 1.6 build-type: Simple stability: beta@@ -26,8 +26,9 @@ , base-unicode-symbols >= 0.1.1 && < 0.3 , text >= 0.1 && < 0.12 , cmdargs >= 0.3 && < 0.11- , usb >= 1.0 && < 1.2+ , usb >= 1.2 && < 1.3 , usb-id-database >= 0.4.0.2 && < 0.5+ , vector >= 0.5 && < 0.11 ghc-options: -Wall main-is: ls-usb.hs other-modules: PrettyDevList
ls-usb.hs view
@@ -22,8 +22,9 @@ import "base" Data.Bool ( Bool(False, True), otherwise ) import "base" Data.Data ( Data ) import "base" Data.Function ( ($), const, id )+import "base" Data.Functor ( (<$>), fmap ) import "base" Data.Int ( Int )-import "base" Data.List ( (++), filter, foldr, map )+import "base" Data.List ( (++), foldr, map ) import "base" Data.Typeable ( Typeable ) import "base" Data.Word ( Word8 ) import "base" Data.Version ( showVersion )@@ -41,16 +42,16 @@ , cmdArgs, def, details, explicit, help , isLoud, name, summary, typ, verbosity )-import "this" PrettyDevList ( ppDevices, brightStyle, darkStyle )+import "this" PrettyDevList ( DescribedDevice(..), ppDevices, brightStyle, darkStyle ) import "this" Paths_ls_usb ( version ) import "usb" System.USB.Initialization ( Verbosity(PrintNothing), newCtx, setDebug ) import "usb" System.USB.Enumeration- ( Device, getDevices, deviceDesc, busNumber, deviceAddress )+ ( getDevices, busNumber, deviceAddress ) import "usb" System.USB.Descriptors- ( VendorId, ProductId, deviceVendorId, deviceProductId )+ ( VendorId, ProductId, getDeviceDesc, deviceVendorId, deviceProductId ) import "usb-id-database" System.USB.IDDB.LinuxUsbIdRepo ( staticDb )-+import qualified "vector" Data.Vector as V -------------------------------------------------------------------------------- -- Main@@ -89,15 +90,20 @@ db ← staticDb ctx ← newCtx setDebug ctx PrintNothing++ devs ← fmap (V.toList ∘ V.filter (filterFromOpts opts)) ∘+ V.mapM (\dev -> DD dev <$> getDeviceDesc dev) =<<+ getDevices ctx+ let style | darker opts = darkStyle | otherwise = brightStyle+ (putDoc ∘ if nocolour opts then plain else id)- =<< ppDevices style db verbose- ∘ filter (filterFromOpts opts)- =<< getDevices ctx+ =<< ppDevices style db verbose devs+ putStrLn "" -filterFromOpts ∷ Options → F Device+filterFromOpts ∷ Options → F DescribedDevice filterFromOpts opts = andF $ map (filterNonEmpty ∘ ($ opts)) [ map (matchVID ∘ fromIntegral) ∘ vid , map (matchPID ∘ fromIntegral) ∘ pid@@ -137,14 +143,14 @@ -- Specific Device filters -------------------------------------------------------------------------------- -matchVID ∷ VendorId → F Device+matchVID ∷ VendorId → F DescribedDevice matchVID vid' = (vid' ≡) ∘ deviceVendorId ∘ deviceDesc -matchPID ∷ ProductId → F Device+matchPID ∷ ProductId → F DescribedDevice matchPID pid' = (pid' ≡) ∘ deviceProductId ∘ deviceDesc -matchBus ∷ Word8 → F Device-matchBus bus' = (bus' ≡) ∘ busNumber+matchBus ∷ Word8 → F DescribedDevice+matchBus bus' = (bus' ≡) ∘ busNumber ∘ device -matchDevAddr ∷ Word8 → F Device-matchDevAddr addr = (addr ≡) ∘ deviceAddress+matchDevAddr ∷ Word8 → F DescribedDevice+matchDevAddr addr = (addr ≡) ∘ deviceAddress ∘ device