diff --git a/PrettyDevList.hs b/PrettyDevList.hs --- a/PrettyDevList.hs +++ b/PrettyDevList.hs @@ -14,7 +14,8 @@ Maintainer : Roel van Dijk -} 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 diff --git a/ls-usb.cabal b/ls-usb.cabal --- a/ls-usb.cabal +++ b/ls-usb.cabal @@ -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 diff --git a/ls-usb.hs b/ls-usb.hs --- a/ls-usb.hs +++ b/ls-usb.hs @@ -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