fix build with ocanren syntax (with dune), separate functional and relational implementations

bin/dune

@@ -8,6 +8,6 @@
  (modules main)
  (flags
   (:standard -rectypes))
- (libraries lib1)
+ ; (libraries ...)
  (preprocess
   (pps OCanren-ppx.ppx_repr OCanren-ppx.ppx_fresh GT.ppx GT.ppx_all)))

lib/dune

@@ -3,38 +3,6 @@
   (flags
    (:standard -warn-error +5))))
 
-(library
- (name lib1)
- (modules lib)
- (flags (-rectypes))
- (libraries OCanren OCanren.tester)
- (inline_tests)
- (wrapped false)
- (preprocess
-  (pps
-   OCanren-ppx.ppx_repr
-   OCanren-ppx.ppx_fresh
-   OCanren-ppx.ppx_distrib
-   GT.ppx
-   GT.ppx_all
-   ppx_inline_test)))
-
-; (library
-;  (name lib2)
-;  (modules lib_next)
-;  (flags (-rectypes))
-;  (libraries OCanren OCanren.tester)
-;  (inline_tests)
-;  (wrapped false)
-;  (preprocess
-;   (pps
-;    OCanren-ppx.ppx_repr
-;    OCanren-ppx.ppx_fresh
-;    OCanren-ppx.ppx_distrib
-;    GT.ppx
-;    GT.ppx_all
-;    ppx_inline_test)))
-
 (library
  (name semantic_interpreter)
  (modules semantic_interpreter)
@@ -51,3 +19,37 @@
    GT.ppx_all
    ppx_expect
    ppx_inline_test)))
+
+(library
+ (name relational_semantic_interpreter)
+ (modules relational_semantic_interpreter)
+ (flags
+  (:standard -rectypes))
+ (libraries OCanren OCanren.tester)
+ (preprocessor_deps %{project_root}/lib/pp5+gt+plugins+ocanren+dump.exe)
+ (inline_tests)
+ (wrapped false)
+ (preprocess
+   (pps
+   OCanren-ppx.ppx_repr
+   OCanren-ppx.ppx_distrib
+   OCanren-ppx.ppx_deriving_reify
+   OCanren-ppx.ppx_fresh
+   ppx_expect
+   ppx_inline_test
+   --
+   -pp
+   lib/pp5+gt+plugins+ocanren+dump.exe)
+  ))
+
+(rule
+ (targets pp5+gt+plugins+ocanren+dump.exe)
+ (action
+  (run
+   mkcamlp5.opt
+   -package
+   camlp5,camlp5.pa_o,camlp5.macro,camlp5.pr_dump,logger.syntax
+   -package
+   logger.syntax,GT.syntax,GT.syntax.all,OCanren.syntax
+   -o
+   %{targets})))

lib/relational_semantic_interpreter.ml

@@ -0,0 +1,44 @@
+(* (,,) -< Pair.inj _ (Pair.inj _ _) *)
+
+module Relational =
+struct
+  open GT
+  open OCanren
+  open OCanren.Std
+
+  @type data_ground = Nat.ground with show, gmap
+  @type data_logic = Nat.logic with show, gmap
+  type data_injected = Nat.injected
+
+  @type tag_ground = Ref | Value with show, gmap
+  @type tag_logic = tag_ground logic with show, gmap
+  type tag_injected = tag_ground ilogic
+
+  @type ('d, 'dl) stmt_abs = Call of 'd * 'dl | Read of 'd | Write of 'd with show, gmap
+  @type stmt_ground = (data_ground, data_ground List.ground) stmt_abs with show, gmap
+  @type stmt_logic = (data_logic, data_logic List.logic) stmt_abs logic with show, gmap
+  type stmt_injected = (data_injected, data_injected List.injected) stmt_abs ilogic
+
+  @type body_ground = stmt_ground List.ground with show, gmap
+  @type body_logic = stmt_logic List.logic with show, gmap
+  type body_injected = stmt_injected List.injected
+
+  @type fun_decl_ground = tag_ground List.ground * body_ground with show, gmap
+  @type fun_decl_logic = (tag_logic List.logic * body_logic) logic with show, gmap
+  type fun_decl_injected = (tag_injected List.injected * body_injected) ilogic
+
+  @type prog_ground = fun_decl_ground List.ground * fun_decl_ground with show, gmap
+  @type prog_logic = (fun_decl_logic List.logic * fun_decl_logic) logic with show, gmap
+  type prog_injected = (fun_decl_injected List.injected * fun_decl_injected) ilogic
+
+  @type 'd arg_abs = RValue | LValue of 'd with show, gmap
+  @type arg_ground = data_ground arg_abs with show, gmap
+  @type arg_logic = data_logic arg_abs logic with show, gmap
+  type arg_injected = data_injected arg_abs ilogic
+
+  @type value_ground = UnitV | BotV with show, gmap
+  @type value_logic = value_ground logic with show, gmap
+  type value_injected = value_ground ilogic
+
+  (* ocanren type 'a lst = Nil | Cons of 'a * 'a lst *)
+end

lib/semantic_interpreter.ml

@@ -1,4 +1,7 @@
-open OCanren
+(* (,,) -< Pair.inj _ (Pair.inj _ _) *)
+
+module Functional =
+struct
 
   (* --- types --- *)
 
@@ -22,20 +25,23 @@ exception Ref_rvalue_argument of int
 
   module M = Map.Make (Int);;
 
-type arg = RValue | LValue of data (* TODO: data in calls ?? *)
+  (* TODO: allow data (rvalue) in calls ?? *)
+  type arg = RValue | LValue of data
   type value = UnitV | BotV (* NOTE: RefV of data - not needed for now *)
 
+  (* TODO: replace env map with pairs *)
   (* env * memory * last unused memory * assignments *) 
-type state = data M.t * value Array.t * int * data list
+  type state = data M.t * value list * int * data list
 
+  (* TODO: replace with pairs *)
   let rec list_replace xs id value = match (xs, id) with
- | (x :: xs, 0) -> value :: xs
- | (x :: xs, n) -> x :: list_replace xs (id - 1) value 
+   | (_x :: xs, 0) -> value :: xs
+   | (x :: xs, _n) -> x :: list_replace xs (id - 1) value 
    | ([], _) -> raise Not_found
 
 
   let env_get state id = match state with
-  (env, mem, mem_len, assignments) -> M.find id env
+    (env, _mem, _mem_len, _assignments) -> M.find id env
 
   let env_add state id mem_id = match state with
     (env, mem, mem_len, assignments) -> let env = M.add id mem_id env in
@@ -44,7 +50,7 @@ let env_add state id mem_id = match state with
   let inv_id mem_len id = mem_len - id - 1
 
   let mem_get state id = match state with
-  (env, mem, mem_len, _) -> List.nth mem @@ inv_id mem_len @@ env_get state id
+    (_env, mem, mem_len, _assignments) -> List.nth mem @@ inv_id mem_len @@ env_get state id
 
   let mem_set state id value= match state with
     (env, mem, mem_len, assignments) -> let mem_id = inv_id mem_len @@ env_get state id in
@@ -64,7 +70,6 @@ let st_mem_len state =
     match state with (_, _, mem_len, _) -> mem_len
 
   let st_add_arg state state_before id arg_tag arg =
-  (* match state with (env, mem, mem_len, assignments) -> *)
     match (arg_tag, arg) with
       | (Ref, RValue) -> raise @@ Ref_rvalue_argument id (* TODO: allow later ?? *) 
       | (Ref, LValue arg) -> env_add state id (env_get state_before arg)
@@ -92,7 +97,7 @@ and eval_fun state prog decl args =
     let (state, _) = List.fold_left2 (fun (state, id) arg_tag arg -> (st_add_arg state state_before id arg_tag arg, id + 1)) (state, 0) arg_tags args in
     let state = eval_body state prog body in
     let state = st_spoil_assignments state in
-  match state with (env, mem, len, assignments) ->
+    match state with (_env, mem, len, _assignments) ->
     (env_before, List.drop (len - len_before) mem, len_before, assignments_before) (* TODO: save some assignments ?? *)
 
   and eval_fun_empty_args state prog decl =
@@ -314,3 +319,5 @@ let%expect_test "two functions: value arg after spoiled ref arg" =
          [%expect.unreachable])
     with Incorrect_memory_access id -> Printf.printf "%i" id;
     [%expect {| 0 |}]
+
+end

test/dune

@@ -1,2 +0,0 @@
-(test
- (name test_pass_strategy_synthesis))