ls-usb (empty) → 0.1
raw patch · 5 files changed
+620/−0 lines, 5 filesdep +ansi-wl-pprintdep +basedep +bytestringsetup-changed
Dependencies added: ansi-wl-pprint, base, bytestring, cmdargs, usb, usb-id-database
Files
- LICENSE +32/−0
- PrettyDevList.hs +427/−0
- Setup.hs +2/−0
- ls-usb.cabal +25/−0
- ls-usb.hs +134/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2009 Roel van Dijk, Bas van Dijk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The name of Roel van Dijk and Bas van Dijk and the names of+ contributors may NOT be used to endorse or promote products+ derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ PrettyDevList.hs view
@@ -0,0 +1,427 @@+{-# 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ls-usb.cabal view
@@ -0,0 +1,25 @@+name: ls-usb+version: 0.1+cabal-version: >= 1.6+build-type: Simple+stability: experimental+author: Roel van Dijk, Bas van Dijk+maintainer: vandijk.roel@gmail.com+copyright: 2009 Roel van Dijk, Bas van Dijk+license: BSD3+license-file: LICENSE+category: System+synopsis: List USB devices+description:+ A small utility that lists USB devices connected to your system.++executable ls-usb+ build-depends: ansi-wl-pprint == 0.5.*+ , base >= 4.0 && < 4.2+ , bytestring == 0.9.*+ , cmdargs == 0.1.*+ , usb == 0.1.*+ , usb-id-database == 0.4.*+ ghc-options: -O2 -Wall -fno-warn-orphans+ main-is: ls-usb.hs+ other-modules: PrettyDevList
+ ls-usb.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Control.Monad ( (>=>), filterM, liftM2 )+import PrettyDevList ( ppDevices+ , brightStyle, darkStyle+ )+import System.Console.CmdArgs+import System.IO ( stdout )+import System.USB+import System.USB.IDDB.LinuxUsbIdRepo ( staticDb )+import Text.PrettyPrint.ANSI.Leijen ( Doc, SimpleDoc(..)+ , displayIO+ , putDoc, renderPretty+ )++-------------------------------------------------------------------------------+-- Main++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+ { vid = def &= explicit & flag "vid" & typ "VID"+ & text "List devices with this VID"+ , pid = def &= explicit & flag "pid" & typ "PID"+ & text "List devices with this PID"+ , bus = def &= explicit & flag "b" & flag "bus" & typ "BUS"+ & text "List devices on this BUS"+ , address = def &= explicit & flag "a" & flag "address" & typ "ADDR"+ & text "List devices with this ADDRESS"+ , nocolour = def &= explicit & flag "nc" & flag "nocolour" & flag "nocolor"+ & text "Don't colour the output"+ , darker = def &= explicit & flag "dark"+ & text "Use darker colours (for bright backgrounds)"+ } &= prog "ls-usb"+ & 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, (C) Roel van Dijk 2009" [defaultOpts]+ verbose <- isLoud+ db <- staticDb+ ctx <- newCtx+ let style | darker opts = darkStyle+ | otherwise = brightStyle+ printDoc (not $ nocolour opts)+ =<< ppDevices style db verbose+ =<< filterM (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+ ]++-------------------------------------------------------------------------------+-- Filters++type F m a = a -> m Bool++-- Construct a filter combinator from a binary boolean operator.+boolBinOpToFComb :: Monad m => (Bool -> Bool -> Bool) -> F m a -> F m a -> F m a+boolBinOpToFComb op f g = \x -> liftM2 op (f x) (g x)++(<||>) :: Monad m => F m a -> F m a -> F m a+(<||>) = boolBinOpToFComb (||)++(<&&>) :: Monad m => F m a -> F m a -> F m a+(<&&>) = boolBinOpToFComb (&&)++constF :: Monad m => Bool -> F m a+constF = const . return++andF :: Monad m => [F m a] -> F m a+andF = foldr (<&&>) (constF True)++orF :: Monad m => [F m a] -> F m a+orF = foldr (<||>) (constF False)++filterNonEmpty :: Monad m => [F m a] -> F m a+filterNonEmpty [] = constF True+filterNonEmpty xs = foldr (<||>) (constF 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++matchPID :: ProductId -> F IO DeviceDesc+matchPID pid' desc = return $ pid' == deviceProductId desc++matchBus :: Int -> F IO Device+matchBus bus' dev = return+ . (bus' ==)+ . fromIntegral+ =<< getBusNumber dev++matchDevAddr :: Int -> F IO Device+matchDevAddr address' dev = return+ . (address' ==)+ . fromIntegral+ =<< getDeviceAddress dev++-------------------------------------------------------------------------------+-- Pretty printer utilities++printDoc :: Bool -> Doc -> IO ()+printDoc colour doc | colour = putDoc doc+ | otherwise = displayIO stdout+ . stripColours+ $ renderPretty 0.4 100 doc+ where+ stripColours :: SimpleDoc -> SimpleDoc+ stripColours e@(SEmpty) = e+ stripColours (SChar c d) = SChar c $ stripColours d+ stripColours (SText l s d) = SText l s $ stripColours d+ stripColours (SLine l d) = SLine l $ stripColours d+ stripColours (SSGR _ d) = stripColours d