1 files changed, 148 insertions, 0 deletions
diff --git a/ocaml/lib/effects.ml b/ocaml/lib/effects.ml
new file mode 100644
index 0000000..1206201
--- /dev/null
+++ b/ocaml/lib/effects.ml
@@ -0,0 +1,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