ztail-1.2: Display.hs

{-# 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