diff --git a/PrettyDevList.hs b/PrettyDevList.hs --- a/PrettyDevList.hs +++ b/PrettyDevList.hs @@ -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 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.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 diff --git a/ls-usb.hs b/ls-usb.hs --- a/ls-usb.hs +++ b/ls-usb.hs @@ -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