🚚 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,2 +1,3 @@
 profile = default
 wrap-comments = true
+ocaml-version = 5.3

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)

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

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);

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

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))

lib/syntax.ml → 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)

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))

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

lib/interp_effects.ml

@@ -1,5 +1,5 @@
 open! Base
-open Stdlib.Effect
+open Lib_domains
 open Syntax
 open Concrete_domains
 
@@ -8,43 +8,42 @@ 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)
   | Render_check of Path.t
   | 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

lib/js_syntax.ml

@@ -1,4 +1,5 @@
 open! Base
+open Lib_domains
 
 exception NotImplemented
 exception Unreachable

lib/logger.ml

@@ -1,4 +1,5 @@
 open! Base
+open Lib_domains
 open Syntax
 open Concrete_domains
 

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