multi color filter tail

root / Display.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
{-# 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