Create runtime value embedding system

Dummy for now but will be extended

Makefile

@@ -18,7 +18,7 @@ dependencies-ocaml:
 		ocamlformat ANSITerminal sedlex	menhir menhirLib dune cmdliner obelisk \
 		re obelisk unionfind bindlib zarith.1.11 zarith_stubs_js.v0.14.0 ocamlgraph \
 		js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile \
-		visitors benchmark hmap
+		visitors benchmark
 
 init-submodules:
 	git submodule update --init

src/catala/dune

@@ -7,7 +7,7 @@
 (library
  (name runtime)
  (public_name catala.runtime)
- (libraries calendar zarith zarith_stubs_js hmap)
+ (libraries calendar zarith zarith_stubs_js)
  (modules runtime))
 
 (executable

src/catala/lcalc/to_ocaml.ml

@@ -309,11 +309,11 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp
         (op, Pos.no_pos) format_with_parens arg2
   | EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ])
     when !Cli.trace_flag ->
-      Format.fprintf fmt "(log_begin_call@ %a@ %a@ %a)" format_uid_list info format_with_parens f
-        format_with_parens arg
+      Format.fprintf fmt "(log_begin_call@ %a@ %a@ unembeddable@ %a)" format_uid_list info
+        format_with_parens f format_with_parens arg
   | EApp ((EOp (Unop (D.Log (D.VarDef, info))), _), [ arg1 ]) when !Cli.trace_flag ->
-      Format.fprintf fmt "(log_variable_definition@ %a@ %a)" format_uid_list info format_with_parens
-        arg1
+      Format.fprintf fmt "(log_variable_definition@ %a@ unembeddable@ %a)" format_uid_list info
+        format_with_parens arg1
   | EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag ->
       Format.fprintf fmt
         "(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \
@@ -322,7 +322,8 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp
         (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
         format_with_parens arg1
   | EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag ->
-      Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1
+      Format.fprintf fmt "(log_end_call@ %a@ unembeddable@ %a)" format_uid_list info
+        format_with_parens arg1
   | EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
   | EApp ((EOp (Unop op), _), [ arg1 ]) ->
       Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1

src/catala/runtime.ml

@@ -34,6 +34,18 @@ exception UncomparableDurations
 
 exception ImpossibleDate
 
+type runtime_value =
+  | Money of money
+  | Integer of integer
+  | Decimal of decimal
+  | Date of date
+  | Duration of duration
+  | Enum of string list * runtime_value
+  | Struct of string list * (string * runtime_value) list
+  | Unembeddable
+
+let unembeddable _ = Unembeddable
+
 type source_position = {
   filename : string;
   start_line : int;
@@ -43,54 +55,28 @@ type source_position = {
   law_headings : string list;
 }
 
-type store_key = Hmap.Key.t
-
 type event =
-  | BeginCall of string list * store_key
-  | EndCall of string list * store_key
-  | VariableDefinition of string list * store_key
+  | BeginCall of string list * runtime_value
+  | EndCall of string list * runtime_value
+  | VariableDefinition of string list * runtime_value
   | DecisionTaken of source_position
 
 let log_ref : event list ref = ref []
 
-let store_ref : Hmap.t ref = ref Hmap.empty
+let reset_log () = log_ref := []
 
-let reset_log () =
-  log_ref := [];
-  store_ref := Hmap.empty
+let retrieve_log () = !log_ref
 
-let retrieve_log () = List.rev !log_ref
-
-(* This function is where we have to punch trough the OCaml type system. Indeed, this value store is
-   really a cheap version of an embedding and de-embedding system where values are annotated by
-   their types. However, since this logging is meant to be accessed through Javascript where we have
-   access to type tagging, this is fine? *)
-let retrieve_value : 'a. store_key -> 'a =
- fun key ->
-  let unique =
-    Hmap.filter
-      (fun binding ->
-        match binding with Hmap.B (key', _) -> Hmap.Key.equal key (Hmap.Key.hide_type key'))
-      !store_ref
-  in
-  match Hmap.get_any_binding unique with Hmap.B (_, v) -> Obj.magic v
-
-let log_begin_call info f x =
-  let x_key = Hmap.Key.create () in
-  store_ref := Hmap.add x_key x !store_ref;
-  log_ref := BeginCall (info, Hmap.Key.hide_type x_key) :: !log_ref;
+let log_begin_call info f _embed x =
+  log_ref := BeginCall (info, Unembeddable) :: !log_ref;
   f x
 
-let log_end_call info x =
-  let x_key = Hmap.Key.create () in
-  store_ref := Hmap.add x_key x !store_ref;
-  log_ref := EndCall (info, Hmap.Key.hide_type x_key) :: !log_ref;
+let log_end_call info _embed x =
+  log_ref := EndCall (info, Unembeddable) :: !log_ref;
   x
 
-let log_variable_definition (info : string list) (x : 'a) =
-  let x_key = Hmap.Key.create () in
-  store_ref := Hmap.add x_key x !store_ref;
-  log_ref := VariableDefinition (info, Hmap.Key.hide_type x_key) :: !log_ref;
+let log_variable_definition (info : string list) _embed (x : 'a) =
+  log_ref := VariableDefinition (info, Unembeddable) :: !log_ref;
   x
 
 let log_decision_taken pos x =

src/catala/runtime.mli

@@ -38,6 +38,20 @@ exception ImpossibleDate
 
 exception NoValueProvided
 
+(** {1 Value Embedding} *)
+
+type runtime_value =
+  | Money of money
+  | Integer of integer
+  | Decimal of decimal
+  | Date of date
+  | Duration of duration
+  | Enum of string list * runtime_value
+  | Struct of string list * (string * runtime_value) list
+  | Unembeddable
+
+val unembeddable : 'a -> runtime_value
+
 (** {1 Logging} *)
 
 type source_position = {
@@ -49,27 +63,21 @@ type source_position = {
   law_headings : string list;
 }
 
-type store_key
-
 type event =
-  | BeginCall of string list * store_key
-  | EndCall of string list * store_key
-  | VariableDefinition of string list * store_key
+  | BeginCall of string list * runtime_value
+  | EndCall of string list * runtime_value
+  | VariableDefinition of string list * runtime_value
   | DecisionTaken of source_position
 
 val reset_log : unit -> unit
 
 val retrieve_log : unit -> event list
 
-val retrieve_value : store_key -> 'a
-(** TODO: This is a cheap substitute for a deep embedding of the language values, which will be
-    necessary. See https://github.com/CatalaLang/catala/issues/89#issuecomment-799723775 *)
+val log_begin_call : string list -> ('a -> 'b) -> ('a -> runtime_value) -> 'a -> 'b
 
-val log_begin_call : string list -> ('a -> 'b) -> 'a -> 'b
+val log_end_call : string list -> ('a -> runtime_value) -> 'a -> 'a
 
-val log_end_call : string list -> 'a -> 'a
-
-val log_variable_definition : string list -> 'a -> 'a
+val log_variable_definition : string list -> ('a -> runtime_value) -> 'a -> 'a
 
 val log_decision_taken : source_position -> bool -> bool
 

src/french_law/api_web.ml

@@ -113,8 +113,7 @@ let _ =
 
                      val mutable loggedValue =
                        match evt with
-                       | BeginCall (_, key) | EndCall (_, key) | VariableDefinition (_, key) ->
-                           let v = retrieve_value key in
+                       | BeginCall (_, v) | EndCall (_, v) | VariableDefinition (_, v) ->
                            Js.Unsafe.inject v
                        | DecisionTaken _ -> Js.Unsafe.inject Js.undefined