ls-usb-0.1.0.13: PrettyDevList.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module : PrettyDevList
Copyright : 2009–2012 Roel van Dijk
License : BSD3 (see the file LICENSE)
Maintainer : Roel van Dijk <vandijk.roel@gmail.com>
-}
module PrettyDevList
( DescribedDevice(..)
, PPStyle(..)
, brightStyle, darkStyle
, ppDevices
) where
--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------
import "ansi-wl-pprint" 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
)
import "base" Control.Exception ( catch )
import "base" Control.Monad ( (<=<), liftM, mapM, return )
import "base" Data.Bool ( Bool(False, True) )
import "base" Data.Char ( toLower )
import "base" Data.Function ( ($), id )
import "base" Data.Functor ( fmap )
import "base" Data.Int ( Int )
import "base" Data.List
( intersperse, length, map, maximum, partition, transpose, zipWith )
import "base" Data.Maybe ( Maybe(Nothing, Just), maybe )
import "base" Data.Word ( Word8, Word16 )
import "base" Prelude ( String, (+), (-), fromIntegral )
import "base" System.IO ( IO )
import "base" Text.Printf ( PrintfArg, printf )
import "base" Text.Show ( Show, show )
#if __GLASGOW_HASKELL__ < 700
import "base" Control.Monad ( (>>=), fail )
import "base" Data.Eq ( (==) )
import "base" Prelude ( fromInteger, fromRational )
#endif
import "base-unicode-symbols" Control.Arrow.Unicode ( (⋙) )
import "base-unicode-symbols" Data.Function.Unicode ( (∘) )
import "base-unicode-symbols" Data.Eq.Unicode ( (≡) )
import "base-unicode-symbols" Prelude.Unicode ( (⋅) )
import qualified "text" Data.Text as T ( Text, unpack )
import "usb" System.USB.Descriptors
import "usb" System.USB.DeviceHandling ( withDeviceHandle )
import "usb" System.USB.Enumeration
( Device, busNumber, deviceAddress )
import "usb" System.USB.Exceptions ( USBException )
import "usb-id-database" System.USB.IDDB
( IDDB
, vendorName, productName
, className, subClassName, protocolName
, langName, subLangName
)
import qualified "vector" Data.Vector as V ( length, toList )
data DescribedDevice = DD { device ∷ Device
, deviceDesc ∷ DeviceDesc
}
--------------------------------------------------------------------------------
-- 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 T.Text where
pretty = pretty ∘ T.unpack
instance Pretty Word8 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"
ppReleaseNumber ∷ ReleaseNumber → Doc
ppReleaseNumber (a, b, c, d) = hcat ∘ punctuate (char '.') $ map pretty [a, b, c, d]
ppStringDesc ∷ PPStyle → Device → Maybe StrIx → IO Doc
ppStringDesc _ _ Nothing = return empty
ppStringDesc style dev (Just ix) = catchUSBException
( withDeviceHandle 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 ( withDeviceHandle dev
$ fmap (hsep ∘ punctuate (text ", ") ∘ map (ppLanguage style db) ∘ V.toList)
∘ getLanguages
)
( return
∘ ppError style "Couldn't retrieve language list"
)
ppDevices ∷ PPStyle → IDDB → Bool → [DescribedDevice] → 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 → DescribedDevice → IO Doc
ppDeviceShort style db (DD dev desc) = do
let 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 → DescribedDevice → IO Doc
ppDevice style db (DD dev desc) = do
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 <=< getConfigDesc dev)
[0..numConfigs-1]
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' ∘ ppReleaseNumber
$ 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' ∘ ppReleaseNumber
$ 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) ∘ V.toList) $
V.toList 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' $ fromIntegral $ V.length ifDescs]
] <$> 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)
$ V.toList $ 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