From f75b8de8313be95aae72ae93ccb0f402fa79c593 Mon Sep 17 00:00:00 2001
From: Jay Lee <jaeho.lee@snu.ac.kr>
Date: Sat, 21 Dec 2024 05:40:40 +0900
Subject: [PATCH] :truck: Move domain-related modules into a package

This improves modularity, as well as preprocessing only the
domain-related code via PPX. PPX does not support effect syntax yet, so
the code using the effect syntax should not be PPX-rewritten.
---
 .ocamlformat                          |  1 +
 bin/js/main.ml                        |  3 +-
 bin/js/string_recorder.ml             |  1 +
 bin/native/main.ml                    | 11 +++---
 bin/native/report_box_recorder.ml     |  1 +
 lib/{ => domains}/batched_queue.ml    |  0
 lib/{ => domains}/concrete_domains.ml |  0
 lib/{ => domains}/domains.ml          |  0
 lib/domains/dune                      | 11 ++++++
 lib/{ => domains}/lexer.mll           |  0
 lib/{ => domains}/parser.mly          |  0
 lib/{ => domains}/sexp_helper.ml      |  0
 lib/{ => domains}/snoc_list.ml        |  0
 lib/{ => domains}/syntax.ml           | 52 +++++++++++++++++++++++----
 lib/dune                              | 10 +-----
 lib/interp.ml                         |  1 +
 lib/interp_effects.ml                 | 43 +++++++++++-----------
 lib/js_syntax.ml                      |  1 +
 lib/logger.ml                         |  1 +
 lib/util.ml                           | 40 ---------------------
 20 files changed, 93 insertions(+), 83 deletions(-)
 rename lib/{ => domains}/batched_queue.ml (100%)
 rename lib/{ => domains}/concrete_domains.ml (100%)
 rename lib/{ => domains}/domains.ml (100%)
 create mode 100644 lib/domains/dune
 rename lib/{ => domains}/lexer.mll (100%)
 rename lib/{ => domains}/parser.mly (100%)
 rename lib/{ => domains}/sexp_helper.ml (100%)
 rename lib/{ => domains}/snoc_list.ml (100%)
 rename lib/{ => domains}/syntax.ml (81%)

diff --git a/.ocamlformat b/.ocamlformat
index f805ba7..b3c8180 100644
--- a/.ocamlformat
+++ b/.ocamlformat
@@ -1,2 +1,3 @@
 profile = default
 wrap-comments = true
+ocaml-version = 5.3
diff --git a/bin/js/main.ml b/bin/js/main.ml
index 9fd50d7..b9b5f2d 100644
--- a/bin/js/main.ml
+++ b/bin/js/main.ml
@@ -1,5 +1,6 @@
 open! Base
 open React_trace
+open Lib_domains
 
 let position (lexbuf : Lexing.lexbuf) : string =
   let open Lexing in
@@ -36,6 +37,6 @@ let () =
               prog
           in
           if Logs.err_count () > 0 then Error "error" else Ok recording)
-         |> (function Ok s -> s | Error s -> s)
+         |> ( function Ok s -> s | Error s -> s )
          |> Js.string
     end)
diff --git a/bin/js/string_recorder.ml b/bin/js/string_recorder.ml
index 1dc1c3e..dc39c2b 100644
--- a/bin/js/string_recorder.ml
+++ b/bin/js/string_recorder.ml
@@ -2,6 +2,7 @@ open! Base
 open Stdlib.Effect
 open Stdlib.Effect.Deep
 open React_trace
+open Lib_domains
 open Concrete_domains
 open Interp_effects
 include Recorder_intf
diff --git a/bin/native/main.ml b/bin/native/main.ml
index e319c93..f91193f 100644
--- a/bin/native/main.ml
+++ b/bin/native/main.ml
@@ -1,6 +1,7 @@
 open! Base
 open Stdio
 open React_trace
+open Lib_domains
 
 let print_position (outx : Out_channel.t) (lexbuf : Lexing.lexbuf) : unit =
   let open Lexing in
@@ -60,11 +61,11 @@ let () =
   Arg.parse speclist (fun x -> filename := x) usage_msg;
   if String.is_empty !filename then Arg.usage speclist usage_msg
   else if !opt_parse_js then failwith "Not implemented"
-    (* (let js_syntax, _ = Js_syntax.parse !filename in *)
-    (* print_endline (Js_syntax.show js_syntax); *)
-    (* let prog = Js_syntax.convert js_syntax in *)
-    (* Sexp.pp_hum Stdlib.Format.std_formatter (Syntax.Prog.sexp_of_t prog)) *)
-  else (
+  (* (let js_syntax, _ = Js_syntax.parse !filename in *)
+  (* print_endline (Js_syntax.show js_syntax); *)
+  (* let prog = Js_syntax.convert js_syntax in *)
+  (* Sexp.pp_hum Stdlib.Format.std_formatter (Syntax.Prog.sexp_of_t prog)) *)
+    else (
     Fmt_tty.setup_std_outputs ();
     Logs.set_reporter (Logs_fmt.reporter ());
     Logs.set_level (Some !opt_verbosity);
diff --git a/bin/native/report_box_recorder.ml b/bin/native/report_box_recorder.ml
index 8f8c9ea..54a3e94 100644
--- a/bin/native/report_box_recorder.ml
+++ b/bin/native/report_box_recorder.ml
@@ -3,6 +3,7 @@ open Stdlib.Effect
 open Stdlib.Effect.Deep
 open React_trace
 open Interp_effects
+open Lib_domains
 open Concrete_domains
 include Recorder_intf
 module B = PrintBox
diff --git a/lib/batched_queue.ml b/lib/domains/batched_queue.ml
similarity index 100%
rename from lib/batched_queue.ml
rename to lib/domains/batched_queue.ml
diff --git a/lib/concrete_domains.ml b/lib/domains/concrete_domains.ml
similarity index 100%
rename from lib/concrete_domains.ml
rename to lib/domains/concrete_domains.ml
diff --git a/lib/domains.ml b/lib/domains/domains.ml
similarity index 100%
rename from lib/domains.ml
rename to lib/domains/domains.ml
diff --git a/lib/domains/dune b/lib/domains/dune
new file mode 100644
index 0000000..71ad4f6
--- /dev/null
+++ b/lib/domains/dune
@@ -0,0 +1,11 @@
+(library
+ (name lib_domains)
+ (preprocess
+  (pps ppx_jane))
+ (libraries base logs ppx_jane))
+
+(ocamllex lexer)
+
+(menhir
+ (modules parser)
+ (flags --dump))
diff --git a/lib/lexer.mll b/lib/domains/lexer.mll
similarity index 100%
rename from lib/lexer.mll
rename to lib/domains/lexer.mll
diff --git a/lib/parser.mly b/lib/domains/parser.mly
similarity index 100%
rename from lib/parser.mly
rename to lib/domains/parser.mly
diff --git a/lib/sexp_helper.ml b/lib/domains/sexp_helper.ml
similarity index 100%
rename from lib/sexp_helper.ml
rename to lib/domains/sexp_helper.ml
diff --git a/lib/snoc_list.ml b/lib/domains/snoc_list.ml
similarity index 100%
rename from lib/snoc_list.ml
rename to lib/domains/snoc_list.ml
diff --git a/lib/syntax.ml b/lib/domains/syntax.ml
similarity index 81%
rename from lib/syntax.ml
rename to lib/domains/syntax.ml
index b46f606..88abb2a 100644
--- a/lib/syntax.ml
+++ b/lib/domains/syntax.ml
@@ -1,13 +1,53 @@
 open! Base
 
+module Map_key (T : sig
+  type t
+
+  val sexp_of_t : t -> Sexp.t
+  val t_of_sexp : Sexp.t -> t
+  val of_string : string -> t
+  val to_string : t -> string
+  val ( <= ) : t -> t -> bool
+  val ( >= ) : t -> t -> bool
+  val ( = ) : t -> t -> bool
+  val ( < ) : t -> t -> bool
+  val ( > ) : t -> t -> bool
+  val ( <> ) : t -> t -> bool
+  val compare : t -> t -> int
+  val min : t -> t -> t
+  val max : t -> t -> t
+  val ascending : t -> t -> int
+  val descending : t -> t -> int
+  val between : t -> low:t -> high:t -> bool
+  val clamp_exn : t -> min:t -> max:t -> t
+  val clamp : t -> min:t -> max:t -> t Or_error.t
+
+  type comparator_witness
+
+  val comparator : (t, comparator_witness) Comparator.t
+  val hash : t -> int
+  val equal : t -> t -> bool
+end) =
+struct
+  include T
+
+  module Map = struct
+    open Map
+    include M (T)
+
+    let empty = empty (module T)
+    let sexp_of_t sexp_of_v t = Map.sexp_of_m__t (module T) sexp_of_v t
+  end
+end
+
 module Id = struct
-  include Util.Map_key (String)
+  include Map_key (String)
 
   let unit = "()"
 end
 
 module Label = struct
-  include Util.Map_key (Int)
+  include Map_key (Int)
 end
 
 module Expr = struct
@@ -62,15 +102,15 @@ module Expr = struct
   let rec hook_free (expr : some_expr) : hook_free t option =
     let (Ex { desc; loc }) = expr in
     let mk = mk ~loc in
-    let open Option.Let_syntax in
+    let ( let* ) x f = Option.bind x ~f in
     match desc with
     | Let ({ body; _ } as e) ->
-        let%bind body = hook_free (Ex body) in
+        let* body = hook_free (Ex body) in
         Some (mk (Let { e with body }))
     | Stt _ | Eff _ -> None
     | Seq (e1, e2) ->
-        let%bind e1 = hook_free (Ex e1) in
-        let%bind e2 = hook_free (Ex e2) in
+        let* e1 = hook_free (Ex e1) in
+        let* e2 = hook_free (Ex e2) in
         Some (mk (Seq (e1, e2)))
     | (Const _ as e)
     | (Var _ as e)
diff --git a/lib/dune b/lib/dune
index 7e296ee..e02f73b 100644
--- a/lib/dune
+++ b/lib/dune
@@ -1,11 +1,3 @@
 (library
  (name react_trace)
- (preprocess
-  (pps ppx_jane))
- (libraries base logs flow_parser ppx_jane))
-
-(ocamllex lexer)
-
-(menhir
- (modules parser)
- (flags --dump))
+ (libraries base logs flow_parser lib_domains))
diff --git a/lib/interp.ml b/lib/interp.ml
index 48efc11..e7dfb76 100644
--- a/lib/interp.ml
+++ b/lib/interp.ml
@@ -1,6 +1,7 @@
 open! Base
 open Stdlib.Effect
 open Stdlib.Effect.Deep
+open Lib_domains
 open Syntax
 open Concrete_domains
 open Interp_effects
diff --git a/lib/interp_effects.ml b/lib/interp_effects.ml
index 6712bdb..8d813f3 100644
--- a/lib/interp_effects.ml
+++ b/lib/interp_effects.ml
@@ -1,5 +1,5 @@
 open! Base
-open Stdlib.Effect
+open Lib_domains
 open Syntax
 open Concrete_domains
 
@@ -8,32 +8,32 @@ exception Type_error
 exception Invalid_phase
 
 (* path and phase effects *)
-type _ Stdlib.Effect.t += Rd_pt : Path.t t | Rd_ph : phase t
+type _ eff += Rd_pt : Path.t eff | Rd_ph : phase eff
 
 (* environmental effects *)
-type _ Stdlib.Effect.t +=
-  | Rd_env : Env.t t
-  | In_env : Env.t -> (('b -> 'a) -> 'b -> 'a) t
+type _ eff +=
+  | Rd_env : Env.t eff
+  | In_env : Env.t -> (('b -> 'a) -> 'b -> 'a) eff
 
 (* memory effects *)
-type _ Stdlib.Effect.t +=
-  | Alloc_addr : obj -> Addr.t t
-  | Lookup_addr : Addr.t -> obj t
-  | Update_addr : Addr.t * obj -> unit t
+type _ eff +=
+  | Alloc_addr : obj -> Addr.t eff
+  | Lookup_addr : Addr.t -> obj eff
+  | Update_addr : Addr.t * obj -> unit eff
 
 (* tree memory effects in eval/eval_mult *)
-type _ Stdlib.Effect.t +=
-  | Lookup_st : Path.t * Label.t -> (value * Job_q.t) t
-  | Update_st : (Path.t * Label.t * (value * Job_q.t)) -> unit t
-  | Get_dec : Path.t -> decision t
-  | Set_dec : Path.t * decision -> unit t
-  | Enq_eff : Path.t * clos -> unit t
+type _ eff +=
+  | Lookup_st : Path.t * Label.t -> (value * Job_q.t) eff
+  | Update_st : (Path.t * Label.t * (value * Job_q.t)) -> unit eff
+  | Get_dec : Path.t -> decision eff
+  | Set_dec : Path.t * decision -> unit eff
+  | Enq_eff : Path.t * clos -> unit eff
 
 (* tree memory effects in render *)
-type _ Stdlib.Effect.t +=
-  | Alloc_pt : Path.t t
-  | Lookup_ent : Path.t -> entry t
-  | Update_ent : Path.t * entry -> unit t
+type _ eff +=
+  | Alloc_pt : Path.t eff
+  | Lookup_ent : Path.t -> entry eff
+  | Update_ent : Path.t * entry -> unit eff
 
 type checkpoint =
   | Retry_start of (int * Path.t)
@@ -41,10 +41,9 @@ type checkpoint =
   | Render_finish of Path.t
   | Effects_finish of Path.t
 
-type _ Stdlib.Effect.t +=
-  | Checkpoint : { msg : string; checkpoint : checkpoint } -> unit t
+type _ eff += Checkpoint : { msg : string; checkpoint : checkpoint } -> unit eff
 
 (* For testing nontermination *)
-type _ Stdlib.Effect.t += Re_render_limit : int t
+type _ eff += Re_render_limit : int eff
 
 exception Too_many_re_renders
diff --git a/lib/js_syntax.ml b/lib/js_syntax.ml
index 6003288..fec6832 100644
--- a/lib/js_syntax.ml
+++ b/lib/js_syntax.ml
@@ -1,4 +1,5 @@
 open! Base
+open Lib_domains
 
 exception NotImplemented
 exception Unreachable
diff --git a/lib/logger.ml b/lib/logger.ml
index 75b8fd5..8fafa9b 100644
--- a/lib/logger.ml
+++ b/lib/logger.ml
@@ -1,4 +1,5 @@
 open! Base
+open Lib_domains
 open Syntax
 open Concrete_domains
 
diff --git a/lib/util.ml b/lib/util.ml
index 0f63433..fdd0f51 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -1,45 +1,5 @@
 open! Base
 
-module Map_key (T : sig
-  type t
-
-  val sexp_of_t : t -> Sexp.t
-  val t_of_sexp : Sexp.t -> t
-  val of_string : string -> t
-  val to_string : t -> string
-  val ( <= ) : t -> t -> bool
-  val ( >= ) : t -> t -> bool
-  val ( = ) : t -> t -> bool
-  val ( < ) : t -> t -> bool
-  val ( > ) : t -> t -> bool
-  val ( <> ) : t -> t -> bool
-  val compare : t -> t -> int
-  val min : t -> t -> t
-  val max : t -> t -> t
-  val ascending : t -> t -> int
-  val descending : t -> t -> int
-  val between : t -> low:t -> high:t -> bool
-  val clamp_exn : t -> min:t -> max:t -> t
-  val clamp : t -> min:t -> max:t -> t Or_error.t
-
-  type comparator_witness
-
-  val comparator : (t, comparator_witness) Comparator.t
-  val hash : t -> int
-  val equal : t -> t -> bool
-end) =
-struct
-  include T
-
-  module Map = struct
-    open Map
-    include M (T)
-
-    let empty = empty (module T)
-    let sexp_of_t sexp_of_v t = Map.sexp_of_m__t (module T) sexp_of_v t
-  end
-end
-
 let pad_or_truncate (lst : 'a list) ~(len : int) : 'a option list =
   let open List in
   let l = length lst in