{-# LANGUAGE RankNTypes #-} module PrettyDevList ( PPStyle(..) , brightStyle, darkStyle , ppDevices ) where import Prelude hiding ( catch ) import Control.Arrow ( (>>>) ) import Control.Exception ( catch ) import Control.Monad ( liftM, mapM ) import Data.ByteString.Char8 ( ByteString, unpack ) import Data.Char ( toLower ) import Data.List ( intersperse, transpose ) import Data.Word ( Word8, Word16 ) import System.USB import System.USB.IDDB ( IDDB , vendorName, productName , className, subClassName, protocolName , langName, subLangName ) import Text.PrettyPrint.ANSI.Leijen import Text.Printf ( PrintfArg, printf ) ------------------------------------------------------------------------------- -- 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 } brightStyle :: PPStyle brightStyle = PPStyle { sectionStyle = pretty >>> white >>> bold >>> underline , fieldStyle = pretty , usbNumStyle = pretty >>> yellow , usbStrStyle = pretty , stringStyle = pretty >>> green , descrStyle = pretty >>> cyan >>> dquotes , descrAddrStyle = pretty >>> cyan >>> bold , versionStyle = pretty >>> yellow , addrStyle = pretty >>> magenta , errorStyle = pretty >>> red , errorDescrStyle = pretty >>> dullred } darkStyle :: PPStyle darkStyle = PPStyle { sectionStyle = pretty >>> bold >>> underline , fieldStyle = pretty , usbNumStyle = pretty >>> onyellow , usbStrStyle = pretty , stringStyle = pretty >>> ongreen , descrStyle = pretty >>> oncyan >>> dquotes , descrAddrStyle = pretty >>> oncyan >>> bold , versionStyle = pretty >>> onyellow , addrStyle = pretty >>> onmagenta , errorStyle = pretty >>> red , errorDescrStyle = pretty >>> dullred } ------------------------------------------------------------------------------- field :: PPStyle -> String -> [Doc] -> [Doc] field style name xs = (fieldStyle style $ (text name) <> char ':') : xs section :: PPStyle -> String -> Doc section style = sectionStyle style . text ------------------------------------------------------------------------------- -- Some basic instances of the Pretty class instance Pretty ByteString where pretty = pretty . unpack instance Pretty Word8 where pretty = int . fromIntegral instance Pretty Word16 where pretty = int . fromIntegral ------------------------------------------------------------------------------- -- Miscellaneous pretty printing functions columns :: Int -> [[Doc]] -> Doc columns s rows = vcat $ map ( hcat . zipWith fill (map (+s) $ columnSizes rows) ) rows 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 where sdocLen :: SimpleDoc -> Int sdocLen (SEmpty) = 0 sdocLen (SChar _ d) = 1 + sdocLen d sdocLen (SText i _ d) = i + sdocLen d sdocLen (SLine i d) = i + sdocLen d sdocLen (SSGR _ d) = sdocLen d ------------------------------------------------------------------------------- -- USB utility functions stringBufferSize :: Int stringBufferSize = 512 catchUSBException :: IO a -> (USBException -> IO a) -> IO a catchUSBException = catch ------------------------------------------------------------------------------- -- Pretty printers for USB types unknown :: Doc unknown = text "unknown" ppBCD4 :: BCD4 -> Doc ppBCD4 (a, b, c, d) = hcat . punctuate (char '.') $ map pretty [a, b, c, d] ppStringDesc :: PPStyle -> Device -> StrIx -> IO Doc ppStringDesc _ _ 0 = return empty ppStringDesc style dev ix = catchUSBException ( withDeviceHandle dev $ \devH -> liftM (descrStyle style) $ getStrDescFirstLang devH ix stringBufferSize ) (return . ppError style "Couldn't retrieve string descriptor") 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) 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) $ productName db vid' pid' where vid' = fromIntegral vid pid' = fromIntegral pid 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 _ _ 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 _ _ 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 style db cid = maybe unknown (stringStyle style) $ className db cid' where cid' = fromIntegral cid 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 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 style db (lid, slid) = 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 style db dev = catchUSBException ( withDeviceHandle dev $ fmap (hsep . punctuate (text ", ") . map (ppLanguage style db)) . getLanguages ) ( return . 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) ppAddr :: PrintfArg n => PPStyle -> IO n -> IO Doc ppAddr style a = let toDoc = addrStyle style :: String -> Doc in fmap (toDoc . printf "%03d") a 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 return $ text "Bus" <+> busDoc <+> text "Device" <+> devAddrDoc <> char ':' <+> text "ID" <+> (usbNumStyle style) (ppId vid) <> char ':' <> (usbNumStyle style) (ppId pid) <+> ppVendorName style db vid (<+> ppProductName style db vid pid (char '-' <+>)) 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 field' = field style return $ section style "Device" <$> indent 2 ( columns 2 [ field' "Bus" [busDoc] , field' "Address" [devAddrDoc] , field' "Supported languages" [langDoc] ] <$> section style "Device descriptor" <$> indent 2 descDoc ) ppDeviceDesc :: PPStyle -> IDDB -> Device -> DeviceDesc -> IO Doc ppDeviceDesc style db dev desc = do let field' = field style usbNumStyle' :: forall a. Pretty a => a -> Doc usbNumStyle' = usbNumStyle style versionStyle' = versionStyle style descrAddrStyle' = descrAddrStyle style manufacturerIx = deviceManufacturerStrIx desc productIx = deviceProductStrIx desc serialIx = deviceSerialNumberStrIx desc numConfigs = deviceNumConfigs desc classId = deviceClass desc subClassId = deviceSubClass desc protocolId = deviceProtocol desc 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 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 $ deviceUSBSpecReleaseNumber desc ] , field' "Class" [usbNumStyle' classId, classDoc] , field' "Sub class" [usbNumStyle' subClassId, subClassDoc] , field' "Protocol" [usbNumStyle' protocolId, protocolDoc] , field' "Max packet size" [usbNumStyle' $ deviceMaxPacketSize0 desc] , field' "Vendor ID" [ usbNumStyle' $ text "0x" <> ppId vendorId , ppVendorName style db vendorId id ] , field' "Product ID" [ usbNumStyle' $ text "0x" <> ppId productId , ppProductName style db vendorId productId id ] , 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" <$> indent 2 d) configDocs ) 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 let vcatAlts = (<$>) (section style "Interface") . 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' "Num interfaces" [usbNumStyle' $ configNumInterfaces conf] ] <$> vcat (map vcatAlts ifDescDocs) ppInterfaceDesc :: PPStyle -> IDDB -> Device -> InterfaceDesc -> IO Doc ppInterfaceDesc style db dev ifDesc = do let field' = field style usbNumStyle' = usbNumStyle style stringIx = interfaceStrIx ifDesc classId = interfaceClass ifDesc subClassId = interfaceSubClass ifDesc protocolId = interfaceProtocol ifDesc classDoc = ppClass style db classId subClassDoc = ppSubClass style db classId subClassId protocolDoc = ppProtocol style db classId subClassId protocolId strDesc <- ppStringDesc style dev stringIx return $ columns 2 [ field' "Interface number" [usbNumStyle' $ interfaceNumber ifDesc] , field' "Alternative setting" [usbNumStyle' $ interfaceAltSetting ifDesc] , field' "Class" [usbNumStyle' classId, classDoc] , 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 ) ------------------------------------------------------------------------------- -- 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] ] 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)] ] where field' = field s instance PrettyStyle EndpointAddress where pretty' s ea = usbNumStyle s (endpointNumber ea) <+> char '-' <+> pretty' s (endpointDirection 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" instance PrettyStyle Synchronization where pretty' s NoSynchronization = usbStrStyle s "no synchronization" pretty' s es = usbStrStyle s . map toLower $ show es instance Pretty Usage where pretty = text . map toLower . show instance PrettyStyle MaxPacketSize where pretty' s mps = usbNumStyle s (maxPacketSize mps) <+> char '-' <+> 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" 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