package ansifmt

  1. Overview
  2. Docs

Source file Styling.ml

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
(** [Styling] encodes terminal styling as a CSS-like language. *)
open Internal

type t =
  { foreground : Color.t option
  ; background : Color.t option
  ; bold : bool
  ; dim : bool
  ; italic : bool
  ; underlined : bool
  }

let none : t =
  { foreground = None
  ; background = None
  ; bold = false
  ; dim = false
  ; italic = false
  ; underlined = false
  }
;;

let create
      ?(foreground : [< Color.t ] option)
      ?(background : [< Color.t ] option)
      ?(bold : bool = false)
      ?(dim : bool = false)
      ?(italic : bool = false)
      ?(underlined : bool = false)
      ()
  : t
  =
  let foreground = (foreground :> Color.t option) in
  let background = (background :> Color.t option) in
  { foreground; background; bold; dim; italic; underlined }
;;

let fg : [< Color.t ] -> t = fun foreground -> create ~foreground ()
let bg : [< Color.t ] -> t = fun background -> create ~background ()
let bold : t = { none with bold = true }
let dim : t = { none with dim = true }
let italic : t = { none with italic = true }
let underlined : t = { none with underlined = true }

let ( & ) left right =
  let foreground = Option.last_some left.foreground right.foreground in
  let background = Option.last_some left.background right.background in
  let bold = left.bold || right.bold in
  let dim = left.dim || right.dim in
  let italic = left.italic || right.italic in
  let underlined = left.underlined || right.underlined in
  { foreground; background; bold; dim; italic; underlined }
;;

let make_sgr_sequence (inner : string) : string = "\x1b[" ^ inner ^ "m"

let add_color_to_buffer
      (buffer : Buffer.t)
      (color : Color.t option)
      ~(ground : Color.Ground.t)
  : unit
  =
  match color with
  | None -> ()
  | Some color' ->
    Buffer.add_string buffer (make_sgr_sequence (Color.to_ansi ~ground color'))
;;

let to_ansi : t -> string = function
  | { foreground; background; bold; dim; italic; underlined } ->
    let buffer = Buffer.create 16 in
    if bold then Buffer.add_string buffer (make_sgr_sequence "1");
    if dim then Buffer.add_string buffer (make_sgr_sequence "2");
    if italic then Buffer.add_string buffer (make_sgr_sequence "3");
    if underlined then Buffer.add_string buffer (make_sgr_sequence "4");
    add_color_to_buffer buffer foreground ~ground:`Foreground;
    add_color_to_buffer buffer background ~ground:`Background;
    Buffer.contents buffer
;;

let wrap : contents:string -> t -> string =
  fun ~contents -> function
  | { foreground; background; bold; dim; italic; underlined } as styling ->
    let buffer = Buffer.create 16 in
    if bold || dim then Buffer.add_string buffer (make_sgr_sequence "22");
    if italic then Buffer.add_string buffer (make_sgr_sequence "23");
    if underlined then Buffer.add_string buffer (make_sgr_sequence "24");
    if Option.is_some foreground then Buffer.add_string buffer (make_sgr_sequence "39");
    if Option.is_some background then Buffer.add_string buffer (make_sgr_sequence "49");
    to_ansi styling ^ contents ^ Buffer.contents buffer
;;