diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/PrettyDevList.hs b/PrettyDevList.hs new file mode 100644 --- /dev/null +++ b/PrettyDevList.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ls-usb.cabal b/ls-usb.cabal new file mode 100644 --- /dev/null +++ b/ls-usb.cabal @@ -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 diff --git a/ls-usb.hs b/ls-usb.hs new file mode 100644 --- /dev/null +++ b/ls-usb.hs @@ -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