ls-usb 0.1.0.1 → 0.1.0.2
raw patch · 3 files changed
+188/−191 lines, 3 filesdep +unicode-symbolsdep ~usb
Dependencies added: unicode-symbols
Dependency ranges changed: usb
Files
- PrettyDevList.hs +136/−132
- ls-usb.cabal +3/−2
- ls-usb.hs +49/−57
PrettyDevList.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-} module PrettyDevList ( PPStyle(..)@@ -13,8 +15,9 @@ import Control.Monad ( liftM, mapM ) import Data.ByteString.Char8 ( ByteString, unpack ) import Data.Char ( toLower )-import Data.List ( intersperse, transpose )+import Data.List ( intersperse, partition, transpose ) import Data.Word ( Word8, Word16 )+import Prelude.Unicode ( (∘), (⋅) ) import System.USB import System.USB.IDDB ( IDDB , vendorName, productName@@ -28,20 +31,20 @@ -- Pretty printing styles data PPStyle = PPStyle- { sectionStyle :: forall a. Pretty a => a -> Doc- , fieldStyle :: forall a. Pretty a => a -> Doc- , usbNumStyle :: forall a. Pretty a => a -> Doc- , usbStrStyle :: forall a. Pretty a => a -> Doc- , stringStyle :: forall a. Pretty a => a -> Doc- , descrStyle :: forall a. Pretty a => a -> Doc- , descrAddrStyle :: forall a. Pretty a => a -> Doc- , versionStyle :: forall a. Pretty a => a -> Doc- , addrStyle :: forall a. Pretty a => a -> Doc- , errorStyle :: forall a. Pretty a => a -> Doc- , errorDescrStyle :: forall a. Pretty a => a -> 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+brightStyle ∷ PPStyle brightStyle = PPStyle { sectionStyle = pretty >>> white >>> bold >>> underline , fieldStyle = pretty@@ -56,7 +59,7 @@ , errorDescrStyle = pretty >>> dullred } -darkStyle :: PPStyle+darkStyle ∷ PPStyle darkStyle = PPStyle { sectionStyle = pretty >>> bold >>> underline , fieldStyle = pretty@@ -73,42 +76,42 @@ ------------------------------------------------------------------------------- -field :: PPStyle -> String -> [Doc] -> [Doc]+field ∷ PPStyle → String → [Doc] → [Doc] field style name xs = (fieldStyle style $ (text name) <> char ':') : xs -section :: PPStyle -> String -> Doc-section style = sectionStyle style . text+section ∷ PPStyle → String → Doc+section style = sectionStyle style ∘ text ------------------------------------------------------------------------------- -- Some basic instances of the Pretty class instance Pretty ByteString where- pretty = pretty . unpack+ pretty = pretty ∘ unpack instance Pretty Word8 where- pretty = int . fromIntegral+ pretty = int ∘ fromIntegral instance Pretty Word16 where- pretty = int . fromIntegral+ pretty = int ∘ fromIntegral ------------------------------------------------------------------------------- -- Miscellaneous pretty printing functions -columns :: Int -> [[Doc]] -> Doc+columns ∷ Int → [[Doc]] → Doc columns s rows = vcat $ map ( hcat- . zipWith fill (map (+s) $ columnSizes rows)+ ∘ zipWith fill (map (+ s) $ columnSizes rows) ) rows -columnSizes :: [[Doc]] -> [Int]-columnSizes = map (maximum . map docLen) . transpose+columnSizes ∷ [[Doc]] → [Int]+columnSizes = map (maximum ∘ map docLen) ∘ transpose -- A bit of a hack to calculate the length of a document without -- considering colour codes.-docLen :: Doc -> Int-docLen = sdocLen . renderPretty 0.4 100+docLen ∷ Doc → Int+docLen = sdocLen ∘ renderPretty 0.4 100 where- sdocLen :: SimpleDoc -> Int+ sdocLen ∷ SimpleDoc → Int sdocLen (SEmpty) = 0 sdocLen (SChar _ d) = 1 + sdocLen d sdocLen (SText i _ d) = i + sdocLen d@@ -118,118 +121,117 @@ ------------------------------------------------------------------------------- -- USB utility functions -stringBufferSize :: Int+stringBufferSize ∷ Int stringBufferSize = 512 -catchUSBException :: IO a -> (USBException -> IO a) -> IO a+catchUSBException ∷ IO α → (USBException → IO α) → IO α catchUSBException = catch ------------------------------------------------------------------------------- -- Pretty printers for USB types -unknown :: Doc+unknown ∷ Doc unknown = text "unknown" -ppBCD4 :: BCD4 -> Doc-ppBCD4 (a, b, c, d) = hcat . punctuate (char '.') $ map pretty [a, b, c, d]+ppBCD4 ∷ BCD4 → Doc+ppBCD4 (a, b, c, d) = hcat ∘ punctuate (char '.') $ map pretty [a, b, c, d] -ppStringDesc :: PPStyle -> Device -> StrIx -> IO Doc+ppStringDesc ∷ PPStyle → Device → StrIx → IO Doc ppStringDesc _ _ 0 = return empty ppStringDesc style dev ix = catchUSBException- ( withDeviceHandle dev $ \devH ->+ ( withDeviceHandle dev $ \devH → liftM (descrStyle style) $ getStrDescFirstLang devH ix stringBufferSize )- (return . ppError style "Couldn't retrieve string descriptor")+ (return ∘ ppError style "Couldn't retrieve string descriptor") -ppError :: Show e => PPStyle -> String -> e -> Doc+ppError ∷ Show e ⇒ PPStyle → String → e → Doc ppError style descr err = errorDescrStyle style $ text descr <> char ':' <+> errorStyle style (show err) -ppId :: PrintfArg n => n -> Doc-ppId x = text (printf "%04x" x :: String)+ppId ∷ PrintfArg n ⇒ n → Doc+ppId x = text (printf "%04x" x ∷ String) -ppVendorName :: PPStyle -> IDDB -> Word16 -> (Doc -> Doc) -> Doc-ppVendorName style db vid f = maybe unknown (f . stringStyle style)+ppVendorName ∷ PPStyle → IDDB → Word16 → (Doc → Doc) → Doc+ppVendorName style db vid f = maybe unknown (f ∘ stringStyle style) $ vendorName db vid' where vid' = fromIntegral vid -ppProductName :: PPStyle -> IDDB -> Word16 -> Word16 -> (Doc -> Doc) -> Doc-ppProductName style db vid pid f = maybe unknown (f . stringStyle style)+ppProductName ∷ PPStyle → IDDB → Word16 → Word16 → (Doc → Doc) → Doc+ppProductName style db vid pid f = maybe unknown (f ∘ stringStyle style) $ productName db vid' pid' where vid' = fromIntegral vid pid' = fromIntegral pid -ppDevClass :: PPStyle -> IDDB -> Word8 -> Doc+ppDevClass ∷ PPStyle → IDDB → Word8 → Doc ppDevClass _ _ 0 = text "defined at interface level" ppDevClass style db cid = ppClass style db cid -ppDevSubClass :: PPStyle -> IDDB -> Word8 -> Word8 -> Doc+ppDevSubClass ∷ PPStyle → IDDB → Word8 → Word8 → Doc ppDevSubClass _ _ 0 0 = text "defined at interface level" ppDevSubClass style db cid scid = ppSubClass style db cid scid -ppDevProtocol :: PPStyle -> IDDB -> Word8 -> Word8 -> Word8 -> Doc+ppDevProtocol ∷ PPStyle → IDDB → Word8 → Word8 → Word8 → Doc ppDevProtocol _ _ 0 0 0 = text "defined at interface level" ppDevProtocol style db cid scid protId = ppProtocol style db cid scid protId -ppClass :: PPStyle -> IDDB -> Word8 -> Doc+ppClass ∷ PPStyle → IDDB → Word8 → Doc ppClass style db cid = maybe unknown (stringStyle style) $ className db cid' where cid' = fromIntegral cid -ppSubClass :: PPStyle -> IDDB -> Word8 -> Word8 -> Doc+ppSubClass ∷ PPStyle → IDDB → Word8 → Word8 → Doc ppSubClass style db cid scid = maybe unknown (stringStyle style) $ subClassName db cid' scid' where cid' = fromIntegral cid scid' = fromIntegral scid -ppProtocol :: PPStyle -> IDDB -> Word8 -> Word8 -> Word8 -> Doc+ppProtocol ∷ PPStyle → IDDB → Word8 → Word8 → Word8 → Doc ppProtocol style db cid scid protId = maybe unknown (stringStyle style) $ protocolName db cid' scid' protId' where cid' = fromIntegral cid scid' = fromIntegral scid protId' = fromIntegral protId -ppLanguage :: PPStyle -> IDDB -> LangId -> Doc+ppLanguage ∷ PPStyle → IDDB → LangId → Doc ppLanguage style db (lid, slid) =- let lid' = fromIntegral lid+ let lid' = fromIntegral lid slid' = fromIntegral slid prettyLang = stringStyle style langDoc = maybe unknown prettyLang $ langName db lid' subDoc = maybe unknown prettyLang $ subLangName db lid' slid' in langDoc <+> char '-' <+> subDoc -ppLanguageList :: PPStyle -> IDDB -> Device -> IO Doc+ppLanguageList ∷ PPStyle → IDDB → Device → IO Doc ppLanguageList style db dev = catchUSBException ( withDeviceHandle dev- $ fmap (hsep . punctuate (text ", ") . map (ppLanguage style db))- . getLanguages+ $ fmap (hsep ∘ punctuate (text ", ") ∘ map (ppLanguage style db))+ ∘ getLanguages ) ( return- . ppError style "Couldn't retrieve language list"+ ∘ ppError style "Couldn't retrieve language list" ) -ppDevices :: PPStyle -> IDDB -> Bool -> [Device] -> IO Doc-ppDevices style db False = liftM vcat . mapM (ppDeviceShort style db)-ppDevices style db True = liftM (vcat . intersperse (char ' '))- . mapM (ppDevice style db)+ppDevices ∷ PPStyle → IDDB → Bool → [Device] → IO Doc+ppDevices style db False = liftM vcat ∘ mapM (ppDeviceShort style db)+ppDevices style db True = liftM (vcat ∘ intersperse (char ' '))+ ∘ mapM (ppDevice style db) -ppAddr :: PrintfArg n => PPStyle -> IO n -> IO Doc-ppAddr style a = let toDoc = addrStyle style :: String -> Doc- in fmap (toDoc . printf "%03d") a+ppAddr ∷ PrintfArg n ⇒ PPStyle → n → Doc+ppAddr style a = let toDoc = addrStyle style ∷ String → Doc+ in toDoc $ printf "%03d" a -ppDeviceShort :: PPStyle -> IDDB -> Device -> IO Doc+ppDeviceShort ∷ PPStyle → IDDB → Device → IO Doc ppDeviceShort style db dev = do- desc <- getDeviceDesc dev- busDoc <- ppAddr style (getBusNumber dev)- devAddrDoc <- ppAddr style (getDeviceAddress dev)-- let vid = deviceVendorId desc- pid = deviceProductId desc+ let desc = deviceDesc dev+ vid = deviceVendorId desc+ pid = deviceProductId desc+ busDoc = ppAddr style $ busNumber dev+ devAddrDoc = ppAddr style $ deviceAddress dev return $ text "Bus" <+> busDoc <+> text "Device" <+> devAddrDoc <> char ':'@@ -239,15 +241,15 @@ <+> ppVendorName style db vid (<+> ppProductName style db vid pid (char '-' <+>)) -ppDevice :: PPStyle -> IDDB -> Device -> IO Doc+ppDevice ∷ PPStyle → IDDB → Device → IO Doc ppDevice style db dev = do- desc <- getDeviceDesc dev- descDoc <- ppDeviceDesc style db dev desc- langDoc <- ppLanguageList style db dev- busDoc <- ppAddr style (getBusNumber dev)- devAddrDoc <- ppAddr style (getDeviceAddress dev)+ let desc = deviceDesc dev+ descDoc ← ppDeviceDesc style db dev desc+ langDoc ← ppLanguageList style db dev - let field' = field style+ let field' = field style+ busDoc = ppAddr style $ busNumber dev+ devAddrDoc = ppAddr style $ deviceAddress dev return $ section style "Device" <$> indent 2@@ -255,15 +257,15 @@ , field' "Address" [devAddrDoc] , field' "Supported languages" [langDoc] ]- <$> section style "Device descriptor"+ <$> section style "Device Descriptor" <$> indent 2 descDoc ) -ppDeviceDesc :: PPStyle -> IDDB -> Device -> DeviceDesc -> IO Doc+ppDeviceDesc ∷ PPStyle → IDDB → Device → DeviceDesc → IO Doc ppDeviceDesc style db dev desc = do- let field' = field style- usbNumStyle' :: forall a. Pretty a => a -> Doc+ let usbNumStyle' ∷ ∀ α. Pretty α ⇒ α → Doc usbNumStyle' = usbNumStyle style+ field' = field style versionStyle' = versionStyle style descrAddrStyle' = descrAddrStyle style manufacturerIx = deviceManufacturerStrIx desc@@ -276,21 +278,18 @@ vendorId = deviceVendorId desc productId = deviceProductId desc - configDescs <- mapM (getConfigDesc dev)- [0 .. fromIntegral numConfigs - 1]-- manufacturerDoc <- ppStringDesc style dev manufacturerIx- productDoc <- ppStringDesc style dev productIx- serialDoc <- ppStringDesc style dev serialIx- configDocs <- mapM (ppConfigDesc style db dev)- configDescs+ manufacturerDoc ← ppStringDesc style dev manufacturerIx+ productDoc ← ppStringDesc style dev productIx+ serialDoc ← ppStringDesc style dev serialIx+ configDocs ← mapM (ppConfigDesc style db dev)+ $ deviceConfigs desc let classDoc = ppDevClass style db classId subClassDoc = ppDevSubClass style db classId subClassId protocolDoc = ppDevProtocol style db classId subClassId protocolId return $ columns 2- [ field' "USB specification" [ versionStyle' . ppBCD4+ [ field' "USB specification" [ versionStyle' ∘ ppBCD4 $ deviceUSBSpecReleaseNumber desc ] , field' "Class" [usbNumStyle' classId, classDoc]@@ -303,46 +302,47 @@ , field' "Product ID" [ usbNumStyle' $ text "0x" <> ppId productId , ppProductName style db vendorId productId id ]- , field' "Release number" [ versionStyle' . ppBCD4+ , field' "Release number" [ versionStyle' ∘ ppBCD4 $ deviceReleaseNumber desc ] , field' "Manufacturer" [descrAddrStyle' manufacturerIx, manufacturerDoc] , field' "Product" [descrAddrStyle' productIx, productDoc] , field' "Serial number" [descrAddrStyle' serialIx, serialDoc] , field' "Num configs" [usbNumStyle' numConfigs]- ] <$> vcat ( map (\d -> section style "Configuration descriptor"+ ] <$> vcat ( map (\d → section style "Configuration Descriptor" <$> indent 2 d) configDocs ) -ppConfigDesc :: PPStyle -> IDDB -> Device -> ConfigDesc -> IO Doc+ppConfigDesc ∷ PPStyle → IDDB → Device → ConfigDesc → IO Doc ppConfigDesc style db dev conf = do let field' = field style usbNumStyle' = usbNumStyle style stringIx = configStrIx conf ifDescs = configInterfaces conf - strDesc <- ppStringDesc style dev stringIx- ifDescDocs <- mapM (mapM $ ppInterfaceDesc style db dev) ifDescs+ strDesc ← ppStringDesc style dev stringIx+ ifDescDocs ← mapM (mapM $ ppInterfaceDesc style db dev) ifDescs let vcatAlts = (<$>) (section style "Interface")- . indent 2- . vcat- . map ( (<$>) (section style "Alternative")- . indent 2+ ∘ indent 2+ ∘ vcat+ ∘ map ( (<$>) (section style "Alternative")+ ∘ indent 2 ) return $ columns 2 [ field' "Value" [usbNumStyle' $ configValue conf] , field' "Descriptor" [descrAddrStyle style stringIx, strDesc] , field' "Attributes" [pretty' style (configAttribs conf)]- , field' "Max power" [usbNumStyle' (2 * configMaxPower conf) <+> text "mA"]+ , field' "Max power" [usbNumStyle' (2 ⋅ configMaxPower conf) <+> text "mA"] , field' "Num interfaces" [usbNumStyle' $ configNumInterfaces conf] ] <$> vcat (map vcatAlts ifDescDocs) -ppInterfaceDesc :: PPStyle -> IDDB -> Device -> InterfaceDesc -> IO Doc+ppInterfaceDesc ∷ PPStyle → IDDB → Device → InterfaceDesc → IO Doc ppInterfaceDesc style db dev ifDesc = do let field' = field style+ usbNumStyle' ∷ ∀ α. Pretty α ⇒ α → Doc usbNumStyle' = usbNumStyle style stringIx = interfaceStrIx ifDesc classId = interfaceClass ifDesc@@ -351,8 +351,11 @@ classDoc = ppClass style db classId subClassDoc = ppSubClass style db classId subClassId protocolDoc = ppProtocol style db classId subClassId protocolId+ (inEndpts, outEndpts) = + partition ((==) In ∘ transferDirection ∘ endpointAddress) + $ interfaceEndpoints ifDesc - strDesc <- ppStringDesc style dev stringIx+ strDesc ← ppStringDesc style dev stringIx return $ columns 2 [ field' "Interface number" [usbNumStyle' $ interfaceNumber ifDesc]@@ -361,53 +364,54 @@ , field' "Sub class" [usbNumStyle' subClassId, subClassDoc] , field' "Protocol" [usbNumStyle' protocolId, protocolDoc] , field' "Descriptor" [descrAddrStyle style stringIx, strDesc]- , field' "Num endpoints" [usbNumStyle' $ interfaceNumEndpoints ifDesc]- ] <$> vcat ( map (\e -> section style "Endpoint" <$> indent 2 (pretty' style e))- $ interfaceEndpoints ifDesc+ , field' "Num in endpoints" [usbNumStyle' $ length inEndpts]+ , field' "Num out endpoints" [usbNumStyle' $ length outEndpts]+ ] <$> vcat ( map (\e → section style "In Endpoint" <$> indent 2 (pretty' style e))+ $ inEndpts )+ <$> vcat ( map (\e → section style "Out Endpoint" <$> indent 2 (pretty' style e))+ $ outEndpts+ ) ------------------------------------------------------------------------------- -- USB specific instances of Pretty -class PrettyStyle a where- pretty' :: PPStyle -> a -> Doc--instance PrettyStyle DeviceStatus where- pretty' s ds = align $ columns 2 [ field s "Remote wakeup"- [usbNumStyle s $ remoteWakeup ds]- , field s "Self powered"- [usbNumStyle s $ selfPowered ds]- ]+class PrettyStyle α where+ pretty' ∷ PPStyle → α → Doc instance PrettyStyle EndpointDesc where pretty' s ep =- columns 2 [ field' "Address" [pretty' s $ endpointAddress ep]- , field' "Attributes" [pretty' s $ endpointAttribs ep]- , field' "Max packet size" [pretty' s $ endpointMaxPacketSize ep]- , field' "Interval"- [usbNumStyle s (endpointInterval ep)]- , field' "Refresh"- [usbNumStyle s (endpointRefresh ep)]- , field' "Synch address"- [usbNumStyle s (endpointSynchAddress ep)]- ]+ columns 2+ [ field' "Address" [pretty' s $ endpointAddress ep]+ , field' "Attributes" [pretty' s $ endpointAttribs ep]+ , field' "Max packet size" [pretty' s $ endpointMaxPacketSize ep]+ , field' "Interval" [usbNumStyle s $ endpointInterval ep]+ , field' "Refresh" [usbNumStyle s $ endpointRefresh ep]+ , field' "Synch address" [usbNumStyle s $ endpointSynchAddress ep]+ ] where field' = field s instance PrettyStyle EndpointAddress where pretty' s ea = usbNumStyle s (endpointNumber ea)- <+> char '-'- <+> pretty' s (endpointDirection ea)+ <+> char '-' <+> pretty' s (transferDirection ea) instance PrettyStyle TransferDirection where- pretty' s Out = usbStrStyle s $ text "host" <+> text "->" <+> text "device"- pretty' s In = usbStrStyle s $ text "device" <+> text "->" <+> text "host"+ pretty' s Out = usbStrStyle s $ text "Out (host" <+> text "->" <+> text "device)"+ pretty' s In = usbStrStyle s $ text "In (device" <+> text "->" <+> text "host)" +instance PrettyStyle DeviceStatus where+ pretty' s ds = align $ columns 2 [ field s "Remote wakeup"+ [usbNumStyle s $ remoteWakeup ds]+ , field s "Self powered"+ [usbNumStyle s $ selfPowered ds]+ ]+ instance PrettyStyle Synchronization where pretty' s NoSynchronization = usbStrStyle s "no synchronization"- pretty' s es = usbStrStyle s . map toLower $ show es+ pretty' s es = usbStrStyle s ∘ map toLower $ show es instance Pretty Usage where- pretty = text . map toLower . show+ pretty = text ∘ map toLower ∘ show instance PrettyStyle MaxPacketSize where pretty' s mps = usbNumStyle s (maxPacketSize mps)@@ -415,13 +419,13 @@ <+> pretty' s (transactionOpportunities mps) instance PrettyStyle TransactionOpportunities where- pretty' s NoAdditionalTransactions = usbStrStyle s "no additional transactions"- pretty' s OneAdditionlTransaction = usbStrStyle s "one additional transaction"- pretty' s TwoAdditionalTransactions = usbStrStyle s "two additional transactions"+ pretty' s Zero = usbStrStyle s "Zero additional transactions"+ pretty' s One = usbStrStyle s "One additional transaction"+ pretty' s Two = usbStrStyle s "Two additional transactions" instance PrettyStyle TransferType where pretty' s (Isochronous syn u) = usbStrStyle s $ text "isochronous" <+> char '-' <+> text "synch:" <+> pretty' s syn <+> char '-' <+> text "usage:" <+> pretty u- pretty' s tt = usbStrStyle s . text . map toLower $ show tt+ pretty' s tt = usbStrStyle s ∘ text ∘ map toLower $ show tt
ls-usb.cabal view
@@ -1,5 +1,5 @@ name: ls-usb-version: 0.1.0.1+version: 0.1.0.2 cabal-version: >= 1.6 build-type: Simple stability: experimental@@ -18,7 +18,8 @@ , base >= 4.0 && < 4.2 , bytestring >= 0.9.1.4 && < 0.10 , cmdargs == 0.1.*- , usb >= 0.1 && < 0.3+ , unicode-symbols == 0.1.*+ , usb == 0.3.* , usb-id-database == 0.4.* ghc-options: -Wall -fno-warn-orphans main-is: ls-usb.hs
ls-usb.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE UnicodeSyntax #-} module Main where -import Control.Monad ( (>=>), filterM, liftM2 )+import Data.Word ( Word8 )+import Prelude.Unicode ( (∘), (∧), (∨), (≡)) import PrettyDevList ( ppDevices , brightStyle, darkStyle )@@ -14,15 +16,15 @@ ------------------------------------------------------------------------------- -- Main -data Options = Options { vid :: [Int]- , pid :: [Int]- , bus :: [Int]- , address :: [Int]- , nocolour :: Bool- , darker :: Bool+data Options = Options { vid ∷ [Int]+ , pid ∷ [Int]+ , bus ∷ [Int]+ , address ∷ [Int]+ , nocolour ∷ Bool+ , darker ∷ Bool } deriving (Show, Data, Typeable) -defaultOpts :: Mode Options+defaultOpts ∷ Mode Options defaultOpts = mode Options { vid = def &= explicit & flag "vid" & typ "VID" & text "List devices with this VID"@@ -40,75 +42,65 @@ & text "Lists connected USB devices" & helpSuffix ["Please ensure you have sufficient rights before running with higher verbosity"] -main :: IO ()-main = do opts <- cmdArgs "ls-usb 0.1.0.1, (C) Roel van Dijk 2009" [defaultOpts]- verbose <- isLoud- db <- staticDb- ctx <- newCtx+main ∷ IO ()+main = do opts ← cmdArgs "ls-usb 0.1.0.1, (C) Roel van Dijk 2009" + [defaultOpts]+ verbose ← isLoud+ db ← staticDb+ ctx ← newCtx let style | darker opts = darkStyle | otherwise = brightStyle- (putDoc . if nocolour opts then plain else id)- =<< ppDevices style db verbose- =<< filterM (filterFromOpts opts)+ (putDoc ∘ if nocolour opts then plain else id)+ =<< ppDevices style db verbose + ∘ filter (filterFromOpts opts) =<< getDevices ctx putStrLn "" -filterFromOpts :: Options -> F IO Device-filterFromOpts opts = andF $ map (filterNonEmpty . ($ opts))- [ map (descToDevFilter . matchVID . fromIntegral) . vid- , map (descToDevFilter . matchPID . fromIntegral) . pid- , map matchBus . bus- , map matchDevAddr . address- ]+filterFromOpts ∷ Options → F Device+filterFromOpts opts = andF $ map (filterNonEmpty ∘ ($ opts))+ [ map (matchVID ∘ fromIntegral) ∘ vid+ , map (matchPID ∘ fromIntegral) ∘ pid+ , map (matchBus ∘ fromIntegral) ∘ bus+ , map (matchDevAddr ∘ fromIntegral) ∘ address+ ]+ ------------------------------------------------------------------------------- -- Filters -type F m a = a -> m Bool+type F a = a → Bool -- Construct a filter combinator from a binary boolean operator.-binBoolOpToFComb :: Monad m => (Bool -> Bool -> Bool) -> F m a -> F m a -> F m a-binBoolOpToFComb op f g = \x -> liftM2 op (f x) (g x)--(<||>) :: Monad m => F m a -> F m a -> F m a-(<||>) = binBoolOpToFComb (||)+binBoolOpToFComb ∷ (Bool → Bool → Bool) → F a → F a → F a+binBoolOpToFComb (⊗) f g = \x → f x ⊗ g x -(<&&>) :: Monad m => F m a -> F m a -> F m a-(<&&>) = binBoolOpToFComb (&&)+(<∨>) ∷ F a → F a → F a+(<∨>) = binBoolOpToFComb (∨) -constF :: Monad m => Bool -> F m a-constF = const . return+(<∧>) ∷ F a → F a → F a+(<∧>) = binBoolOpToFComb (∧) -andF :: Monad m => [F m a] -> F m a-andF = foldr (<&&>) (constF True)+andF ∷ [F a] → F a+andF = foldr (<∧>) (const True) -orF :: Monad m => [F m a] -> F m a-orF = foldr (<||>) (constF False)+orF ∷ [F a] → F a+orF = foldr (<∨>) (const False) -filterNonEmpty :: Monad m => [F m a] -> F m a-filterNonEmpty [] = constF True-filterNonEmpty xs = foldr (<||>) (constF False) xs+filterNonEmpty ∷ [F a] → F a+filterNonEmpty [] = const True+filterNonEmpty xs = foldr (<∨>) (const False) xs ------------------------------------------------------------------------------- -- Specific Device filters -descToDevFilter :: F IO DeviceDesc -> F IO Device-descToDevFilter = (getDeviceDesc >=>)--matchVID :: VendorId -> F IO DeviceDesc-matchVID vid' desc = return $ vid' == deviceVendorId desc+matchVID ∷ VendorId → F Device+matchVID vid' = (vid' ≡) ∘ deviceVendorId ∘ deviceDesc -matchPID :: ProductId -> F IO DeviceDesc-matchPID pid' desc = return $ pid' == deviceProductId desc+matchPID ∷ ProductId → F Device+matchPID pid' = (pid' ≡) ∘ deviceProductId ∘ deviceDesc -matchBus :: Int -> F IO Device-matchBus bus' dev = return- . (bus' ==)- . fromIntegral- =<< getBusNumber dev+matchBus ∷ Word8 → F Device+matchBus bus' = (bus' ≡) ∘ busNumber -matchDevAddr :: Int -> F IO Device-matchDevAddr address' dev = return- . (address' ==)- . fromIntegral- =<< getDeviceAddress dev+matchDevAddr ∷ Word8 → F Device+matchDevAddr addr = (addr ≡) ∘ deviceAddress