ls-usb-0.1.0.6: PrettyDevList.hs
{-# LANGUAGE NoImplicitPrelude
, RankNTypes
, ScopedTypeVariables
, UnicodeSyntax
#-}
module PrettyDevList
( PPStyle(..)
, brightStyle, darkStyle
, ppDevices
) where
-- from ansi-wl-pprint:
import Text.PrettyPrint.ANSI.Leijen ( Doc, Pretty, SimpleDoc(..)
, (<+>), (<$>), (<>)
, align, char, dquotes, empty, fill, hcat
, hsep, indent, int, pretty, punctuate
, renderPretty, text, vcat
, bold, cyan, dullred, green, magenta
, oncyan, ongreen, onmagenta, onyellow, red
, underline, white, yellow
)
-- from base:
import Control.Exception ( catch )
import Control.Monad ( (>>=), fail, liftM, mapM, return )
import Data.Bool ( Bool(False, True) )
import Data.Char ( String, toLower )
import Data.Eq ( (==) )
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 )
import Data.Word ( Word8, Word16 )
import Prelude ( (+), fromIntegral, fromInteger, fromRational )
import System.IO ( IO )
import Text.Printf ( PrintfArg, printf )
import Text.Show ( Show, show )
-- from base-unicode-symbols:
import Control.Arrow.Unicode ( (⋙) )
import Data.Function.Unicode ( (∘) )
import Data.Eq.Unicode ( (≡) )
import Prelude.Unicode ( (⋅) )
-- from bytestring:
import Data.ByteString.Char8 ( ByteString, unpack )
-- from usb:
import System.USB.Descriptors ( DeviceDesc
, deviceClass, deviceConfigs
, deviceManufacturerStrIx
, deviceMaxPacketSize0, deviceNumConfigs
, deviceProductId, deviceProductStrIx
, deviceProtocol, deviceReleaseNumber
, deviceSerialNumberStrIx, deviceSubClass
, deviceUSBSpecReleaseNumber, deviceVendorId
, BCD4
, ConfigDesc
, configAttribs, configInterfaces
, configMaxPower, configNumInterfaces
, configStrIx, configValue
, DeviceStatus
, remoteWakeup, selfPowered
, InterfaceDesc
, interfaceAltSetting, interfaceClass
, interfaceEndpoints, interfaceNumber
, interfaceProtocol, interfaceStrIx
, interfaceSubClass
, EndpointDesc
, endpointAddress, endpointAttribs
, endpointInterval, endpointMaxPacketSize
, endpointRefresh, endpointSynchAddress
, EndpointAddress
, endpointNumber, transferDirection
, TransferDirection(In, Out)
, TransferType(Isochronous)
, Synchronization(NoSynchronization)
, Usage
, MaxPacketSize
, maxPacketSize, transactionOpportunities
, TransactionOpportunities(Zero, One, Two)
, LangId, StrIx
)
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
)
-------------------------------------------------------------------------------
-- 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
}
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 α → (USBException → IO α) → IO α
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
( withDevice dev $ \devH →
fmap (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 ( withDevice 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 → n → Doc
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
pid = deviceProductId desc
busDoc = ppAddr style $ busNumber dev
devAddrDoc = ppAddr style $ deviceAddress dev
return $ text "Bus" <+> busDoc
<+> text "Address" <+> 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
let desc = deviceDesc dev
descDoc ← ppDeviceDesc style db dev desc
langDoc ← ppLanguageList style db dev
let field' = field style
busDoc = ppAddr style $ busNumber dev
devAddrDoc = ppAddr style $ deviceAddress dev
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 usbNumStyle' ∷ ∀ α. Pretty α ⇒ α → Doc
usbNumStyle' = usbNumStyle style
field' = field 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
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
$ 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' ∷ ∀ α. Pretty α ⇒ α → Doc
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
(inEndpts, outEndpts) =
partition ((In ≡) ∘ transferDirection ∘ endpointAddress)
$ interfaceEndpoints ifDesc
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 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 α 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]
]
where field' = field s
instance PrettyStyle EndpointAddress where
pretty' s ea = usbNumStyle s (endpointNumber ea)
<+> char '-' <+> pretty' s (transferDirection ea)
instance PrettyStyle TransferDirection where
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
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 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