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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2019       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

type color = [
  `DEFAULT
| `BLACK
| `RED
| `GREEN
| `YELLOW
| `BLUE
| `MAGENTA
| `CYAN
| `WHITE
| `LIGHT_BLACK
| `LIGHT_RED
| `LIGHT_GREEN
| `LIGHT_YELLOW
| `LIGHT_BLUE
| `LIGHT_MAGENTA
| `LIGHT_CYAN
| `LIGHT_WHITE
| `INDEX of int
| `RGB of (int * int * int)
]

type style = {
  fg_color : color option;
  bg_color : color option;
  bold : bool option;
  italic : bool option;
  underline : bool option;
  negative : bool option;
  prefix : string option;
  suffix : string option;
}

let set o1 o2 = match o1 with
| None -> o2
| Some _ ->
  match o2 with
  | None -> o1
  | Some _ -> o2

let default = {
  fg_color = None;
  bg_color = None;
  bold = None;
  italic = None;
  underline = None;
  negative = None;
  prefix = None;
  suffix = None;
}

let reset = "\027[0m"

let reset_style = {
  fg_color = Some `DEFAULT;
  bg_color = Some `DEFAULT;
  bold = Some false;
  italic = Some false;
  underline = Some false;
  negative = Some false;
  prefix = None;
  suffix = None;
}

let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style ?prefix ?suffix () =
  let st = match style with
  | None -> default
  | Some st -> st
  in
  {
    fg_color = set st.fg_color fg_color;
    bg_color = set st.bg_color bg_color;
    bold = set st.bold bold;
    italic = set st.italic italic;
    underline = set st.underline underline;
    negative = set st.negative negative;
    prefix = set st.prefix prefix;
    suffix = set st.suffix suffix;
  }

let merge s1 s2 =
  {
    fg_color = set s1.fg_color s2.fg_color;
    bg_color = set s1.bg_color s2.bg_color;
    bold = set s1.bold s2.bold;
    italic = set s1.italic s2.italic;
    underline = set s1.underline s2.underline;
    negative = set s1.negative s2.negative;
    prefix = set s1.prefix s2.prefix;
    suffix = set s1.suffix s2.suffix;
  }

let diff s1 s2 =
  let diff_op o1 o2 reset_val = match o1 with
  | None -> o2
  | Some _ ->
    match o2 with
    | None -> reset_val
    | Some _ -> if o1 = o2 then None else o2 in

  {
    fg_color = diff_op s1.fg_color s2.fg_color reset_style.fg_color;
    bg_color = diff_op s1.bg_color s2.bg_color reset_style.bg_color;
    bold = diff_op s1.bold s2.bold reset_style.bold;
    italic = diff_op s1.italic s2.italic reset_style.italic;
    underline = diff_op s1.underline s2.underline reset_style.underline;
    negative = diff_op s1.negative s2.negative reset_style.negative;
    prefix = diff_op s1.prefix s2.prefix reset_style.prefix;
    suffix = diff_op s1.suffix s2.suffix reset_style.suffix;
  }

let base_color = function
| `DEFAULT -> 9
| `BLACK -> 0
| `RED -> 1
| `GREEN -> 2
| `YELLOW -> 3
| `BLUE -> 4
| `MAGENTA -> 5
| `CYAN -> 6
| `WHITE -> 7
| `LIGHT_BLACK -> 0
| `LIGHT_RED -> 1
| `LIGHT_GREEN -> 2
| `LIGHT_YELLOW -> 3
| `LIGHT_BLUE -> 4
| `LIGHT_MAGENTA -> 5
| `LIGHT_CYAN -> 6
| `LIGHT_WHITE -> 7
| _ -> invalid_arg "base_color"

let extended_color off = function
| `INDEX i -> [off + 8; 5; i]
| `RGB (r, g, b) -> [off + 8; 2; r; g; b]
| _ -> invalid_arg "extended_color"

let is_light = function
| `LIGHT_BLACK
| `LIGHT_RED
| `LIGHT_GREEN
| `LIGHT_YELLOW
| `LIGHT_BLUE
| `LIGHT_MAGENTA
| `LIGHT_CYAN
| `LIGHT_WHITE -> true
| _ -> false

let is_extended = function
| `INDEX _ | `RGB _ -> true
| _ -> false

let repr st =
  let fg = match st.fg_color with
  | None -> []
  | Some c ->
    if is_light c then [90 + base_color c]
    else if is_extended c then extended_color 30 c
    else [30 + base_color c]
  in
  let bg = match st.bg_color with
  | None -> []
  | Some c ->
    if is_light c then [100 + base_color c]
    else if is_extended c then extended_color 40 c
    else [40 + base_color c]
  in
  let bold = match st.bold with
  | None -> []
  | Some true -> [1]
  | Some false -> [22]
  in
  let italic = match st.italic with
  | None -> []
  | Some true -> [3]
  | Some false -> [23]
  in
  let underline = match st.underline with
  | None -> []
  | Some true -> [4]
  | Some false -> [24]
  in
  let negative = match st.negative with
  | None -> []
  | Some true -> [7]
  | Some false -> [27]
  in
  fg @ bg @ bold @ italic @ underline @ negative

let eval st =
  let tags = repr st in
  let tags = List.map string_of_int tags in
  if List.length tags = 0 then "" else
    Printf.sprintf "\027[%sm" (String.concat ";" tags)

let has_style t =
  Unix.isatty t && Sys.os_type = "Unix"

let split c s =
  let len = String.length s in
  let rec split n =
    try
      let pos = String.index_from s n c in
      let dir = String.sub s n (pos-n) in
      dir :: split (succ pos)
    with
      | Not_found -> [String.sub s n (len-n)]
  in
  if len = 0 then [] else split 0

let check_char i = if i < 0 || i > 255 then invalid_arg "check_char"

let parse_color off rem = match off with
| 0 -> (`BLACK, rem)
| 1 -> (`RED, rem)
| 2 -> (`GREEN, rem)
| 3 -> (`YELLOW, rem)
| 4 -> (`BLUE, rem)
| 5 -> (`MAGENTA, rem)
| 6 -> (`CYAN, rem)
| 7 -> (`WHITE, rem)
| 9 -> (`DEFAULT, rem)
| 8 ->
  begin match rem with
  | 5 :: i :: rem ->
    check_char i;
    (`INDEX i, rem)
  | 2 :: r :: g :: b :: rem ->
    check_char r;
    check_char g;
    check_char b;
    (`RGB (r, g, b), rem)
  | _ -> invalid_arg "parse_color"
  end
| _ -> invalid_arg "parse_color"

let set_light = function
| `BLACK -> `LIGHT_BLACK
| `RED -> `LIGHT_RED
| `GREEN -> `LIGHT_GREEN
| `YELLOW -> `LIGHT_YELLOW
| `BLUE -> `LIGHT_BLUE
| `MAGENTA -> `LIGHT_MAGENTA
| `CYAN -> `LIGHT_CYAN
| `WHITE -> `LIGHT_WHITE
| _ -> invalid_arg "parse_color"

let rec parse_style style = function
| [] -> style
| 0 :: rem ->
  let style = merge style reset_style in
  parse_style style rem
| 1 :: rem ->
  let style = make ~style ~bold:true () in
  parse_style style rem
| 3 :: rem ->
  let style = make ~style ~italic:true () in
  parse_style style rem
| 4 :: rem ->
  let style = make ~style ~underline:true () in
  parse_style style rem
| 7 :: rem ->
  let style = make ~style ~negative:true () in
  parse_style style rem
| 22 :: rem ->
  let style = make ~style ~bold:false () in
  parse_style style rem
| 23 :: rem ->
  let style = make ~style ~italic:false () in
  parse_style style rem
| 24 :: rem ->
  let style = make ~style ~underline:false () in
  parse_style style rem
| 27 :: rem ->
  let style = make ~style ~negative:false () in
  parse_style style rem
| code :: rem when (30 <= code && code < 40) ->
  let color, rem = parse_color (code mod 10) rem in
  let style = make ~style ~fg_color:color () in
  parse_style style rem
| code :: rem when (40 <= code && code < 50) ->
  let color, rem = parse_color (code mod 10) rem in
  let style = make ~style ~bg_color:color () in
  parse_style style rem
| code :: rem when (90 <= code && code < 100) ->
  let color, rem = parse_color (code mod 10) rem in
  let style = make ~style ~fg_color:(set_light color) () in
  parse_style style rem
| code :: rem when (100 <= code && code < 110) ->
  let color, rem = parse_color (code mod 10) rem in
  let style = make ~style ~bg_color:(set_light color) () in
  parse_style style rem
| _ :: rem -> parse_style style rem

(** Parse LS_COLORS-like strings *)
let parse s =
  let defs = split ':' s in
  let fold accu s = match split '=' s with
  | [name; attrs] ->
    let attrs = split ';' attrs in
    let accu =
      try
        let attrs = List.map int_of_string attrs in
        let attrs = parse_style (make ()) attrs in
        (name, attrs) :: accu
      with _ -> accu
    in
    accu
  | _ -> accu
  in
  List.fold_left fold [] defs