Libify ocaml, add buttons to interaction.

1 files changed, 63 insertions, 0 deletions

diff --git a/discocaml/discocaml.ml b/discocaml/discocaml.ml
new file mode 100644
index 0000000..cd99c9a
--- /dev/null
+++ b/discocaml/discocaml.ml
@@ -0,0 +1,63 @@
+type command = [ `Roundtrip ]
+
+let command_of_yojson = function
+  | `String "Roundtrip" -> Ok `Roundtrip
+  | _ -> Error "invalid command"
+
+type request = { expr : string; command : command }
+[@@deriving of_yojson { exn = true }]
+
+type response_expr = { expr : string } [@@deriving to_yojson { exn = true }]
+
+type response = [ `Error of string | `Expr of response_expr ]
+[@@deriving to_yojson { exn = true }]
+
+let%expect_test _ =
+  Yojson.Safe.to_channel stdout (response_to_yojson (`Error "foo"));
+  [%expect {| ["Error","foo"] |}]
+
+let%expect_test _ =
+  Yojson.Safe.to_channel stdout (response_to_yojson (`Expr { expr = "foo" }));
+  [%expect {| ["Expr",{"expr":"foo"}] |}]
+(*
+type position = [%import: Lexing.position] [@@deriving show]
+
+type location = [%import: (Location.t[@with Lexing.position := position])]
+[@@deriving show]
+
+type constant = [%import: Parsetree.constant] [@@deriving show]
+type expression_desc = [%import: Parsetree.expression_desc] [@@deriving show]
+type expression = [%import: Parsetree.expression] [@@deriving show]
+
+type structure_item_desc = [%import: Parsetree.structure_item_desc]
+[@@deriving show]
+
+type structure_item = [%import: Parsetree.structure_item] [@@deriving show]
+type structure = [%import: Parsetree.structure] [@@deriving show]
+type toplevel_phrase = [%import: Parsetree.toplevel_phrase] [@@deriving show]
+
+let parse ~path (src : string) =
+  let buf = Lexing.from_string src in
+  buf.lex_start_p <- { buf.lex_start_p with pos_fname = path };
+  buf.lex_curr_p <- { buf.lex_curr_p with pos_fname = path };
+  Parse.expression buf
+
+let () =
+  parse ~path:"main.ml" " print_endline ((\"Hello, world!\") )"
+  |> Format.fprintf Format.std_formatter "\n%a\n" Pprintast.expression
+*)
+
+let handle_request { expr; command } : response =
+  try
+    let buf = Lexing.from_string expr in
+    let expr = Parse.expression buf in
+    match command with
+    | `Roundtrip ->
+        let buf = Buffer.create 16 in
+        (let fmt = Format.formatter_of_buffer buf in
+         Pprintast.expression fmt expr;
+         Format.pp_print_flush fmt ());
+        `Expr { expr = Buffer.contents buf }
+  with
+  | Failure msg -> `Error msg
+  | exn -> `Error ("uncaught exception: " ^ Printexc.to_string exn)