{-# LANGUAGE PatternGuards, ViewPatterns, GeneralizedNewtypeDeriving #-} module Display ( TermColor , parseColor , rawErrMsg , Output(..) , runOutput ) where import Control.Concurrent (forkIO) import Control.Concurrent.Chan (newChan, readChan, writeChan) import qualified Data.ByteString.Char8 as BS import Data.Char (isDigit, isAlphaNum) import Data.List (stripPrefix) import Data.Monoid ((<>)) import System.IO (stdout, stderr, hPutStrLn) newtype TermColor = TermColor [Int] deriving (Monoid) displayColor :: TermColor -> BS.ByteString displayColor (TermColor []) = BS.empty displayColor (TermColor c) = esc <> BS.intercalate semi (map (BS.pack . show) c) `BS.snoc` 'm' where esc = BS.pack "\ESC[" semi = BS.singleton ';' displayResetColor :: BS.ByteString displayResetColor = displayColor colorReset isInteger :: String -> Bool isInteger [] = False isInteger x = all isDigit x colorReset :: TermColor colorReset = colorValue "reset" -- TODO: use terminfo! colorValue :: String -> TermColor colorValue "reset" = TermColor [0] colorValue "bo" = TermColor [1] --colorValue "dark" = TermColor [2] colorValue "so" = TermColor [3] colorValue "hl" = TermColor [3] colorValue "ul" = TermColor [4] colorValue "bl" = TermColor [5] colorValue "rev" = TermColor [7] colorValue "hidden" = TermColor [8] colorValue "nobo" = TermColor [22]--[21] --colorValue "nodark" = TermColor [22] colorValue "noso" = TermColor [23] colorValue "nohl" = TermColor [23] colorValue "noul" = TermColor [24] colorValue "nobl" = TermColor [25] colorValue "norev" = TermColor [27] colorValue "nohidden" = TermColor [28] colorValue "black" = TermColor [30] colorValue "red" = TermColor [31] colorValue "green" = TermColor [32] colorValue "yellow" = TermColor [33] colorValue "blue" = TermColor [34] colorValue "magenta" = TermColor [35] colorValue "cyan" = TermColor [36] colorValue "white" = TermColor [37] colorValue "default" = TermColor [39] colorValue ('c':'o':'l':'o':'r':n) | isInteger n = TermColor [38,5,read n] colorValue ('m':'o':'d':'e':n) | isInteger n = TermColor [read n] colorValue ('b':'r':'i':'g':'h':'t':(colorValue -> TermColor [n])) | n >= 30 && n < 40 = TermColor [60 + n] colorValue ('b':'r':(colorValue -> TermColor [n])) | n >= 30 && n < 40 = TermColor [60 + n] colorValue ('/':(colorValue -> TermColor (n:r))) = TermColor $ 10+n:r colorValue "normal" = colorValue "reset" colorValue "bold" = colorValue "bo" colorValue "nobold" = colorValue "nobo" colorValue "dim" = colorValue "dark" colorValue "nodim" = colorValue "nodark" colorValue "standout" = colorValue "so" colorValue "nostandout" = colorValue "noso" colorValue "hilite" = colorValue "hl" colorValue "nohilite" = colorValue "nohl" colorValue "underline" = colorValue "ul" colorValue "nounderline"= colorValue "noul" colorValue "blink" = colorValue "bl" colorValue "noblink" = colorValue "nobl" colorValue "reverse" = colorValue "rev" colorValue "noreverse" = colorValue "norev" colorValue x = error ("unknown color name: " ++ x) colorSep :: Char -> Bool colorSep = not . isAlphaNum parseColor :: String -> TermColor parseColor [] = mempty parseColor s@(c:s') | colorSep c = parseColor s' | otherwise = colorValue x <> parseColor r where (x, r) = break colorSep s displayColorFrom :: TermColor -> TermColor -> BS.ByteString displayColorFrom (TermColor o) c@(TermColor n) | Just d <- stripPrefix o n = displayColor $ TermColor d | otherwise = displayColor $ colorReset <> c rawErrMsg :: String -> IO () rawErrMsg m = BS.hPutStr stderr displayResetColor >> hPutStrLn stderr m data Output = OutputLine { outputColor :: !TermColor , outputText :: !BS.ByteString } | OutputError { outputText :: !BS.ByteString } runOutput :: IO (Output -> IO ()) runOutput = do chan <- newChan let loop p = do o <- readChan chan let (h, c, t) = case o of OutputLine{ outputColor = c', outputText = t' } -> (stdout, c', t') OutputError{ outputText = t' } -> (stderr, mempty, t') BS.hPutStr h $ displayColorFrom p c BS.hPutStrLn h t loop c _ <- forkIO $ loop mempty return $ writeChan chan