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
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Trammel where
import Data.List
import Data.String
import Data.Monoid
import Data.Maybe (catMaybes)
import Data.Ix (inRange)
data Trammel a
= Plain a
| Gaudy [Int] (Trammel a)
| Append (Trammel a) (Trammel a)
| Empty
deriving (Eq, Show)
instance Monoid (Trammel a) where
mappend = Append
mempty = Empty
instance IsString a => IsString (Trammel a) where
fromString = Plain . fromString
data Color = AnsiColor Int | Xterm256 Int | XtermRGB Int Int Int
deriving (Eq, Show)
getColor :: Color -> [Int] -> Color
getColor c0 [] = c0
getColor c0 (c:s)
| inRange (30, 37) c = getColor (AnsiColor c) s
| c == 38 = case s of
(5:i:s') -> getColor (Xterm256 i) s'
(2:r:g:b:s') -> getColor (XtermRGB r g b) s'
_ -> getColor c0 s
| c == 39 = getColor (AnsiColor 39) s
| otherwise = getColor c0 s
toGR :: Color -> [Int]
toGR (AnsiColor i) = [i]
toGR (Xterm256 i) = [38,5,i]
toGR (XtermRGB r g b) = [38,2,r,g,b]
-- TODO maybe bold and underline could be simply Bools
type RenderState = [(Color,Int,Int)]
emptyRenderState :: RenderState
emptyRenderState = [(AnsiColor 39,22,24)]
renderString :: RenderState -> Trammel String -> String -> String
renderString _ (Plain s) y = s ++ y
renderString rs@((fc0, b0, u0):_) (Gaudy c t) y =
let fc = getColor fc0 c
b = f (`elem`[1,22]) b0 c
u = f (`elem`[4,24]) u0 c
gr = catMaybes $
( if fc /= fc0 then map Just (toGR fc) else [] ) ++
[ if b /= b0 then Just b else Nothing
, if u /= u0 then Just u else Nothing
]
ungr = catMaybes $
( if fc /= fc0 then map Just (toGR fc0) else [] ) ++
[ if b /= b0 then Just b0 else Nothing
, if u /= u0 then Just u0 else Nothing
]
in sgr gr ++ renderString ((fc, b, u):rs) t (sgr ungr ++ y)
where
f p alt xs =
case filter p xs of
[] -> alt
xs' -> last xs'
renderString _ (Gaudy _ _) _ =
error "renderString called w/o proper initial state"
-- where a proper initial state is s.th. like emptyRenderState
renderString r (Append t1 t2) y =
renderString r t1 $ renderString r t2 y
renderString _ Empty y = y
len :: Trammel String -> Int
len (Plain x) = length x
len (Gaudy _ x) = len x
len (Append t1 t2) = len t1 + len t2
len Empty = 0
pp :: Trammel String -> String
pp t = renderString emptyRenderState t ""
sgr :: [Int] -> String
sgr [] = []
sgr xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs
|
