List USB devices' configurations in human readable format (similar to ls-usb)

gistfile1.hs

{-# LANGUAGE ScopedTypeVariables #-}

import System.USB
import Control.Monad (forM_, when)
import Data.Vector (toList, Vector)
import Control.Exception
import Text.PrettyPrint
import Control.Arrow hiding ((<+>))
import qualified Data.ByteString as BS
import Numeric
import Data.Char
import Data.List
import Text.Printf
import Data.Maybe (maybe)

main = do
    putStrLn "Scanning..."
    ctx <- newCtx
    devices <- fmap toList $ getDevices ctx
    mapM_ showDeviceConfigs devices
    putStrLn "Finished!"

showDeviceConfigs :: Device -> IO ()
showDeviceConfigs device =
    do description <- getDeviceDesc device
       print description
       let numConfigs = deviceNumConfigs description
       let showConfig = when (numConfigs > 0) $ do
               configs <- mapM (getConfigDesc device ) [0 .. numConfigs - 1]
               mapM_ (putStr . render . prettyShowConfigDesc) configs
       catch showConfig (\(e :: USBException) -> print "Exception occured")
       putStrLn ""

printList :: (Show a) => [a] -> IO ()
printList = mapM_ (\x -> print x >> putStrLn "")

layout2columns :: [(String, Doc)] -> Doc
layout2columns lst = vcat . map docF $ lst
    where
        firstColumnLength = maximum (map (length . fst) lst)
        docF (label, value) = 
            if isEmpty value
                then empty
                else text label $$ nest (firstColumnLength + 1) value

prettyShowEndpointAddress :: EndpointAddress -> Doc
prettyShowEndpointAddress address =
    text "#" <> int (endpointNumber address)
    <+> (text . show . transferDirection) address

prettyShowMaxPacketSize :: MaxPacketSize -> Doc
prettyShowMaxPacketSize packetSize =
    layout2columns (map (second ($ packetSize)) [
         ("max size:", int . maxPacketSize)
       , ("transactions:", text . show . transactionOpportunities)
      ])

prettyShowEndpointDesc :: EndpointDesc -> Doc
prettyShowEndpointDesc endpoint =
    layout2columns (map (second ($ endpoint)) [
         ("address:", prettyShowEndpointAddress . endpointAddress)
       , ("attributes:", text . show . endpointAttribs)
       , ("packet:", prettyShowMaxPacketSize . endpointMaxPacketSize)
       , ("interval:", showInterval . fromIntegral . endpointInterval)
       , ("refresh rate:", text . show . endpointRefresh)
       , ("synch address:", text . show . endpointSynchAddress)
       , ("extra:", prettyPrintByteString . endpointExtra)
      ])
  where
    showInterval i = hcat [int i, text "ms or ", int (i * 125), text "us"]

toHex :: (Integral a, Show a, PrintfArg a) => a -> String
toHex x = printf "0x%02x" x

prettyPrintByteString :: BS.ByteString -> Doc
prettyPrintByteString s =
    let stringRepr = show s
        hexRepr = intercalate " " $ map toHex $ BS.unpack s
    in if BS.null s
        then empty 
        else vcat [text stringRepr, text hexRepr]
    
prettyShowInterfaceDesc :: InterfaceDesc -> Doc
prettyShowInterfaceDesc interface =
    layout2columns (map (second ($ interface)) [
         ("class:", text . show . interfaceClass)
       , ("sub class:", text . show . interfaceSubClass)
       , ("protocol:", text . show . interfaceProtocol)
       , ("StrIx:", maybe empty (text . show) . interfaceStrIx)
       , ("extra:", prettyPrintByteString . interfaceExtra)
      ])
      $+$ (showEndpoints . toList . interfaceEndpoints $ interface)
  where showEndpoints = prettyShowList "Endpoint" prettyShowEndpointDesc
  
prettyShowConfigDesc :: ConfigDesc -> Doc
prettyShowConfigDesc config =
    layout2columns (map (second ($ config)) [
         ("value:", text . show . configValue)
       , ("StrIx:", maybe empty (text . show) . configStrIx)
       , ("attributes:", text . show . configAttribs)
       , ("max power:", (<> text "mA") . text . show . (*2) . configMaxPower)
       , ("extra:", prettyPrintByteString . configExtra)
      ])
    $+$ (showInterfaces . toList . configInterfaces $ config)
  where showInterfaces = prettyShowList "Interface" showInterfaceDesc
        showInterfaceDesc = prettyShowList "Alt interface" prettyShowInterfaceDesc . toList

prettyShowList :: String -> (a -> Doc) -> [a] -> Doc
prettyShowList label f =
    let docF (i, value) = firstPart $+$ secondPart
          where firstPart = hcat [text label, text " #", int i]
                secondPart = nest 4 (f value)
    in vcat . map docF . zip [0..]