package hardcaml_waveterm

You can search for identifiers within the package.

in-package search v0.2.0

A terminal based digital waveform viewer for Hardcaml

Install

Dune Dependency

github.com Readme Changelog MIT License Edit opam file Versions (6)

Authors

J

Jane Street Group, LLC

Maintainers

J

Jane Street developers

Sources

hardcaml_waveterm-v0.16.0.tar.gz

sha256=20844546139ee69e8d328b75a54369b2c1db91d88e43f7ca9ccfc0cd855be828

doc/src/hardcaml_waveterm.kernel/write.ml.html

Source file `write.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
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
open Base

type styler =
  { start : (string -> unit) -> unit
  ; set : (string -> unit) -> Draw.Style.t -> unit
  ; eol : (string -> unit) -> unit
  ; finish : (string -> unit) -> unit
  }

let no_styler =
  { start = (fun _ -> ())
  ; set = (fun _ _ -> ())
  ; eol = (fun _ -> ())
  ; finish = (fun _ -> ())
  }
;;

open Draw.Style

let str_of_colour = function
  | Black -> "black"
  | Red -> "red"
  | Green -> "green"
  | Yellow -> "yellow"
  | Blue -> "blue"
  | Magenta -> "magenta"
  | Cyan -> "cyan"
  | White -> "white"
;;

let int_of_colour = function
  | Black -> 0
  | Red -> 1
  | Green -> 2
  | Yellow -> 3
  | Blue -> 4
  | Magenta -> 5
  | Cyan -> 6
  | White -> 7
;;

let html_styler =
  let prev = ref default in
  let set_style style os =
    os
      (Printf.sprintf
         "<span style=\"background-color:%s; color:%s; font-weight:%s\">"
         (str_of_colour style.bg)
         (str_of_colour style.fg)
         (if style.bold then "bold" else "normal"))
  in
  let close_style os = os "</span>" in
  { start =
      (fun os ->
         prev := default;
         set_style default os)
  ; set =
      (fun os style ->
         if Draw.Style.compare style !prev <> 0
         then (
           prev := style;
           close_style os;
           set_style style os))
  ; eol = (fun _ -> ())
  ; finish = close_style
  }
;;

let css_class_styler =
  let prev = ref default in
  let set_style style os =
    os
      (Printf.sprintf
         "<span class=\"w%i%i%s\">"
         (int_of_colour style.bg)
         (int_of_colour style.fg)
         (if style.bold then "b" else ""))
  in
  let close_style os = os "</span>" in
  { start =
      (fun os ->
         prev := default;
         set_style default os)
  ; set =
      (fun os style ->
         if Draw.Style.compare style !prev <> 0
         then (
           prev := style;
           close_style os;
           set_style style os))
  ; eol = (fun _ -> ())
  ; finish = close_style
  }
;;

let css_classes =
  let css fg bg b =
    Printf.sprintf
      ".w%i%i%s { background-color:%s; color:%s; font-weight:%s; }"
      (int_of_colour bg)
      (int_of_colour fg)
      (if b then "b" else "")
      (str_of_colour bg)
      (str_of_colour fg)
      (if b then "bold" else "normal")
  in
  let colours = [ Black; Red; Green; Yellow; Blue; Magenta; Cyan; White ] in
  let mapcat f = String.concat ~sep:"\n" (List.map colours ~f) in
  mapcat (fun fg -> mapcat (fun bg -> css fg bg false ^ "\n" ^ css fg bg true))
;;

let term_styler =
  let prev = ref None in
  let set_style style os =
    os
      (Printf.sprintf
         "\027[%i;%i%sm"
         (int_of_colour style.bg + 40)
         (int_of_colour style.fg + 30)
         (if style.bold then ";1" else ""))
  in
  let close_style os = os "\027[0m" in
  { start = (fun _ -> prev := None)
  ; set =
      (fun os style ->
         let set_style () =
           prev := Some style;
           set_style style os
         in
         match !prev with
         | Some prev' when Draw.Style.compare style prev' <> 0 -> set_style ()
         | None -> set_style ()
         | _ -> ())
  ; eol =
      (fun os ->
         prev := None;
         close_style os)
  ; finish = close_style
  }
;;

let html_escape ?(styler = no_styler) os ctx =
  let open Draw.In_memory in
  let bounds = get_bounds ctx in
  styler.start os;
  for r = 0 to bounds.h - 1 do
    for c = 0 to bounds.w - 1 do
      (* TODO styling *)
      let code = fst ctx.(r).(c) in
      styler.set os (snd ctx.(r).(c));
      os ("&#" ^ Int.to_string code)
    done;
    styler.eol os;
    os "\n"
  done;
  styler.finish os
;;

let utf8 ?(styler = no_styler) os ctx =
  let open Draw.In_memory in
  let put c =
    if c <= 0x7f
    then os (String.init 1 ~f:(fun _ -> Char.of_int_exn c))
    else if c <= 0x7FF
    then
      os
        (String.init 2 ~f:(function
           | 0 -> Char.of_int_exn ((c lsr 6) lor 0b11000000)
           | _ -> Char.of_int_exn (c land 0b00111111 lor 0b10000000)))
    else if c <= 0xFFFF
    then
      os
        (String.init 3 ~f:(function
           | 0 -> Char.of_int_exn ((c lsr 12) lor 0b11100000)
           | 1 -> Char.of_int_exn ((c lsr 6) land 0b00111111 lor 0b10000000)
           | _ -> Char.of_int_exn (c land 0b00111111 lor 0b10000000)))
    else failwith "extend utf-8 writer!"
  in
  let bounds = get_bounds ctx in
  styler.start os;
  for r = 0 to bounds.h - 1 do
    for c = 0 to bounds.w - 1 do
      styler.set os (snd ctx.(r).(c));
      put (fst ctx.(r).(c))
    done;
    styler.eol os;
    os "\n"
  done;
  styler.finish os
;;