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
|
open Noun
(** Effect parsing and routing *)
type blit =
| Lin of string (* Simple line of text *)
| Klr of noun (* Styled/colored text (TODO: parse structure) *)
| Mor of blit list (* Multiple blits *)
| Hop of int (* Cursor hop *)
| Clr (* Clear screen *)
| Unknown of noun (* Unparsed blit *)
type card =
| Blit of blit (* Terminal output *)
| Logo (* Show logo *)
| HttpResponse of noun (* HTTP response (TODO) *)
| Send of noun (* Network send (TODO) *)
| Unknown of noun (* Unknown card type *)
type effect = {
wire: noun;
card: card;
}
(** Convert atom to string if possible *)
let atom_to_string = function
| Atom z ->
if Z.equal z Z.zero then ""
else
let bits = Z.numbits z in
let bytes = (bits + 7) / 8 in
let buf = Bytes.create bytes in
let z_ref = ref z in
for i = 0 to bytes - 1 do
let byte = Z.to_int (Z.logand !z_ref (Z.of_int 0xFF)) in
Bytes.set buf i (Char.chr byte);
z_ref := Z.shift_right !z_ref 8
done;
Bytes.to_string buf
| Cell _ -> ""
(** Parse a blit from noun *)
let rec parse_blit = function
| Cell (tag, rest) -> begin
match tag with
| Atom z when Z.equal z (Z.of_string "0x6e696c") -> (* 'lin' *)
(* %lin format: [%lin text] where text is [flag styled] *)
begin match rest with
| Cell (Cell (_, text), _) ->
let str = atom_to_string text in
Lin str
| _ -> Unknown rest
end
| Atom z when Z.equal z (Z.of_string "0x726c6b") -> (* 'klr' *)
Klr rest
| Atom z when Z.equal z (Z.of_string "0x726f6d") -> (* 'mor' *)
(* %mor is a list of blits *)
let rec parse_list acc = function
| Atom z when Z.equal z Z.zero -> List.rev acc
| Cell (h, t) -> parse_list (parse_blit h :: acc) t
| _ -> List.rev acc
in
Mor (parse_list [] rest)
| Atom z when Z.equal z (Z.of_string "0x706f68") -> (* 'hop' *)
begin match rest with
| Atom n -> Hop (Z.to_int n)
| _ -> Unknown rest
end
| Atom z when Z.equal z (Z.of_string "0x726c63") -> (* 'clr' *)
Clr
| _ -> Unknown (Cell (tag, rest))
end
| Atom _ as a -> Unknown a
(** Parse a card from noun *)
let parse_card = function
| Cell (tag, rest) -> begin
match tag with
| Atom z when Z.equal z (Z.of_string "0x74696c62") -> (* 'blit' *)
Blit (parse_blit rest)
| Atom z when Z.equal z (Z.of_string "0x6f676f6c") -> (* 'logo' *)
Logo
| Atom z when Z.equal z (Z.of_string "0x65736e6f7073657220707474682d") -> (* 'http-response' (partial) *)
HttpResponse rest
| Atom z when Z.equal z (Z.of_string "0x646e6573") -> (* 'send' *)
Send rest
| _ -> Unknown (Cell (tag, rest))
end
| Atom _ as a -> Unknown a
(** Parse a single effect [wire card] *)
let parse_effect = function
| Cell (wire, card_noun) ->
Some { wire; card = parse_card card_noun }
| _ -> None
(** Parse effects list from noun *)
let rec parse_effects = function
| Atom z when Z.equal z Z.zero -> []
| Cell (h, t) ->
begin match parse_effect h with
| Some eff -> eff :: parse_effects t
| None -> parse_effects t
end
| _ -> []
(** Show wire for debugging *)
let rec show_wire = function
| Atom z when Z.equal z Z.zero -> "~"
| Cell (Atom a, rest) ->
"/" ^ atom_to_string (Atom a) ^ show_wire rest
| Cell (h, t) ->
"/" ^ show_noun h ^ show_wire t
| Atom a -> "/" ^ atom_to_string (Atom a)
and show_noun = function
| Atom z -> Z.to_string z
| Cell (h, t) -> "[" ^ show_noun h ^ " " ^ show_noun t ^ "]"
(** Show card for debugging *)
let show_card = function
| Blit (Lin s) -> Printf.sprintf "%%blit %%lin %S" s
| Blit (Mor bs) -> Printf.sprintf "%%blit %%mor (%d blits)" (List.length bs)
| Blit Clr -> "%blit %clr"
| Blit (Hop n) -> Printf.sprintf "%%blit %%hop %d" n
| Blit (Klr _) -> "%blit %klr (...)"
| Blit (Unknown _) -> "%blit (unknown)"
| Logo -> "%logo"
| HttpResponse _ -> "%http-response"
| Send _ -> "%send"
| Unknown _ -> "(unknown card)"
(** Filter effects by wire pattern *)
let is_dill_wire = function
| Cell (Atom d, Cell (Atom term, _)) ->
Z.equal d (Z.of_int (Char.code 'd')) &&
Z.equal term (Z.of_string "0x6d726574") (* 'term' *)
| _ -> false
let is_http_wire = function
| Cell (Atom g, _) ->
Z.equal g (Z.of_int (Char.code 'g'))
| _ -> false
let is_ames_wire = function
| Cell (Atom a, _) ->
Z.equal a (Z.of_int (Char.code 'a'))
| _ -> false
|
