diff --git a/PrettyDevList.hs b/PrettyDevList.hs --- a/PrettyDevList.hs +++ b/PrettyDevList.hs @@ -4,7 +4,9 @@ , ScopedTypeVariables , UnicodeSyntax #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module : PrettyDevList Copyright : 2009–2011 Roel van Dijk @@ -17,6 +19,11 @@ , ppDevices ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + -- from ansi-wl-pprint: import Text.PrettyPrint.ANSI.Leijen ( Doc, Pretty, SimpleDoc(..) , (<+>), (<$>), (<>) @@ -29,22 +36,22 @@ ) -- from base: -import Control.Exception ( catch ) -import Control.Monad ( liftM, mapM, return ) -import Data.Bool ( Bool(False, True) ) -import Data.Char ( String, toLower ) -import Data.Function ( ($), id ) -import Data.Functor ( fmap ) -import Data.Int ( Int ) -import Data.List ( intersperse, length, map, maximum - , partition, transpose, zipWith - ) -import Data.Maybe ( Maybe(Nothing, Just), maybe ) -import Data.Word ( Word8, Word16 ) -import Prelude ( (+), fromIntegral ) -import System.IO ( IO ) -import Text.Printf ( PrintfArg, printf ) -import Text.Show ( Show, show ) +import Control.Exception ( catch ) +import Control.Monad ( liftM, mapM, return ) +import Data.Bool ( Bool(False, True) ) +import Data.Char ( toLower ) +import Data.Function ( ($), id ) +import Data.Functor ( fmap ) +import Data.Int ( Int ) +import Data.List ( intersperse, length, map, maximum + , partition, transpose, zipWith + ) +import Data.Maybe ( Maybe(Nothing, Just), maybe ) +import Data.Word ( Word8, Word16 ) +import Prelude ( String, (+), fromIntegral ) +import System.IO ( IO ) +import Text.Printf ( PrintfArg, printf ) +import Text.Show ( Show, show ) #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), fail ) @@ -53,16 +60,18 @@ #endif -- from base-unicode-symbols: -import Control.Arrow.Unicode ( (⋙) ) -import Data.Function.Unicode ( (∘) ) -import Data.Eq.Unicode ( (≡) ) -import Prelude.Unicode ( (⋅) ) +import Control.Arrow.Unicode ( (⋙) ) +import Data.Function.Unicode ( (∘) ) +import Data.Eq.Unicode ( (≡) ) +import Prelude.Unicode ( (⋅) ) -- from text: -import qualified Data.Text as T ( Text, unpack ) +import qualified Data.Text as T ( Text, unpack ) -- from usb: -import System.USB.Descriptors ( DeviceDesc +import System.USB.Descriptors ( getLanguages + , getStrDescFirstLang + , DeviceDesc , deviceClass, deviceConfigs , deviceManufacturerStrIx , deviceMaxPacketSize0, deviceNumConfigs @@ -97,40 +106,36 @@ , TransactionOpportunities(Zero, One, Two) , LangId, StrIx ) +import System.USB.DeviceHandling ( withDeviceHandle ) import System.USB.Enumeration ( Device , deviceDesc, busNumber, deviceAddress ) import System.USB.Exceptions ( USBException ) -- from usb-id-database: -import System.USB.IDDB ( IDDB - , vendorName, productName - , className, subClassName, protocolName - , langName, subLangName - ) - --- from usb-safe: -import System.USB.Safe ( withDevice - , getStrDescFirstLang - , getLanguages - ) +import System.USB.IDDB ( IDDB + , vendorName, productName + , className, subClassName, protocolName + , langName, subLangName + ) -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- Pretty printing styles +-------------------------------------------------------------------------------- data PPStyle = PPStyle - { sectionStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , fieldStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , usbNumStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , usbStrStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , stringStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , descrStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , descrAddrStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , versionStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , addrStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , errorStyle ∷ ∀ α. Pretty α ⇒ α → Doc - , errorDescrStyle ∷ ∀ α. Pretty α ⇒ α → Doc + { sectionStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , fieldStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , usbNumStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , usbStrStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , stringStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , descrStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , descrAddrStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , versionStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , addrStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , errorStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc + , errorDescrStyle ∷ ∀ α. (Pretty α) ⇒ α → Doc } brightStyle ∷ PPStyle @@ -163,7 +168,7 @@ , errorDescrStyle = pretty ⋙ dullred } -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- field ∷ PPStyle → String → [Doc] → [Doc] field style name xs = (fieldStyle style $ (text name) <> char ':') : xs @@ -171,8 +176,10 @@ section ∷ PPStyle → String → Doc section style = sectionStyle style ∘ text -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- Some basic instances of the Pretty class +-------------------------------------------------------------------------------- instance Pretty T.Text where pretty = pretty ∘ T.unpack @@ -180,8 +187,10 @@ instance Pretty Word8 where pretty = int ∘ fromIntegral -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- Miscellaneous pretty printing functions +-------------------------------------------------------------------------------- columns ∷ Int → [[Doc]] → Doc columns s rows = vcat $ map ( hcat @@ -204,8 +213,10 @@ sdocLen (SLine i d) = i + sdocLen d sdocLen (SSGR _ d) = sdocLen d -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- USB utility functions +-------------------------------------------------------------------------------- stringBufferSize ∷ Int stringBufferSize = 512 @@ -213,8 +224,10 @@ catchUSBException ∷ IO α → (USBException → IO α) → IO α catchUSBException = catch -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- Pretty printers for USB types +-------------------------------------------------------------------------------- unknown ∷ Doc unknown = text "unknown" @@ -225,7 +238,7 @@ ppStringDesc ∷ PPStyle → Device → Maybe StrIx → IO Doc ppStringDesc _ _ Nothing = return empty ppStringDesc style dev (Just ix) = catchUSBException - ( withDevice dev $ \devH → + ( withDeviceHandle dev $ \devH → fmap (descrStyle style) $ getStrDescFirstLang devH ix @@ -294,7 +307,7 @@ ppLanguageList ∷ PPStyle → IDDB → Device → IO Doc ppLanguageList style db dev = - catchUSBException ( withDevice dev + catchUSBException ( withDeviceHandle dev $ fmap (hsep ∘ punctuate (text ", ") ∘ map (ppLanguage style db)) ∘ getLanguages ) @@ -459,8 +472,10 @@ $ outEndpts ) -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- USB specific instances of Pretty +-------------------------------------------------------------------------------- class PrettyStyle α where pretty' ∷ PPStyle → α → Doc 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.9 +version: 0.1.0.10 cabal-version: >= 1.6 build-type: Simple stability: beta @@ -8,6 +8,8 @@ copyright: 2009–2011 Roel van Dijk license: BSD3 license-file: LICENSE +homepage: https://github.com/roelvandijk/ls-usb +bug-reports: https://github.com/roelvandijk/ls-usb/issues category: System synopsis: List USB devices description: @@ -20,13 +22,12 @@ executable ls-usb build-depends: ansi-wl-pprint >= 0.5.1 && < 0.7 - , base >= 4.0 && < 4.4 + , base >= 4.0 && < 4.5 , base-unicode-symbols >= 0.1.1 && < 0.3 , text >= 0.1 && < 0.12 - , cmdargs >= 0.3 && < 0.7 - , usb >= 0.8 && < 0.9 + , cmdargs >= 0.3 && < 0.9 + , usb >= 1.0 && < 1.1 , usb-id-database >= 0.4.0.2 && < 0.5 - , usb-safe >= 0.12 && < 0.13 - ghc-options: -Wall -fno-warn-orphans + 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 @@ -8,6 +8,11 @@ -} module Main where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + -- from ansi-wl-pprint: import Text.PrettyPrint.ANSI.Leijen ( putDoc, plain ) @@ -62,8 +67,9 @@ import System.USB.IDDB.LinuxUsbIdRepo ( staticDb ) -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- Main +-------------------------------------------------------------------------------- data Options = Options { vid ∷ [Int] , pid ∷ [Int] @@ -115,8 +121,9 @@ ] -------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- Filters +-------------------------------------------------------------------------------- type F α = α → Bool @@ -140,8 +147,10 @@ filterNonEmpty [] = const True filterNonEmpty xs = foldr (<∨>) (const False) xs -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- -- Specific Device filters +-------------------------------------------------------------------------------- matchVID ∷ VendorId → F Device matchVID vid' = (vid' ≡) ∘ deviceVendorId ∘ deviceDesc