blob: 2140fa5e4fa729d27c9ac524528139075066c04f (
plain)
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
|
type command = [ `Parse | `DrawTree | `RunCBN | `RunCBV | `StepCBN | `StepCBV ]
let command_of_yojson = function
| `String "Parse" -> Ok `Parse
| `String "DrawTree" -> Ok `DrawTree
| `String "RunCBN" -> Ok `RunCBN
| `String "RunCBV" -> Ok `RunCBV
| `String "StepCBN" -> Ok `StepCBN
| `String "StepCBV" -> Ok `StepCBV
| _ -> Error "invalid command"
type request = { expr : string; command : command }
[@@deriving of_yojson { exn = true }]
type response_expr = { expr : string; has_redex : bool }
[@@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"; has_redex = false }));
[%expect {| ["Expr",{"expr":"foo","has_redex":false}] |}]
let handle_request { expr; command } : response =
try
let buf = Lexing.from_string expr in
let expr = Parse.expression buf in
let expr = Ast.expr_of_parsetree expr in
let expr_response (expr : Ast.expr) : response =
let buf = Buffer.create 16 in
(let fmt = Format.formatter_of_buffer buf in
Pprintast.expression fmt (Ast.parsetree_of_expr expr);
Format.pp_print_flush fmt ());
let has_redex = Option.is_some (Eval.find_redex_cbn expr) in
`Expr { expr = Buffer.contents buf; has_redex }
in
let step_with (find_redex : Ast.expr -> Eval.path option) (expr : Ast.expr)
: Ast.expr =
match find_redex expr with
| Some path -> Eval.reduce expr path
| None -> failwith "no redex"
in
match command with
| `Parse -> expr_response expr
| `StepCBN -> expr_response (step_with Eval.find_redex_cbn expr)
| `StepCBV -> expr_response (step_with Eval.find_redex_cbv expr)
| `DrawTree | `RunCBN | `RunCBV -> failwith "not implemented"
with
| Failure msg -> `Error msg
| exn -> `Error ("uncaught exception: " ^ Printexc.to_string exn)
|
