Libify ocaml, add buttons to interaction.

4 files changed, 78 insertions, 46 deletions

diff --git a/discocaml/default.nix b/discocaml/default.nix
index 392c146..885a515 100644
--- a/discocaml/default.nix
+++ b/discocaml/default.nix
@@ -1,10 +1,11 @@
 { buildDunePackage, yojson, ocaml-compiler-libs, ppx_deriving
-, ppx_deriving_yojson, ppx_import, ppxlib }:
+, ppx_deriving_yojson, ppx_expect, ppxlib }:
 
 buildDunePackage {
   pname = "discocaml";
   version = "0.1.0";
   minimalOcamlVersion = "5.1";
   src = ./.;
-  buildInputs = [ ppx_deriving ppx_deriving_yojson ppx_import ppxlib yojson ];
+  buildInputs = [ ppx_deriving ppx_deriving_yojson ppx_expect ppxlib yojson ];
+  doCheck = true;
 }
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)
diff --git a/discocaml/dune b/discocaml/dune
index 695d78f..961fe70 100644
--- a/discocaml/dune
+++ b/discocaml/dune
@@ -1,9 +1,17 @@
+(library
+ (name discocaml)
+ (inline_tests)
+ (libraries compiler-libs.common yojson)
+ (modules discocaml)
+ (package discocaml)
+ (preprocess
+  (pps ppx_deriving.show ppx_deriving_yojson ppx_expect)))
+
 (executable
  (flags
   (:standard -cclib -static -cclib -lm))
- (libraries compiler-libs.common yojson)
+ (libraries discocaml yojson)
+ (modules main)
  (name main)
  (package discocaml)
- (preprocess
-  (staged_pps ppx_import ppx_deriving.show ppx_deriving_yojson))
  (public_name discocaml))
diff --git a/discocaml/main.ml b/discocaml/main.ml
index d9895f1..1f325e2 100644
--- a/discocaml/main.ml
+++ b/discocaml/main.ml
@@ -1,44 +1,4 @@
-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 = [ `Error of string ] [@@deriving to_yojson { exn = true }]
-
-(*
-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 =
-  match command with `Roundtrip -> `Error ("TODO: " ^ expr)
+open Discocaml
 
 let () =
   Yojson.Safe.from_channel stdin