diff --git a/build_system/clerk_config.ml b/build_system/clerk_config.ml index 24248d87e..fc5285798 100644 --- a/build_system/clerk_config.ml +++ b/build_system/clerk_config.ml @@ -18,7 +18,7 @@ open Catala_utils open Otoml type backend = .. -type backend += C | OCaml | Java | Python +type backend += C | OCaml | Java | Python | Jsoo let registered_backends = ref [] @@ -29,7 +29,8 @@ let () = register_backend ~name:"c" C; register_backend ~name:"ocaml" OCaml; register_backend ~name:"java" Java; - register_backend ~name:"python" Python + register_backend ~name:"python" Python; + register_backend ~name:"jsoo" Jsoo let registered_backends () = !registered_backends diff --git a/build_system/clerk_config.mli b/build_system/clerk_config.mli index c7578a301..7601e47c7 100644 --- a/build_system/clerk_config.mli +++ b/build_system/clerk_config.mli @@ -17,7 +17,7 @@ open Catala_utils type backend = .. -type backend += C | OCaml | Java | Python +type backend += C | OCaml | Java | Python | Jsoo val register_backend : name:string -> backend -> unit diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 1f94d0de5..7f5154dd0 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -133,6 +133,7 @@ let backend_src_extensions = Clerk_rules.Python, ["py"]; Clerk_rules.Java, ["java"]; Clerk_rules.Tests, ["catala_en"; "catala_fr"; "catala_pl"]; + Clerk_rules.Jsoo, ["ml"; "mli"]; ] let backend_obj_extensions = @@ -142,6 +143,7 @@ let backend_obj_extensions = Clerk_rules.Python, []; Clerk_rules.Java, ["class"]; Clerk_rules.Tests, []; + Clerk_rules.Jsoo, []; ] let backend_extensions = @@ -163,6 +165,7 @@ let backend_subdir_list = Clerk_rules.Java, "java"; Clerk_rules.OCaml, "ocaml"; Clerk_rules.Tests, ""; + Clerk_rules.Jsoo, "jsoo"; ] let subdir_backend_list = @@ -173,6 +176,16 @@ let backend_subdir bk = List.assoc bk backend_subdir_list let rule_subdir rule = backend_subdir (Clerk_rules.backend_from_config rule.Config.backend) +let backend_suffix = + [ + Clerk_rules.C, None; + Clerk_rules.Python, None; + Clerk_rules.Java, None; + Clerk_rules.OCaml, None; + Clerk_rules.Tests, None; + Clerk_rules.Jsoo, Some "_jsoo"; + ] + let linking_command ~build_dir ~backend ~var_bindings link_deps item target = let open File in match backend with @@ -195,6 +208,7 @@ let linking_command ~build_dir ~backend ~var_bindings link_deps item target = "-o"; target -.- "exe"; ] + | `Jsoo -> [] | `C -> get_var var_bindings Var.cc_exe @ [build_dir / Scan.libcatala / "c" / "dates_calc.o"] @@ -336,6 +350,7 @@ let rules_backend = function | Clerk_rules.Python -> `Python | Clerk_rules.Java -> `Java | Clerk_rules.Tests -> `Interpret + | Clerk_rules.Jsoo -> `Jsoo let string_of_backend = function | `OCaml -> "ocaml" @@ -343,6 +358,7 @@ let string_of_backend = function | `Python -> "python" | `Java -> "java" | `Interpret -> "interpret" + | `Jsoo -> "jsoo" let make_target ~build_dir ~backend item = let open File in @@ -359,6 +375,7 @@ let make_target ~build_dir ~backend item = | `C -> (dir / "c" / base) -.- "o" | `Python -> (dir / "python" / base) -.- "py" | `Java -> (dir / "java" / base) -.- "class" + | `Jsoo -> File.with_extension ~suffix:"_jsoo" (dir / "ocaml" / base) ".ml" | `Custom rule -> (dir / rule_subdir rule / base) -.- List.hd rule.Config.in_exts in @@ -371,8 +388,11 @@ let backend_runtime_targets ?(only_source = false) enabled_backends = @ (if List.mem Clerk_rules.C enabled_backends then [src "@runtime-c"] else []) @ (if List.mem Clerk_rules.Python enabled_backends then ["@runtime-python"] else []) + @ (if List.mem Clerk_rules.Java enabled_backends then [src "@runtime-java"] + else []) @ - if List.mem Clerk_rules.Java enabled_backends then [src "@runtime-java"] + if List.mem Clerk_rules.Jsoo enabled_backends then + if only_source then ["@runtime-jsoo-src"] else [] else [] open Cmdliner @@ -484,8 +504,11 @@ let build_clerk_target if target.include_objects then List.assoc bk backend_extensions else List.assoc bk backend_src_extensions in + let suffix = List.assoc bk backend_suffix in List.map - (fun ext -> (module_item, target, bk), base -.- ext) + (fun ext -> + ( (module_item, target, bk), + File.with_extension ?suffix base ext )) extensions) all_modules_deps) enabled_backends @@ -508,7 +531,8 @@ let build_clerk_target List.assoc backend backend_extensions else List.assoc backend backend_src_extensions in - List.map File.(fun ext -> tf -.- ext) exts + let suffix = List.assoc backend backend_suffix in + List.map (fun ext -> File.with_extension ?suffix tf ext) exts in targets @ acc) (backend_runtime_targets @@ -552,10 +576,21 @@ let build_clerk_target ["catala"; "org"] | Clerk_rules.Tests -> assert false | bk -> + let suffix = List.assoc bk backend_suffix in List.iter (fun ext -> - let src = (local_runtime_dir bk / "catala_runtime") -.- ext in - if File.exists src then copy_in ~dir ~src) + let runtime_src = + File.with_extension ?suffix + (local_runtime_dir bk / "catala_runtime") + ext + in + if File.exists runtime_src then copy_in ~dir ~src:runtime_src; + let dates_calc_src = + File.with_extension ?suffix + (local_runtime_dir bk / "dates_calc") + ext + in + if File.exists dates_calc_src then copy_in ~dir ~src:dates_calc_src) extensions); if target.Config.include_sources then all_modules_deps @@ -883,7 +918,7 @@ let setup_report_format ?fix_path verbosity diff_command coverage = let run_artifact config ~backend ~var_bindings ?scope src = let open File in match backend with - | `OCaml -> + | `OCaml | `Jsoo -> let cmd = (src -.- "exe") :: Option.to_list scope in Message.debug "Executing artifact: '%s'..." (String.concat " " cmd); run_command cmd @@ -926,6 +961,7 @@ let enable_backend = | `C -> C | `Python -> Python | `Java -> Java + | `Jsoo -> Jsoo let build_test_deps ~config @@ -967,7 +1003,7 @@ let build_test_deps let backend = match backend with | `Interpret -> `Interpret_module - | (`OCaml | `C | `Python | `Java) as bk -> bk + | (`OCaml | `C | `Python | `Java | `Jsoo) as bk -> bk in List.fold_left (fun acc (it, t) -> @@ -1004,7 +1040,7 @@ let run_tests scope_input (test_targets, link_deps, var_bindings) = let build_dir = config.Cli.options.global.build_dir in - match (backend : [ `Interpret | `C | `OCaml | `Python | `Java ]) with + match (backend : [ `Interpret | `C | `OCaml | `Python | `Java | `Jsoo ]) with | `Interpret -> let () = match scope_input, test_targets with @@ -1031,7 +1067,7 @@ let run_tests let cmd = exec @ [cmd; target] @ catala_flags in Message.debug "Running command: '%s'..." (String.concat " " cmd); run_command cmd - | (`C | `OCaml | `Python | `Java) as backend -> ( + | (`C | `OCaml | `Python | `Java | `Jsoo) as backend -> ( let link_cmd = linking_command ~build_dir ~backend ~var_bindings link_deps in @@ -1197,7 +1233,7 @@ let run_clerk_test config quiet (clerk_targets_or_files_or_folders : string list) - (backend : [ `Interpret | `OCaml | `C | `Python | `Java ]) + (backend : [ `Interpret | `OCaml | `C | `Python | `Java | `Jsoo ]) (reset_test_outputs : bool) verbosity (report_format : [ `Terminal | `JUnitXML | `VSCodeJSON ]) diff --git a/build_system/clerk_rules.ml b/build_system/clerk_rules.ml index bcc7142a8..30d5ffae9 100644 --- a/build_system/clerk_rules.ml +++ b/build_system/clerk_rules.ml @@ -22,15 +22,16 @@ module Poll = Clerk_poll (**{1 Building rules}*) -type backend = OCaml | Python | C | Java | Tests (* | JS *) +type backend = OCaml | Python | C | Java | Tests | Jsoo -let all_backends = [OCaml; Python; C; Java; Tests] +let all_backends = [OCaml; Python; C; Java; Tests; Jsoo] let backend_from_config = function | Clerk_config.OCaml -> OCaml | Clerk_config.Python -> Python | Clerk_config.C -> C | Clerk_config.Java -> Java + | Clerk_config.Jsoo -> Jsoo | _ -> invalid_arg __FUNCTION__ (** Ninja variable names *) @@ -58,6 +59,7 @@ module Var = struct let catala_flags_c = make "CATALA_FLAGS_C" let catala_flags_python = make "CATALA_FLAGS_PYTHON" let catala_flags_java = make "CATALA_FLAGS_JAVA" + let catala_flags_jsoo = make "CATALA_FLAGS_JSOO" let ocamlc_exe = make "OCAMLC_EXE" let ocamlopt_exe = make "OCAMLOPT_EXE" let ocaml_flags = make "OCAML_FLAGS" @@ -71,6 +73,8 @@ module Var = struct let javac_flags = make "JAVAC_FLAGS" let jar = make "jar" let java = make "JAVA" + let js_of_ocaml_exe = make "JS_OF_OCAML_EXE" + let js_of_ocaml_flags = make "JS_OF_OCAML_FLAGS" let all_vars = all_vars_ref.contents (* Definition spreading different rules *) @@ -151,6 +155,16 @@ let base_bindings ~code_coverage ~autotest ~enabled_backends ~config = | "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false) test_flags in + let catala_flags_jsoo = + (if autotest then ["--autotest"] else []) + @ + if use_default_flags then ["-O"] + else + List.filter + (function + | "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false) + test_flags + in let def var value = let value = match List.assoc_opt (Var.name var) options.variables with @@ -214,28 +228,35 @@ let base_bindings ~code_coverage ~autotest ~enabled_backends ~config = def Var.javac_flags (lazy ["-implicit:none"]); ] else []) + @ (if List.mem C enabled_backends then + [ + def Var.catala_flags_c (lazy catala_flags_c); + def Var.cc_exe (lazy ["cc"]); + def Var.c_flags + (lazy + [ + "-std=c89"; + "-pedantic"; + "-Wall"; + "-Wno-unused-function"; + "-Wno-unused-variable"; + "-Wno-unused-but-set-variable"; + "-Werror"; + "-fPIC"; + "-g"; + ]); + def Var.c_include + (lazy + (["-I"; File.(Var.(!builddir) / Scan.libcatala / "c")] + @ includes ~backend:"c" ())); + ] + else []) @ - if List.mem C enabled_backends then + if List.mem Jsoo enabled_backends then [ - def Var.catala_flags_c (lazy catala_flags_c); - def Var.cc_exe (lazy ["cc"]); - def Var.c_flags - (lazy - [ - "-std=c89"; - "-pedantic"; - "-Wall"; - "-Wno-unused-function"; - "-Wno-unused-variable"; - "-Wno-unused-but-set-variable"; - "-Werror"; - "-fPIC"; - "-g"; - ]); - def Var.c_include - (lazy - (["-I"; File.(Var.(!builddir) / Scan.libcatala / "c")] - @ includes ~backend:"c" ())); + def Var.catala_flags_jsoo (lazy catala_flags_jsoo); + def Var.js_of_ocaml_exe (lazy ["js_of_ocaml"]); + def Var.js_of_ocaml_flags (lazy []); ] else [] @@ -276,6 +297,14 @@ let[@ocamlformat "disable"] static_base_rules enabled_backends = "-o"; !output] ~description:[""; "⇒"; !output]; ] else []) @ + (if List.mem Jsoo enabled_backends then [ + Nj.rule "catala-jsoo" + ~command:[!catala_exe; "jsoo"; !catala_flags; !catala_flags_jsoo; + "-o"; !output; "--"; !input] + ~description:[""; "jsoo"; "⇒"; !output]; + ] + else [] + ) @ (if List.mem C enabled_backends then [ Nj.rule "catala-c" ~command:[!catala_exe; "c"; !catala_flags; !catala_flags_c; @@ -348,23 +377,31 @@ let gen_build_statements ]) include_dirs in - let target ?backend ext = + let target ?suffix ?backend ext = let ext = match ext.[0] with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> "." ^ ext | _ -> ext in + let suffix = + match suffix with + | None | Some "" -> "" + | Some s -> ( + match s.[0] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> "_" ^ s + | _ -> s) + in let bdir = match backend with - | None -> fun f -> f ^ ext - | Some b -> fun f -> (b / f) ^ ext + | None -> fun f -> f ^ suffix ^ ext + | Some b -> fun f -> (b / f) ^ suffix ^ ext in !Var.tdir / bdir !Var.dst in let modules = List.rev_map Mark.remove item.used_modules in - let modfile ?(backend = "ocaml") ext modname = + let modfile ?(suffix = "") ?(backend = "ocaml") ext modname = match List.assoc_opt modname same_dir_modules with - | Some _ -> (!Var.tdir / backend / String.to_id modname) ^ ext + | Some _ -> (!Var.tdir / backend / String.to_id modname) ^ suffix ^ ext | None -> modname ^ "@" ^ backend ^ "-module" in let module_target x = modfile "@ocaml-module" x in @@ -409,8 +446,8 @@ let gen_build_statements else [] in let has_scope_tests = Lazy.force item.has_scope_tests in - let extern_src backend ext missing = - let f = src -.- ext in + let extern_src ?suffix backend ext missing = + let f = File.with_extension ?suffix src ext in match check_file f with | Some f -> f, missing | None -> ( @@ -433,7 +470,7 @@ let gen_build_statements File.format) missing backend src in - let ocaml, c, python, java = + let ocaml, c, python, java, jsoo = if item.extrnal then let ocaml = if not (List.mem OCaml enabled_backends) then Seq.empty @@ -485,7 +522,21 @@ let gen_build_statements ~outputs:[target ~backend:"java" "java"]; ] in - ocaml, c, python, java + let jsoo = + if not (List.mem Jsoo enabled_backends) then Seq.empty + else + let ml, missing = extern_src ~suffix:"_jsoo" "jsoo" "ml" [] in + let mli, missing = extern_src ~suffix:"_jsoo" "jsoo" "mli" missing in + check_missing "jsoo" missing; + List.to_seq + [ + Nj.build "copy" ~implicit_in:[catala_src] ~inputs:[ml] + ~outputs:[target ~suffix:"_jsoo" ~backend:"jsoo" "ml"]; + Nj.build "copy" ~implicit_in:[catala_src] ~inputs:[mli] + ~outputs:[target ~suffix:"_jsoo" ~backend:"jsoo" "mli"]; + ] + in + ocaml, c, python, java, jsoo else let inputs = [catala_src] in let implicit_in = @@ -516,7 +567,11 @@ let gen_build_statements ~outputs:[target ~backend:"python" "py"]), Seq.return (Nj.build "catala-java" ?vars ~inputs ~implicit_in - ~outputs:[target ~backend:"java" "java"]) ) + ~outputs:[target ~backend:"java" "java"]), + Seq.return + (Nj.build "catala-jsoo" ?vars ~inputs ~implicit_in + ~outputs:[target ~suffix:"_jsoo" ~backend:"jsoo" "ml"] + ~implicit_out:[target ~suffix:"_jsoo" ~backend:"jsoo" "mli"]) ) in let ocamlopt = let obj = @@ -655,12 +710,19 @@ let gen_build_statements ~inputs:[modfile ~backend:"python" ".py" modname]; ] else []) + @ (if List.mem Java enabled_backends then + [ + Nj.build "phony" + ~outputs:[modname ^ "@java-module"] + ~inputs:[modfile ~backend:"java" ".class" modname]; + ] + else []) @ - if List.mem Java enabled_backends then + if List.mem Jsoo enabled_backends then [ Nj.build "phony" - ~outputs:[modname ^ "@java-module"] - ~inputs:[modfile ~backend:"java" ".class" modname]; + ~outputs:[modname ^ "@jsoo-module"] + ~inputs:[modfile ~suffix:"_jsoo" ~backend:"jsoo" ".ml" modname]; ] else [] | _ -> [] @@ -687,7 +749,8 @@ let gen_build_statements @ (if List.mem C enabled_backends then [c; List.to_seq cc] else []) @ (if List.mem Python enabled_backends then [python] else []) @ (if List.mem Java enabled_backends then [java; Seq.return javac] else []) - @ if List.mem Tests enabled_backends then [List.to_seq tests] else [] + @ (if List.mem Tests enabled_backends then [List.to_seq tests] else []) + @ if List.mem Jsoo enabled_backends then [jsoo] else [] in Seq.concat (List.to_seq statements_list) @@ -916,48 +979,79 @@ let runtime_build_statements ~config enabled_backends = ~outputs:[python_base -.- "py"]; ] else []) + @ (if List.mem Java enabled_backends then + let java_base = stdbase / "java" in + let java_src = Var.(!runtime) / "java" in + let java_orig_prefix = Lazy.force runtime_orig / "java" in + let java_files = + File.scan_tree + (fun f -> + let base = File.basename f in + if + Filename.check_suffix base ".java" + && base = String.capitalize_ascii base + then Some (File.remove_prefix java_orig_prefix f) + else None) + java_orig_prefix + |> Seq.flat_map (fun (_, _, files) -> List.to_seq files) + |> Seq.map (File.remove_prefix java_src) + |> List.of_seq + in + let java_list_file = + let base = + config.Clerk_cli.options.global.build_dir / Scan.libcatala / "java" + in + File.with_out_channel (base / "java.files") (fun oc -> + List.iter + (fun s -> output_string oc ((base / s) ^ "\n")) + java_files); + java_base / "java.files" + in + Nj.build "phony" + ~inputs:(List.map (fun f -> (java_base / f) -.- "java") java_files) + ~outputs:["@runtime-java-src"] + :: Nj.build "phony" + ~inputs:(List.map (fun f -> (java_base / f) -.- "class") java_files) + ~outputs:["@runtime-java"] + :: Nj.build "java-class" ~inputs:[] + ~implicit_in: + (java_list_file :: List.map (fun f -> java_base / f) java_files) + ~outputs: + (List.map (fun f -> (java_base / f) -.- "class") java_files) + ~vars:[Var.javac_flags, [Var.(!javac_flags); "@" ^ java_list_file]] + :: List.map + (fun f -> + Nj.build "copy" ~inputs:[java_src / f] ~outputs:[java_base / f]) + java_files + else []) @ - if List.mem Java enabled_backends then - let java_base = stdbase / "java" in - let java_src = Var.(!runtime) / "java" in - let java_orig_prefix = Lazy.force runtime_orig / "java" in - let java_files = - File.scan_tree - (fun f -> - let base = File.basename f in - if - Filename.check_suffix base ".java" - && base = String.capitalize_ascii base - then Some (File.remove_prefix java_orig_prefix f) - else None) - java_orig_prefix - |> Seq.flat_map (fun (_, _, files) -> List.to_seq files) - |> Seq.map (File.remove_prefix java_src) - |> List.of_seq - in - let java_list_file = - let base = - config.Clerk_cli.options.global.build_dir / Scan.libcatala / "java" - in - File.with_out_channel (base / "java.files") (fun oc -> - List.iter (fun s -> output_string oc ((base / s) ^ "\n")) java_files); - java_base / "java.files" - in - Nj.build "phony" - ~inputs:(List.map (fun f -> (java_base / f) -.- "java") java_files) - ~outputs:["@runtime-java-src"] - :: Nj.build "phony" - ~inputs:(List.map (fun f -> (java_base / f) -.- "class") java_files) - ~outputs:["@runtime-java"] - :: Nj.build "java-class" ~inputs:[] - ~implicit_in: - (java_list_file :: List.map (fun f -> java_base / f) java_files) - ~outputs:(List.map (fun f -> (java_base / f) -.- "class") java_files) - ~vars:[Var.javac_flags, [Var.(!javac_flags); "@" ^ java_list_file]] - :: List.map - (fun f -> - Nj.build "copy" ~inputs:[java_src / f] ~outputs:[java_base / f]) - java_files + if List.mem Jsoo enabled_backends then + let jsoo_src = Var.(!runtime) / "jsoo" in + let dates_base = stdbase / "jsoo" / "dates_calc" in + let runtime_base = stdbase / "jsoo" / "catala_runtime" in + [ + Nj.build "phony" + ~inputs: + [ + File.with_extension ~suffix:"_jsoo" dates_base "ml"; + File.with_extension ~suffix:"_jsoo" dates_base "mli"; + File.with_extension ~suffix:"_jsoo" runtime_base "ml"; + File.with_extension ~suffix:"_jsoo" runtime_base "mli"; + ] + ~outputs:["@runtime-jsoo-src"]; + Nj.build "copy" + ~inputs:[jsoo_src / "catala_runtime_jsoo.mli"] + ~outputs:[File.with_extension ~suffix:"_jsoo" runtime_base "mli"]; + Nj.build "copy" + ~inputs:[jsoo_src / "catala_runtime_jsoo.ml"] + ~outputs:[File.with_extension ~suffix:"_jsoo" runtime_base "ml"]; + Nj.build "copy" + ~inputs:[jsoo_src / "dates_calc_jsoo.mli"] + ~outputs:[File.with_extension ~suffix:"_jsoo" dates_base "mli"]; + Nj.build "copy" + ~inputs:[jsoo_src / "dates_calc_jsoo.ml"] + ~outputs:[File.with_extension ~suffix:"_jsoo" dates_base "ml"]; + ] else [] let output_ninja_file_header pp ~config ~enabled_backends ~var_bindings = diff --git a/build_system/clerk_rules.mli b/build_system/clerk_rules.mli index bf55338c6..0af354c21 100644 --- a/build_system/clerk_rules.mli +++ b/build_system/clerk_rules.mli @@ -17,7 +17,7 @@ open Catala_utils -type backend = OCaml | Python | C | Java | Tests +type backend = OCaml | Python | C | Java | Tests | Jsoo val all_backends : backend list val backend_from_config : Clerk_config.backend -> backend diff --git a/catala.opam b/catala.opam index e458e3fb7..145536bb9 100644 --- a/catala.opam +++ b/catala.opam @@ -51,6 +51,10 @@ depends: [ "ninja_utils" {= "0.9.0"} "otoml" {>= "1.0"} "json-data-encoding" { >= "1.0.1" } + "ocamlformat-lib" {= "0.28.1"} + "js_of_ocaml" { >= "6.0.0" } + "js_of_ocaml-ppx" { >= "6.0.0" } + "zarith_stubs_js" { >= "v0.16.1" } "odoc" {with-doc} "ocamlformat" {?cataladevmode & cataladevmode & = "0.28.1"} "obelisk" {?cataladevmode & cataladevmode} diff --git a/compiler/catala_utils/dune b/compiler/catala_utils/dune index 03ccdc4b1..1b43f97b4 100644 --- a/compiler/catala_utils/dune +++ b/compiler/catala_utils/dune @@ -3,7 +3,16 @@ (public_name catala.catala_utils) (modules (:standard \ get_version)) - (libraries unix cmdliner ubase uucp ocolor re ocamlgraph yojson)) + (libraries + unix + cmdliner + ubase + uucp + ocolor + re + ocamlgraph + yojson + ocamlformat-lib)) (executable (name get_version) diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index 36ae996da..82fe9d78f 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -222,7 +222,7 @@ let extension filename = in String.remove_prefix ~prefix:"." full_extension -let ( -.- ) file ext = +let with_extension ?(suffix = "") file ext = (* file_ext may be empty, "" when non-md, "md" if only ".md" is present and ".md" if a double-extension is present *) let file_ext = extension file in @@ -231,27 +231,32 @@ let ( -.- ) file ext = if file_ext = "" then (* Nothing to do *) file else (* Remove the extension and the dot *) - String.(sub file 0 (length file - length file_ext - 1)) + let f = String.(sub file 0 (length file - length file_ext - 1)) in + f ^ suffix else if file_ext = "" then (* File has no extension, append the new one *) - file ^ "." ^ ext + file ^ suffix ^ "." ^ ext else (* Remove the existing extension (minus the dot) and append the new one *) - String.(sub file 0 (length file - length file_ext)) ^ ext + let f = String.(sub file 0 (length file - length file_ext - 1)) in + f ^ suffix ^ "." ^ ext +let ( -.- ) file ext = with_extension file ext let remove_extension filename = filename -.- "" -let get_main_out_channel ~source_file ~output_file ?ext () = +let get_main_out_channel ~source_file ~output_file ?ext ?suffix () = match output_file, ext with | Some "-", _ | None, None -> None, fun f -> f stdout | Some f, _ -> Some f, with_out_channel f | None, Some ext -> let src = Global.input_src_file source_file in - let f = src -.- ext in + let f = with_extension ?suffix src ext in Some f, with_out_channel f -let get_main_out_formatter ~source_file ~output_file ?ext () = - let f, with_ = get_main_out_channel ~source_file ~output_file ?ext () in +let get_main_out_formatter ~source_file ~output_file ?ext ?suffix () = + let f, with_ = + get_main_out_channel ~source_file ~output_file ?ext ?suffix () + in let nocolor = match output_file with Some "-" | None -> false | _ -> true in f, fun fmt -> with_ (fun oc -> with_formatter_of_out_channel ~nocolor oc fmt) diff --git a/compiler/catala_utils/file.mli b/compiler/catala_utils/file.mli index 95ed54cfd..ec5ca0ef0 100644 --- a/compiler/catala_utils/file.mli +++ b/compiler/catala_utils/file.mli @@ -47,6 +47,7 @@ val get_main_out_channel : source_file:t Global.input_src -> output_file:t option -> ?ext:string -> + ?suffix:string -> unit -> t option * ((out_channel -> 'a) -> 'a) (** [get_output ~source_file ~output_file ?ext ()] returns the inferred filename @@ -57,6 +58,7 @@ val get_main_out_formatter : source_file:t Global.input_src -> output_file:t option -> ?ext:string -> + ?suffix:string -> unit -> t option * ((Format.formatter -> 'a) -> 'a) (** [get_output_format ~source_file ~output_file ?ext ()] returns the inferred @@ -197,6 +199,8 @@ val find_in_parents : ?cwd:t -> (t -> bool) -> (t * t) option val ( /../ ) : t -> t -> t (** Sugar for [parent a / b] *) +val with_extension : ?suffix:string -> t -> string -> t + val ( -.- ) : t -> string -> t (** Extension replacement: chops the given filename extension, and replaces it with the given one (which shouldn't start with a dot). No dot is appended if diff --git a/compiler/catala_utils/ocamlformat.ml b/compiler/catala_utils/ocamlformat.ml new file mode 100644 index 000000000..1bbd6716b --- /dev/null +++ b/compiler/catala_utils/ocamlformat.ml @@ -0,0 +1,38 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2023 Inria, contributor: + Denis Merigoux + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Ocamlformat_lib + +let conf = Conf.default + +let write filename contents = + File.with_out_channel filename @@ fun oc -> output_string oc contents + +let format input_name = + match Syntax.of_fname input_name with + | None -> + failwith + (Format.sprintf "file %S cannot be formatted by ocamlformat" input_name) + | Some kind -> ( + let source = File.contents input_name in + match Translation_unit.parse_and_format kind conf ~input_name ~source with + | Ok formatted -> write input_name formatted + | Error e -> + let content = + Message.Content.of_message (fun fmt -> + Translation_unit.Error.print fmt e) + in + raise (Message.CompilerError content)) diff --git a/compiler/catala_utils/ocamlformat.mli b/compiler/catala_utils/ocamlformat.mli new file mode 100644 index 000000000..ee1f7d402 --- /dev/null +++ b/compiler/catala_utils/ocamlformat.mli @@ -0,0 +1,18 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2023 Inria, contributor: + Denis Merigoux + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +val format : string -> unit +(** format a file in place with ocamlformat *) diff --git a/compiler/driver.ml b/compiler/driver.ml index cfff7e331..0882ce29c 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -544,10 +544,10 @@ module Commands = struct let get_output_format options output_file = let output_file = Option.map options.Global.path_rewrite output_file in - fun ?ext f -> + fun ?ext ?suffix f -> let output_file, with_output = File.get_main_out_formatter ~source_file:options.Global.input_src - ~output_file ?ext () + ~output_file ?ext ?suffix () in Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file); with_output (fun ppf -> f output_file ppf) @@ -1212,6 +1212,48 @@ module Commands = struct $ Cli.Flags.autotest $ Cli.Flags.closure_conversion) + let jsoo + options + includes + stdlib + output + optimize + check_invariants + autotest + closure_conversion = + let options = if closure_conversion then fix_trace options else options in + let prg, type_ordering, _ = + Passes.lcalc options ~includes ~stdlib ~optimize ~check_invariants + ~autotest ~typed:Expr.typed ~closure_conversion ~keep_special_ops:true + ~monomorphize_types:false ~expand_ops:true + ~renaming:(Some Lcalc.To_ocaml.renaming) + in + Message.debug "Compiling program to generate Js_of_ocaml interface..."; + get_output_format options output + ~ext:(if Global.options.gen_external then "template.ml" else "ml") + ~suffix:"_jsoo" + @@ fun output_file fmt -> + let hashf = Hash.finalise ~monomorphize_types:false in + Lcalc.To_jsoo_interface.format_program output_file fmt prg ~hashf + type_ordering + + let jsoo_cmd = + Cmd.v + (Cmd.info "jsoo" ~man:Cli.man_base + ~doc: + "Generates a Js_of_ocaml interface to use Catala program in \ + javascript.") + Term.( + const jsoo + $ Cli.Flags.Global.options + $ Cli.Flags.include_dirs + $ Cli.Flags.stdlib_dir + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.autotest + $ Cli.Flags.closure_conversion) + let scalc options includes @@ -1544,6 +1586,7 @@ module Commands = struct typecheck_cmd; proof_cmd; ocaml_cmd; + jsoo_cmd; python_cmd; java_cmd; c_cmd; diff --git a/compiler/driver.mli b/compiler/driver.mli index 2608b2b1d..730cb9cd1 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -102,6 +102,7 @@ module Commands : sig Global.options -> Global.raw_file option -> ?ext:string -> + ?suffix:string -> (string option -> Format.formatter -> 'a) -> 'a diff --git a/compiler/lcalc/to_jsoo_interface.ml b/compiler/lcalc/to_jsoo_interface.ml new file mode 100644 index 000000000..00dc87a23 --- /dev/null +++ b/compiler/lcalc/to_jsoo_interface.ml @@ -0,0 +1,691 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Catala_utils +open Shared_ast + +let pp dest fmt = Format.kdprintf (fun k -> List.iter k dest) fmt + +let method_name = function + | "" -> invalid_arg "empty method name" + | s -> + let s = if String.contains s '_' then s ^ "_" else s in + let code = Char.code (String.get s 0) in + if code >= 65 && code <= 90 then "_" ^ s else s + +let format_method_var fmt v = + let s = Format.asprintf "%a" To_ocaml.format_var v in + Format.fprintf fmt "%s" (method_name s) + +let format_struct_field_name fmt n = + let s = Format.asprintf "%a" To_ocaml.format_struct_field_name n in + Format.fprintf fmt "%s" (method_name s) + +let format_enum_cons_name fmt v = + let s = Format.asprintf "%a" To_ocaml.format_enum_cons_name v in + Format.fprintf fmt "%s" (method_name s) + +let typ_needs_parens (e : typ) : bool = + match Mark.remove e with TArrow _ | TArray _ -> true | _ -> false + +let format_to_module_name fmt s = + let p, i = + match s with + | `Sname s -> StructName.path s, StructName.get_info s + | `Ename s -> EnumName.path s, EnumName.get_info s + | `Aname s -> AbstractType.path s, AbstractType.get_info s + in + Format.fprintf fmt "%a%a" + (Format.pp_print_list + ~pp_sep:(fun _ () -> ()) + (fun ppf m -> Format.fprintf ppf "%a_jsoo." Uid.Module.format m)) + p Uid.MarkedString.format i + +let format_typ (fmt : Format.formatter) (typ : typ) : unit = + let rec aux bctx fmt typ = + let format_typ_with_parens (fmt : Format.formatter) (t : typ) = + if typ_needs_parens t then Format.fprintf fmt "(%a)" (aux bctx) t + else Format.fprintf fmt "%a" (aux bctx) t + in + match Mark.remove typ with + | TLit l -> Format.fprintf fmt "%a_jsoo" Print.tlit l + | TTuple [] -> Format.fprintf fmt "unit" + | TTuple _ -> Format.fprintf fmt "Js.Unsafe.any Js.js_array Js.t" + | TStruct s -> Format.fprintf fmt "%a.jsoo" format_to_module_name (`Sname s) + | TOption t -> + Format.fprintf fmt "@[(%a)@] Optional.jsoo" format_typ_with_parens + t + | TDefault t -> aux bctx fmt t + | TEnum e -> Format.fprintf fmt "%a.jsoo" format_to_module_name (`Ename e) + | TAbstract e -> + Format.fprintf fmt "%a.jsoo" format_to_module_name (`Aname e) + | TArrow (t1, t2) -> + Format.fprintf fmt "@[%a@]" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt " ->@ ") + format_typ_with_parens) + (t1 @ [t2]) + | TArray t1 -> + Format.fprintf fmt "@[%a@ Js.js_array Js.t@]" format_typ_with_parens t1 + | TVar _ -> Format.fprintf fmt "Js.Unsafe.any" + | TForAll tb -> + let _v, typ, bctx = Bindlib.unmbind_in bctx tb in + aux bctx fmt typ + | TClosureEnv -> Format.fprintf fmt "Js.Unsafe.any" + | TError -> assert false + in + aux Bindlib.empty_ctxt fmt typ + +let rec format_typ_to (fmt : Format.formatter) (typ : typ) : unit = + let rec aux bctx fmt typ = + match Mark.remove typ with + | TLit l -> Format.fprintf fmt "%a_to_jsoo" Print.tlit l + | TTuple [] -> Format.fprintf fmt "unit_to_jsoo" + | TTuple l -> + let ip, ie = ref (-1), ref (-1) in + Format.fprintf fmt "(fun @[(%a)@] -> Js.array @[[|%a|]@])" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + (fun fmt _t -> + incr ip; + Format.fprintf fmt "_t%d" !ip)) + l + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") + (fun fmt t -> + incr ie; + Format.fprintf fmt "Js.Unsafe.inject (%a _t%d)" (aux bctx) t !ie)) + l + | TStruct s -> + Format.fprintf fmt "%a.to_jsoo" format_to_module_name (`Sname s) + | TOption t -> + Format.fprintf fmt "(fun x -> Optional.to_jsoo %a x)" (aux bctx) t + | TDefault t -> aux bctx fmt t + | TEnum e -> + Format.fprintf fmt "%a.to_jsoo" format_to_module_name (`Ename e) + | TAbstract e -> + Format.fprintf fmt "%a.to_jsoo" format_to_module_name (`Aname e) + | TArrow (t1, t2) -> + let ip, ie = ref (-1), ref (-1) in + Format.fprintf fmt "(fun f -> (fun %a -> %a (f %a)))" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt _t -> + incr ip; + Format.fprintf fmt "_x%d" !ip)) + t1 (aux bctx) t2 + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt t -> + incr ie; + Format.fprintf fmt "(%a _x%d)" format_typ_of t !ie)) + t1 + | TArray t1 -> ( + match Mark.remove t1 with + | TVar _ | TClosureEnv -> Format.fprintf fmt "Js.array" + | _ -> + Format.fprintf fmt "(fun a -> Js.array (Array.map %a a))" (aux bctx) t1) + | TVar _ -> Format.fprintf fmt "Js.Unsafe.inject" + | TForAll tb -> + let _v, typ, bctx = Bindlib.unmbind_in bctx tb in + aux bctx fmt typ + | TClosureEnv -> Format.fprintf fmt "Js.Unsafe.inject" + | TError -> assert false + in + aux Bindlib.empty_ctxt fmt typ + +and format_typ_of (fmt : Format.formatter) (typ : typ) : unit = + let rec aux bctx fmt typ = + match Mark.remove typ with + | TLit l -> Format.fprintf fmt "%a_of_jsoo" Print.tlit l + | TTuple [] -> Format.fprintf fmt "unit_of_jsoo" + | TTuple l -> + let i = ref (-1) in + Format.fprintf fmt "@[(fun js ->@,(%a))@]" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + (fun fmt t -> + incr i; + Format.fprintf fmt + "(@[let v = Js.Optdef.to_option (Js.array_get js %d) in@;\ + <1 0>match v with@;\ + <1 0>| None -> invalid_arg \"no value in tuple position %d\"@;\ + <1 0>| Some v -> %a (Js.Unsafe.coerce v)@])" + !i !i (aux bctx) t)) + l + | TStruct s -> + Format.fprintf fmt "%a.of_jsoo" format_to_module_name (`Sname s) + | TOption t -> + Format.fprintf fmt "(fun x -> Optional.of_jsoo %a x)" (aux bctx) t + | TDefault t -> aux bctx fmt t + | TEnum e -> + Format.fprintf fmt "%a.of_jsoo" format_to_module_name (`Ename e) + | TAbstract e -> + Format.fprintf fmt "%a.of_jsoo" format_to_module_name (`Aname e) + | TArrow (t1, t2) -> + let ip, ie = ref (-1), ref (-1) in + Format.fprintf fmt "(fun f -> (fun %a -> %a (f %a)))" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt _t -> + incr ip; + Format.fprintf fmt "_x%d" !ip)) + t1 (aux bctx) t2 + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt t -> + incr ie; + Format.fprintf fmt "(%a _x%d)" format_typ_to t !ie)) + t1 + | TArray t1 -> ( + match Mark.remove t1 with + | TVar _ | TClosureEnv -> Format.fprintf fmt "Js.to_array" + | _ -> + Format.fprintf fmt "(fun js -> Array.map %a (Js.to_array js))" + (aux bctx) t1) + | TVar _ -> Format.fprintf fmt "Js.Unsafe.coerce" + | TForAll tb -> + let _v, typ, bctx = Bindlib.unmbind_in bctx tb in + aux bctx fmt typ + | TClosureEnv -> Format.fprintf fmt "Js.Unsafe.coerce" + | TError -> assert false + in + aux Bindlib.empty_ctxt fmt typ + +let format_struct_field_typ (fmt : Format.formatter) (typ : typ) : unit = + Format.fprintf fmt "@[%a@] Js.prop" format_typ typ + +let format_struct_field_to + var + (fmt : Format.formatter) + ((name, typ) : StructField.t * typ) : unit = + Format.fprintf fmt "%a %s.%a" format_typ_to typ var + To_ocaml.format_struct_field_name (None, name) + +let format_struct_field_of + var + (fmt : Format.formatter) + ((name, typ) : StructField.t * typ) : unit = + Format.fprintf fmt "%a (%s ##. %a)" format_typ_of typ var + format_struct_field_name (None, name) + +let format_ctx + (type_ordering : TypeIdent.t list) + (ppml : Format.formatter) + (ppi : Format.formatter) + (ctx : decl_ctx) : unit = + let format_struct_decl (struct_name, struct_fields) = + if TypeIdent.(Set.mem (Struct struct_name) ctx.ctx_public_types) then + let fields = StructField.Map.bindings struct_fields in + if StructField.Map.is_empty struct_fields then ( + Format.fprintf ppi + "@[module %a : sig@,\ + type t = unit@,\ + type jsoo = unit@,\ + val to_jsoo : t -> jsoo@,\ + val of_jsoo : jsoo -> t@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Sname struct_name); + Format.fprintf ppml + "@[module %a = struct@,\ + include %a@,\ + type jsoo = unit@,\ + let to_jsoo = Fun.id@,\ + let of_jsoo = Fun.id@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Sname struct_name) + To_ocaml.format_to_module_name (`Sname struct_name)) + else + (Format.fprintf ppi + "@[module %a : sig@,\ + @[type t = %a.t = {@,\ + %a@;\ + <0-2>}@]@;\ + @[class type jsoo_ct = object@;\ + <1 0>%a@;\ + <1 -2>end@]@,\ + type jsoo = jsoo_ct Js.t@,\ + val to_jsoo : t -> jsoo@,\ + val of_jsoo : jsoo -> t@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Sname struct_name) + To_ocaml.format_to_module_name (`Sname struct_name) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") + (fun fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "@[%a:@ %a@]" + To_ocaml.format_struct_field_name (None, struct_field) + To_ocaml.format_typ struct_field_type)) + fields + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "@[method %a:@ %a@]" + format_struct_field_name (None, struct_field) + format_struct_field_typ struct_field_type)) + fields; + Format.fprintf ppml + "@[module %a = struct@,\ + include %a@,\ + @[class type jsoo_ct = object@;\ + <1 0>%a@;\ + <1 -2>end@]@,\ + type jsoo = jsoo_ct Js.t@,\ + @[let to_jsoo x = object%%js@;\ + <1 0>%a@;\ + <1 -2>end@]@;\ + @[let of_jsoo js = {@;\ + %a@;\ + <0 -2>}@]@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Sname struct_name) + To_ocaml.format_to_module_name (`Sname struct_name) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "@[method %a:@ %a@]" + format_struct_field_name (None, struct_field) + format_struct_field_typ struct_field_type)) + fields) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "@[val mutable %a =@ %a@]" + format_struct_field_name (None, struct_field) + (format_struct_field_to "x") + (struct_field, struct_field_type))) + fields + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") + (fun fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "@[%a =@ %a@]" + To_ocaml.format_struct_field_name (None, struct_field) + (format_struct_field_of "js") + (struct_field, struct_field_type))) + fields + in + let format_enum_decl (enum_name, enum_cons) = + if TypeIdent.(Set.mem (Enum enum_name) ctx.ctx_public_types) then + let variants = EnumConstructor.Map.bindings enum_cons in + let string_enum = + EnumConstructor.Map.for_all + (fun _ -> (function TLit TUnit, _ -> true | _ -> false)) + enum_cons + in + if string_enum then ( + Format.fprintf ppi + "@[module %a : sig@ @[type t =@ %a.t =@ %a%a%a@]@,\ + type jsoo = Js.js_string Js.t@,\ + val to_jsoo : t -> jsoo@,\ + val of_jsoo : jsoo -> t@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Ename enum_name) + To_ocaml.format_to_module_name (`Ename enum_name) + Format.pp_print_if_newline () Format.pp_print_string "| " + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ") + (fun fmt (enum_cons, enum_cons_type) -> + match enum_cons_type with + | TLit TUnit, _ -> + Format.fprintf fmt "@[%a@]" + To_ocaml.format_enum_cons_name enum_cons + | _ -> + Format.fprintf fmt "@[%a of@ %a@]" + To_ocaml.format_enum_cons_name enum_cons format_typ + enum_cons_type)) + variants; + Format.fprintf ppml + "@[module %a = struct@ @[include %a@,\ + type jsoo = Js.js_string Js.t@,\ + @[let to_jsoo x = Js.string (match x with %a%a%a)@]@,\ + @[let of_jsoo js = match Js.to_string js with %a%a%a@,\ + @ |@[ s -> invalid_arg (Format.sprintf \"unknown case in enum: \ + %%S\" s)@]@]@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Ename enum_name) + To_ocaml.format_to_module_name (`Ename enum_name) + Format.pp_print_if_newline () Format.pp_print_string "| " + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ") + (fun fmt (enum_cons, _) -> + Format.fprintf fmt "@[%a -> \"%a\"@]" + To_ocaml.format_enum_cons_name enum_cons + To_ocaml.format_enum_cons_name enum_cons)) + variants Format.pp_print_if_newline () Format.pp_print_string "| " + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ") + (fun fmt (enum_cons, _) -> + Format.fprintf fmt "@[\"%a\" -> %a@]" + To_ocaml.format_enum_cons_name enum_cons + To_ocaml.format_enum_cons_name enum_cons)) + variants) + else ( + Format.fprintf ppi + "@[module %a : sig@ @[type t =@ %a.t =@ %a%a%a@]@,\ + @[class type jsoo_ct = object@;\ + <1 0>%a@;\ + <1 -2>end@]@,\ + type jsoo = jsoo_ct Js.t@,\ + val to_jsoo : t -> jsoo@,\ + val of_jsoo : jsoo -> t@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Ename enum_name) + To_ocaml.format_to_module_name (`Ename enum_name) + Format.pp_print_if_newline () Format.pp_print_string "| " + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ") + (fun fmt (enum_cons, enum_cons_type) -> + match enum_cons_type with + | TLit TUnit, _ -> + Format.fprintf fmt "@[%a@]" + To_ocaml.format_enum_cons_name enum_cons + | _ -> + Format.fprintf fmt "@[%a of@ %a@]" + To_ocaml.format_enum_cons_name enum_cons To_ocaml.format_typ + enum_cons_type)) + variants + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt (enum_cons, enum_cons_type) -> + Format.fprintf fmt "@[method %a :@ %a Js.optdef Js.prop@]" + format_enum_cons_name enum_cons format_typ enum_cons_type)) + variants; + Format.fprintf ppml + "@[module %a = struct@ @[include %a@,\ + @[class type jsoo_ct = object@;\ + <1 0>%a@;\ + <1 -2>end@]@,\ + type jsoo = jsoo_ct Js.t@,\ + @[let to_jsoo x = match x with %a%a%a@]@,\ + @[let of_jsoo js = match %a with@;\ + %a%a%a@,\ + @ |@[ _ -> invalid_arg \"unknown case\"@]@]@;\ + <1 -2>end@]@,\ + @," + To_ocaml.format_to_module_name (`Ename enum_name) + To_ocaml.format_to_module_name (`Ename enum_name) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt (enum_cons, enum_cons_type) -> + Format.fprintf fmt "@[method %a :@ %a Js.optdef Js.prop@]" + format_enum_cons_name enum_cons format_typ enum_cons_type)) + variants Format.pp_print_if_newline () Format.pp_print_string "| " + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ") + (fun fmt (enum_cons, enum_cons_type) -> + let no_content = + match enum_cons_type with TLit TUnit, _ -> true | _ -> false + in + Format.fprintf fmt + "@[%a%a -> object%%js@;<1 0>%a@;<1 -2>end@]@," + To_ocaml.format_enum_cons_name enum_cons + (fun fmt b -> if not b then Format.fprintf fmt "@ x") + no_content + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt (enum_cons2, _) -> + if enum_cons <> enum_cons2 then + Format.fprintf fmt + "@[val mutable %a =@ Js.undefined@]@," + format_enum_cons_name enum_cons2 + else + Format.fprintf fmt + "@[val mutable %a =@ Js.def (%a@ %a)@]@," + format_enum_cons_name enum_cons format_typ_to + enum_cons_type + (fun fmt b -> + if not b then Format.fprintf fmt "x" + else Format.fprintf fmt "()") + no_content)) + variants)) + variants + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + (fun fmt (enum_cons, _) -> + Format.fprintf fmt "@[Js.Optdef.to_option (js##.%a)@]" + format_enum_cons_name enum_cons)) + variants Format.pp_print_if_newline () Format.pp_print_string "| " + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ") + (fun fmt (enum_cons, enum_cons_type) -> + let no_content = + match enum_cons_type with TLit TUnit, _ -> true | _ -> false + in + Format.fprintf fmt "@[%a -> %a%a@]@," + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + (fun fmt (enum_cons2, _) -> + if enum_cons <> enum_cons2 then Format.fprintf fmt "_" + else Format.fprintf fmt "Some _c")) + variants To_ocaml.format_enum_cons_name enum_cons + (fun fmt b -> + if not b then + Format.fprintf fmt "@ (%a _c)" format_typ_of enum_cons_type) + no_content)) + variants) + in + let is_in_type_ordering s = + List.exists + (fun struct_or_enum -> + match struct_or_enum with + | TypeIdent.Enum _ | TypeIdent.Abstract _ -> false + | TypeIdent.Struct s' -> s = s') + type_ordering + in + let scope_structs = + List.map + (fun (s, _) -> TypeIdent.Struct s) + (StructName.Map.bindings + (StructName.Map.filter + (fun s _ -> not (is_in_type_ordering s)) + ctx.ctx_structs)) + in + List.iter + (function + | TypeIdent.Struct s -> + let def = StructName.Map.find s ctx.ctx_structs in + if StructName.path s = [] then format_struct_decl (s, def) + | TypeIdent.Enum e -> + if EnumName.equal e Expr.option_enum then () + else + let def = EnumName.Map.find e ctx.ctx_enums in + if EnumName.path e = [] then format_enum_decl (e, def) + | _ -> ()) + (type_ordering @ scope_structs) + +let format_code_items + (ppml : Format.formatter) + (ppi : Format.formatter) + (code_items : 'm Ast.expr code_item_list) = + pp [ppml; ppi] "@["; + let acc, _exports = + BoundList.fold_left code_items ~init:[] ~f:(fun acc item var -> + match item with + | Topdef (_name, typ, vis, _e) -> + if vis = Public then ( + Format.fprintf ppi "@,@[val %a_jsoo : %a@]@," + To_ocaml.format_var var format_typ typ; + let rec aux bctx typ = + match Mark.remove typ with + | TArrow (lt, te) | TDefault (TArrow (lt, te), _) -> + let ip, ie = ref (-1), ref (-1) in + Format.fprintf ppml + "@,\ + @[@[let %a_jsoo : %a =@]@ fun %a -> %a (%a \ + %a)@]@," + To_ocaml.format_var var format_typ typ + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt _t -> + incr ip; + Format.fprintf fmt "_x%d" !ip)) + lt format_typ_to te To_ocaml.format_var var + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt t -> + incr ie; + Format.fprintf fmt "(%a _x%d)" format_typ_of t !ie)) + lt; + `meth (var, lt, te) + | TForAll tb -> + let _v, typ, bctx = Bindlib.unmbind_in bctx tb in + aux bctx typ + | _ -> + Format.fprintf ppml + "@,@[@[let %a_jsoo : %a =@]@ %a %a@]@," + To_ocaml.format_var var format_typ typ format_typ_to typ + To_ocaml.format_var var; + `value (var, typ) + in + aux Bindlib.empty_ctxt typ :: acc) + else acc + | ScopeDef (_name, body) -> + if body.scope_body_visibility = Public then ( + let scope_input_var, _scope_body_expr = + Bindlib.unbind body.scope_body_expr + in + Format.fprintf ppi + "@,@[val %a_jsoo :@ @[%a.jsoo ->@ %a.jsoo@]@]@," + To_ocaml.format_var var format_to_module_name + (`Sname body.scope_body_input_struct) format_to_module_name + (`Sname body.scope_body_output_struct); + Format.fprintf ppml + "@,\ + @[@[let %a_jsoo :@ %a.jsoo -> %a.jsoo =@ fun %a \ + ->@]@ %a.to_jsoo (%a (%a.of_jsoo %a))@]@," + To_ocaml.format_var var format_to_module_name + (`Sname body.scope_body_input_struct) format_to_module_name + (`Sname body.scope_body_output_struct) To_ocaml.format_var + scope_input_var format_to_module_name + (`Sname body.scope_body_output_struct) To_ocaml.format_var var + format_to_module_name (`Sname body.scope_body_input_struct) + To_ocaml.format_var scope_input_var; + `scope + (var, body.scope_body_input_struct, body.scope_body_output_struct) + :: acc) + else acc) + in + pp [ppml; ppi] "@]"; + List.rev acc + +let export_code_items ppml ppi modname exports = + pp [ppml; ppi] + "@[class type default_ct = object@;\ + <1 0>%a@;\ + <1 -2>end@]@,\ + @,\ + type default = default_ct Js.t@,\ + @," + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt e -> + match e with + | `value (v, t) -> + Format.fprintf fmt "@[method %a :@ %a Js.prop@]" + format_method_var v format_typ t + | `meth (v, lt, te) -> + Format.fprintf fmt "@[method %a :@ %a Js.meth@]" + format_method_var v format_typ + (Mark.ghost (TArrow (lt, te))) + | `scope (v, i, o) -> + Format.fprintf fmt + "@[method %a :@ %a.jsoo -> %a.jsoo Js.meth@]" + format_method_var v format_to_module_name (`Sname i) + format_to_module_name (`Sname o))) + exports; + + Format.fprintf ppml + "@[let default : default = object%%js@;\ + <1 0>%a@;\ + <1 -2>end@]@,\ + @,\ + let () = %a default" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") + (fun fmt e -> + match e with + | `value (v, _) -> + Format.fprintf fmt "@[val mutable %a =@ %a_jsoo@]" + format_method_var v To_ocaml.format_var v + | `meth (v, lt, _) -> + let ip, ie = ref (-1), ref (-1) in + Format.fprintf fmt "@[method %a %a =@ %a_jsoo %a@]" + format_method_var v + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt _ -> + incr ip; + Format.fprintf fmt "x%d" !ip)) + lt To_ocaml.format_var v + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + (fun fmt _ -> + incr ie; + Format.fprintf fmt "x%d" !ie)) + lt + | `scope (v, _, _) -> + Format.fprintf fmt "@[method %a x =@ %a_jsoo x@]" + format_method_var v To_ocaml.format_var v)) + exports + (fun fmt m -> + match m with + | None -> Format.fprintf fmt "Js.export_all" + | Some m -> Format.fprintf fmt "Js.export \"%s\"" m) + modname; + Format.fprintf ppi "val default : default@," + +let format_program + output_file + ppml + ~(hashf : Hash.t -> Hash.full) + (p : 'm Ast.program) + (type_ordering : TypeIdent.t list) : unit = + ignore hashf; + File.with_secondary_out_channel ~output_file ~ext:"mli" + @@ fun intf_file ppi -> + let modname = + match p.module_name, output_file with + | Some (n, _), _ -> Some (ModuleName.to_string n) + | None, Some filename -> + Some + (String.capitalize_ascii (String.to_id File.(basename filename -.- ""))) + | _ -> None + in + pp [ppml; ppi] + "@[[%@%@%@ocaml.warning \"-4-26-27-32-33-34-37-41-42-69\"]@,\ + @,\ + open Js_of_ocaml@,\ + open Catala_runtime@,\ + open Catala_runtime_jsoo@,\ + %a@,\ + @," + (fun fmt o -> Option.iter (Format.fprintf fmt "open %s@,") o) + modname; + format_ctx type_ordering ppml ppi p.decl_ctx; + let exports = format_code_items ppml ppi p.code_items in + export_code_items ppml ppi modname exports; + pp [ppml; ppi] "@]"; + Format.pp_print_flush ppml (); + Format.pp_print_flush ppi (); + Option.iter Ocamlformat.format output_file; + Option.iter Ocamlformat.format intf_file diff --git a/compiler/lcalc/to_jsoo_interface.mli b/compiler/lcalc/to_jsoo_interface.mli new file mode 100644 index 000000000..7729d261e --- /dev/null +++ b/compiler/lcalc/to_jsoo_interface.mli @@ -0,0 +1,28 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Catala_utils +open Shared_ast + +val format_program : + File.t option -> + Format.formatter -> + hashf:(Hash.t -> Hash.full) -> + 'm Ast.program -> + TypeIdent.t list -> + unit +(** Usage [format_program get_fmt p type_dependencies_ordering]. Either one of + these may be set *) diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index 1ee457c67..00e60a0b2 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -32,11 +32,14 @@ val format_struct_field_name : Format.formatter -> StructName.t option * StructField.t -> unit val format_to_module_name : - Format.formatter -> [< `Ename of EnumName.t | `Sname of StructName.t ] -> unit + Format.formatter -> + [< `Ename of EnumName.t | `Sname of StructName.t | `Aname of AbstractType.t ] -> + unit (* * val format_lit : Format.formatter -> lit Mark.pos -> unit * val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit *) val format_var : Format.formatter -> 'm Var.t -> unit +val format_typ : Format.formatter -> typ -> unit val format_program : File.t option -> diff --git a/compiler/manpages.sexp b/compiler/manpages.sexp index eb8a80671..57d1163c0 100644 --- a/compiler/manpages.sexp +++ b/compiler/manpages.sexp @@ -8,6 +8,7 @@ (rule (alias man) (action (with-stdout-to catala-interpret.1 (run %{bin:catala} interpret --help=groff)))) (rule (alias man) (action (with-stdout-to catala-java.1 (run %{bin:catala} java --help=groff)))) (rule (alias man) (action (with-stdout-to catala-json-schema.1 (run %{bin:catala} json-schema --help=groff)))) +(rule (alias man) (action (with-stdout-to catala-jsoo.1 (run %{bin:catala} jsoo --help=groff)))) (rule (alias man) (action (with-stdout-to catala-latex.1 (run %{bin:catala} latex --help=groff)))) (rule (alias man) (action (with-stdout-to catala-lcalc.1 (run %{bin:catala} lcalc --help=groff)))) (rule (alias man) (action (with-stdout-to catala-makefile.1 (run %{bin:catala} makefile --help=groff)))) diff --git a/runtimes/dune b/runtimes/dune index dbc54f563..02ede9b89 100644 --- a/runtimes/dune +++ b/runtimes/dune @@ -19,8 +19,10 @@ (install (files - (jsoo/runtime_jsoo.ml as runtime/jsoo/runtime_jsoo.ml) - (jsoo/runtime_jsoo.mli as runtime/jsoo/runtime_jsoo.mli)) + (jsoo/dates_calc_jsoo.ml as runtime/jsoo/dates_calc_jsoo.ml) + (jsoo/dates_calc_jsoo.mli as runtime/jsoo/dates_calc_jsoo.mli) + (jsoo/catala_runtime_jsoo.ml as runtime/jsoo/catala_runtime_jsoo.ml) + (jsoo/catala_runtime_jsoo.mli as runtime/jsoo/catala_runtime_jsoo.mli)) (section lib)) ; Python runtime diff --git a/runtimes/jsoo/catala_runtime_jsoo.ml b/runtimes/jsoo/catala_runtime_jsoo.ml new file mode 100644 index 000000000..8f7f4111a --- /dev/null +++ b/runtimes/jsoo/catala_runtime_jsoo.ml @@ -0,0 +1,298 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Emile Rolley . + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Js_of_ocaml +open Catala_runtime + +type unit_jsoo = unit + +let unit_to_jsoo = Fun.id +let unit_of_jsoo = Fun.id + +type bool_jsoo = bool Js.t + +let bool_to_jsoo = Js.bool +let bool_of_jsoo = Js.to_bool + +class type bigInt = object + method toLocalString : Js.js_string Js.t -> Js.js_string Js.t Js.meth + + method toLocalString_withopt : + Js.js_string Js.t -> Js.Unsafe.any -> Js.js_string Js.t Js.meth + + method toString : Js.js_string Js.t Js.meth + method toString_base : int -> Js.js_string Js.t Js.meth + method valueOf : bigInt Js.t Js.meth +end + +class type decimal_ct = object + method n : bigInt Js.t Js.prop + method d : bigInt Js.t Js.prop +end + +let bigInt (x : 'a Js.t) : bigInt Js.t = Js.Unsafe.global##_BigInt x + +type money_jsoo = bigInt Js.t + +let money_to_jsoo z = bigInt (Js.string (Z.to_string z)) +let money_of_jsoo js = Z.of_string (Js.to_string js##toString) + +type integer_jsoo = bigInt Js.t + +let integer_to_jsoo z = bigInt (Js.string (Z.to_string z)) +let integer_of_jsoo js = Z.of_string (Js.to_string js##toString) + +type decimal_jsoo = decimal_ct Js.t + +let decimal_to_jsoo q = + object%js + val mutable n = bigInt (Js.string (Z.to_string (Q.num q))) + val mutable d = bigInt (Js.string (Z.to_string (Q.den q))) + end + +let decimal_of_jsoo js = + Q.make + (Z.of_string (Js.to_string js##.n##toString)) + (Z.of_string (Js.to_string js##.d##toString)) + +type date_jsoo = Dates_calc_jsoo.date_jsoo + +let date_to_jsoo = Dates_calc_jsoo.date_to_jsoo +let date_of_jsoo = Dates_calc_jsoo.date_of_jsoo + +type date_rounding_jsoo = Dates_calc_jsoo.date_rounding_jsoo + +let date_rounding_to_jsoo = Dates_calc_jsoo.date_rounding_to_jsoo +let date_rounding_of_jsoo = Dates_calc_jsoo.date_rounding_of_jsoo + +type duration_jsoo = Dates_calc_jsoo.period_jsoo + +let duration_to_jsoo = Dates_calc_jsoo.period_to_jsoo +let duration_of_jsoo = Dates_calc_jsoo.period_of_jsoo + +module Optional = struct + include Optional + + class type ['a] ct = object + method _Absent : unit_jsoo Js.optdef Js.prop + method _Present : 'a Js.optdef Js.prop + end + + type 'a jsoo = 'a ct Js.t + + let to_jsoo a_to_jsoo x = + match x with + | Absent -> + object%js + val mutable _Absent = Js.def () + val mutable _Present = Js.undefined + end + | Present a -> + object%js + val mutable _Absent = Js.undefined + val mutable _Present = Js.def (a_to_jsoo a) + end + + let of_jsoo a_of_jsoo js = + match + Js.Optdef.to_option js##._Absent, Js.Optdef.to_option js##._Present + with + | Some _, _ -> Absent + | _, Some a -> Present (a_of_jsoo a) + | _ -> invalid_arg "unknown case" +end + +type io_input_jsoo = Js.js_string Js.t + +let io_input_to_jsoo x = + Js.string + @@ + match x with + | NoInput -> "NoInput" + | OnlyInput -> "OnlyInput" + | Reentrant -> "Reentrant" + +let io_input_of_jsoo js = + match Js.to_string js with + | "NoInput" -> NoInput + | "OnlyInput" -> OnlyInput + | "Reentrant" -> Reentrant + | s -> invalid_arg (Format.sprintf "unknown case in enum: %S" s) + +class type io_log_ct = object + method io_input_ : io_input_jsoo Js.prop + method io_output_ : bool Js.t Js.prop +end + +type io_log_jsoo = io_log_ct Js.t + +let io_log_to_jsoo x = + object%js + val mutable io_input_ = io_input_to_jsoo x.io_input + val mutable io_output_ = Js.bool x.io_output + end + +let io_log_of_jsoo js = + { + io_input = io_input_of_jsoo js##.io_input_; + io_output = Js.to_bool js##.io_output_; + } + +class type code_location_ct = object + method fileName : Js.js_string Js.t Js.prop + method startLine : int Js.prop + method endLine : int Js.prop + method startColumn : int Js.prop + method endColumn : int Js.prop + method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop +end + +type code_location_jsoo = code_location_ct Js.t + +let code_location_to_jsoo (pos : code_location) : code_location_jsoo = + object%js + val mutable fileName = Js.string pos.filename + val mutable startLine = pos.start_line + val mutable endLine = pos.end_line + val mutable startColumn = pos.start_column + val mutable endColumn = pos.end_column + + val mutable lawHeadings = + Array.of_list pos.law_headings |> Array.map Js.string |> Js.array + end + +let code_location_of_jsoo (jpos : code_location_jsoo) : code_location = + { + filename = Js.to_string jpos##.fileName; + start_line = jpos##.startLine; + start_column = jpos##.startColumn; + end_line = jpos##.endLine; + end_column = jpos##.endColumn; + law_headings = + Js.to_array jpos##.lawHeadings |> Array.map Js.to_string |> Array.to_list; + } + +type error_jsoo = Js.js_string Js.t + +let error_to_jsoo e = Js.string (error_to_string e) +let error_of_jsoo js = error_of_string (Js.to_string js) + +class type raw_event = object + method eventType : Js.js_string Js.t Js.prop + method information : Js.js_string Js.t Js.js_array Js.t Js.prop + method sourcePosition : code_location_jsoo Js.optdef Js.prop + method loggedIOJson : Js.js_string Js.t Js.prop + method loggedValueJson : Js.js_string Js.t Js.prop +end + +class type event = object + method data : Js.js_string Js.t Js.prop +end + +class type event_manager = object + method resetLog : unit Js.meth + method retrieveEvents : event Js.t Js.js_array Js.t Js.meth + method retrieveRawEvents : raw_event Js.t Js.js_array Js.t Js.meth +end + +let event_manager : event_manager Js.t = + object%js (_self) + method resetLog = reset_log () + + method retrieveEvents = + retrieve_log () + |> EventParser.parse_raw_events + |> List.map (fun event -> + object%js + val mutable data = event |> Json.event |> Js.string + end) + |> Array.of_list + |> Js.array + + method retrieveRawEvents = + let evt_to_js evt = + (* FIXME: ideally this could be just a Json.parse (Json.event foo) ? *) + object%js + val mutable eventType = + (match evt with + | BeginCall _ -> "Begin call" + | EndCall _ -> "End call" + | VariableDefinition _ -> "Variable definition" + | DecisionTaken _ -> "Decision taken") + |> Js.string + + val mutable information = + (match evt with + | BeginCall info | EndCall info | VariableDefinition (info, _, _) + -> + List.map Js.string info + | DecisionTaken _ -> []) + |> Array.of_list + |> Js.array + + val mutable loggedIOJson = + match evt with + | VariableDefinition (_, io, _) -> io |> Json.io_log |> Js.string + | EndCall _ | BeginCall _ | DecisionTaken _ -> + "unavailable" |> Js.string + + val mutable loggedValueJson = + (match evt with + | VariableDefinition (_, _, v) -> v + | EndCall _ | BeginCall _ | DecisionTaken _ -> unembeddable ()) + |> Json.runtime_value + |> Js.string + + val mutable sourcePosition = + match evt with + | DecisionTaken pos -> + Js.def + (object%js + val mutable fileName = Js.string pos.filename + val mutable startLine = pos.start_line + val mutable endLine = pos.end_line + val mutable startColumn = pos.start_column + val mutable endColumn = pos.end_column + + val mutable lawHeadings = + List.map Js.string pos.law_headings + |> Array.of_list + |> Js.array + end) + | _ -> Js.undefined + end + in + retrieve_log () |> List.map evt_to_js |> Array.of_list |> Js.array + end + +let execute_or_throw_error f = + try f () + with Error _ as exc -> + let msg = Js.string (Printexc.to_string exc) in + Js.Js_error.raise_ + (Js.Js_error.of_error + (object%js + val mutable name = Js.string "CatalaError" + val mutable message = msg + val mutable stack = Js.Optdef.empty + method toString = msg + end)) + +let () = + Js.export_all + (object%js + val eventsManager = event_manager + end) diff --git a/runtimes/jsoo/runtime_jsoo.mli b/runtimes/jsoo/catala_runtime_jsoo.mli similarity index 57% rename from runtimes/jsoo/runtime_jsoo.mli rename to runtimes/jsoo/catala_runtime_jsoo.mli index 019d354f4..7d7da0db2 100644 --- a/runtimes/jsoo/runtime_jsoo.mli +++ b/runtimes/jsoo/catala_runtime_jsoo.mli @@ -18,11 +18,96 @@ wrapper around the {!module: Runtime}. *) open Js_of_ocaml +open Catala_runtime -(** {1 Log events} *) +type unit_jsoo = unit -(** Information about the position of the log inside the Catala source file. *) -class type code_location = object +val unit_to_jsoo : unit -> unit_jsoo +val unit_of_jsoo : unit_jsoo -> unit + +type bool_jsoo = bool Js.t + +val bool_to_jsoo : bool -> bool_jsoo +val bool_of_jsoo : bool_jsoo -> bool + +class type bigInt = object + method toLocalString : Js.js_string Js.t -> Js.js_string Js.t Js.meth + + method toLocalString_withopt : + Js.js_string Js.t -> Js.Unsafe.any -> Js.js_string Js.t Js.meth + + method toString : Js.js_string Js.t Js.meth + method toString_base : int -> Js.js_string Js.t Js.meth + method valueOf : bigInt Js.t Js.meth +end + +class type decimal_ct = object + method n : bigInt Js.t Js.prop + method d : bigInt Js.t Js.prop +end + +val bigInt : 'a Js.t -> bigInt Js.t + +type money_jsoo = bigInt Js.t + +val money_to_jsoo : money -> money_jsoo +val money_of_jsoo : money_jsoo -> money + +type integer_jsoo = bigInt Js.t + +val integer_to_jsoo : integer -> integer_jsoo +val integer_of_jsoo : integer_jsoo -> integer + +type decimal_jsoo = decimal_ct Js.t + +val decimal_to_jsoo : decimal -> decimal_jsoo +val decimal_of_jsoo : decimal_jsoo -> decimal + +type date_jsoo = Dates_calc_jsoo.date_jsoo + +val date_to_jsoo : date -> date_jsoo +val date_of_jsoo : date_jsoo -> date + +type date_rounding_jsoo = Dates_calc_jsoo.date_rounding_jsoo + +val date_rounding_to_jsoo : date_rounding -> date_rounding_jsoo +val date_rounding_of_jsoo : date_rounding_jsoo -> date_rounding + +type duration_jsoo = Dates_calc_jsoo.period_jsoo + +val duration_to_jsoo : duration -> duration_jsoo +val duration_of_jsoo : duration_jsoo -> duration + +module Optional : sig + type 'a t = 'a Catala_runtime.Optional.t = Absent | Present of 'a + + class type ['a] ct = object + method _Absent : unit_jsoo Js.optdef Js.prop + method _Present : 'a Js.optdef Js.prop + end + + type 'a jsoo = 'a ct Js.t + + val to_jsoo : ('a -> 'a_jsoo) -> 'a t -> 'a_jsoo jsoo + val of_jsoo : ('a_jsoo -> 'a) -> 'a_jsoo jsoo -> 'a t +end + +type io_input_jsoo = Js.js_string Js.t + +val io_input_to_jsoo : io_input -> io_input_jsoo +val io_input_of_jsoo : io_input_jsoo -> io_input + +class type io_log_ct = object + method io_input_ : io_input_jsoo Js.prop + method io_output_ : bool Js.t Js.prop +end + +type io_log_jsoo = io_log_ct Js.t + +val io_log_to_jsoo : io_log -> io_log_jsoo +val io_log_of_jsoo : io_log_jsoo -> io_log + +class type code_location_ct = object method fileName : Js.js_string Js.t Js.prop method startLine : int Js.prop method endLine : int Js.prop @@ -31,6 +116,16 @@ class type code_location = object method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop end +type code_location_jsoo = code_location_ct Js.t + +val code_location_to_jsoo : code_location -> code_location_jsoo +val code_location_of_jsoo : code_location_jsoo -> code_location + +type error_jsoo = Js.js_string Js.t + +val error_to_jsoo : error -> error_jsoo +val error_of_jsoo : error_jsoo -> error + (** Wrapper for the {!type: Runtime.raw_event} -- directly collected during the program execution.*) class type raw_event = object @@ -58,7 +153,7 @@ class type raw_event = object letter [Subscope_name] or, the [input] (resp. [output]) string -- which corresponds to the input (resp. the output) of a function. *) - method sourcePosition : code_location Js.t Js.optdef Js.prop + method sourcePosition : code_location_jsoo Js.optdef Js.prop method loggedIOJson : Js.js_string Js.t Js.prop (** Serialzed [Runtime.io_log] corresponding to a `VariableDefinition` raw @@ -85,32 +180,6 @@ end val event_manager : event_manager Js.t (** JS object usable to retrieve and reset log events. *) -(** {1 Duration} *) - -(** Simple JSOO wrapper around {!type: Runtime.duration}.*) -class type duration = object - method years : int Js.readonly_prop - method months : int Js.readonly_prop - method days : int Js.readonly_prop -end - -val duration_of_js : duration Js.t -> Catala_runtime.duration -val duration_to_js : Catala_runtime.duration -> duration Js.t - -(** {1 Date conversion} *) - -(** Date values are encoded to a string in the - {{:https://www.iso.org/iso-8601-date-and-time-format.html} ISO8601 format}: - 'YYYY-MM-DD'. *) - -val date_of_js : Js.js_string Js.t -> Catala_runtime.date -val date_to_js : Catala_runtime.date -> Js.js_string Js.t - -(** {1 Error management} *) - -val position_of_js : code_location Js.t -> Catala_runtime.code_location -val position_to_js : Catala_runtime.code_location -> code_location Js.t - val execute_or_throw_error : (unit -> 'a) -> 'a (** [execute_or_throw_error f] calls [f ()] and propagates the {!Catala_runtime.NoValue}, {!Catala_runtime.Conflict} diff --git a/runtimes/jsoo/dates_calc_jsoo.ml b/runtimes/jsoo/dates_calc_jsoo.ml new file mode 100644 index 000000000..284ce7f55 --- /dev/null +++ b/runtimes/jsoo/dates_calc_jsoo.ml @@ -0,0 +1,157 @@ +open Js_of_ocaml +open Dates_calc + +class type date_jsoo_ct = object + method year : int Js.prop + method month : int Js.prop + method day : int Js.prop +end + +type date_jsoo = date_jsoo_ct Js.t + +let date_to_jsoo : date -> date_jsoo = + fun d -> + let y, m, d = date_to_ymd d in + object%js + val mutable year = y + val mutable month = m + val mutable day = d + end + +let date_of_jsoo : date_jsoo -> date = + fun js -> make_date ~year:js##.year ~month:js##.month ~day:js##.day + +class type period_jsoo_ct = object + method years : int Js.prop + method months : int Js.prop + method days : int Js.prop +end + +type period_jsoo = period_jsoo_ct Js.t + +let period_to_jsoo : period -> period_jsoo = + fun p -> + let y, m, d = period_to_ymds p in + object%js + val mutable years = y + val mutable months = m + val mutable days = d + end + +let period_of_jsoo : period_jsoo -> period = + fun js -> make_period ~years:js##.years ~months:js##.months ~days:js##.days + +type date_rounding_jsoo = Js.js_string Js.t + +let date_rounding_to_jsoo x = + Js.string + @@ + match x with + | RoundUp -> "RoundUp" + | RoundDown -> "RoundDown" + | AbortOnRound -> "AbortOnRound" + +let date_rounding_of_jsoo js = + match Js.to_string js with + | "RoundUp" -> RoundUp + | "RoundDown" -> RoundDown + | "AbortOnRound" -> AbortOnRound + | s -> invalid_arg (Format.sprintf "unknown case in enum: %S" s) + +let make_date_jsoo year month day = date_to_jsoo (make_date ~year ~month ~day) + +let add_dates_jsoo d p round = + let round = Option.map date_rounding_of_jsoo (Js.Optdef.to_option round) in + date_to_jsoo (add_dates ?round (date_of_jsoo d) (period_of_jsoo p)) + +let sub_dates_jsoo d1 d2 = + period_to_jsoo (sub_dates (date_of_jsoo d1) (date_of_jsoo d2)) + +let compare_dates_jsoo d1 d2 = compare_dates (date_of_jsoo d1) (date_of_jsoo d2) +let date_to_ymd_jsoo d = Js.array [| d##.year; d##.month; d##.day |] + +let date_to_string_jsoo js = + Js.string (Format.asprintf "%a" format_date (date_of_jsoo js)) + +let date_of_string_jsoo s = date_to_jsoo (date_of_string (Js.to_string s)) + +let first_day_of_month_jsoo d = + date_to_jsoo (first_day_of_month (date_of_jsoo d)) + +let last_day_of_month_jsoo d = date_to_jsoo (last_day_of_month (date_of_jsoo d)) +let is_leap_year_jsoo y = Js.bool (is_leap_year y) + +let make_period_jsoo years months days = + period_to_jsoo (make_period ~years ~months ~days) + +let neg_period_jsoo p = period_to_jsoo (neg_period (period_of_jsoo p)) + +let add_periods_jsoo p1 p2 = + period_to_jsoo (add_periods (period_of_jsoo p1) (period_of_jsoo p2)) + +let sub_periods_jsoo p1 p2 = + period_to_jsoo (sub_periods (period_of_jsoo p1) (period_of_jsoo p2)) + +let mul_period_jsoo p i = period_to_jsoo (mul_period (period_of_jsoo p) i) +let period_of_string_jsoo s = period_to_jsoo (period_of_string (Js.to_string s)) + +let period_to_string_jsoo js = + Js.string (Format.asprintf "%a" format_period (period_of_jsoo js)) + +let period_to_days_jsoo p = period_to_days (period_of_jsoo p) +let period_to_ymds_jsoo p = Js.array [| p##.years; p##.months; p##.days |] + +class type default_ct = object + method make_date_ : int -> int -> int -> date_jsoo Js.meth + + method add_dates_ : + date_jsoo -> + period_jsoo -> + date_rounding_jsoo Js.optdef -> + date_jsoo Js.meth + + method sub_dates_ : date_jsoo -> date_jsoo -> period_jsoo Js.meth + method compare_dates_ : date_jsoo -> date_jsoo -> int Js.meth + method date_to_ymd_ : date_jsoo -> int Js.js_array Js.t Js.meth + method date_of_string_ : Js.js_string Js.t -> date_jsoo Js.meth + method date_to_string_ : date_jsoo -> Js.js_string Js.t Js.meth + method first_day_of_month_ : date_jsoo -> date_jsoo Js.meth + method last_day_of_month_ : date_jsoo -> date_jsoo Js.meth + method is_leap_year_ : int -> bool Js.t Js.meth + method make_period_ : int -> int -> int -> period_jsoo Js.meth + method neg_period_ : period_jsoo -> period_jsoo Js.meth + method add_periods_ : period_jsoo -> period_jsoo -> period_jsoo Js.meth + method sub_periods_ : period_jsoo -> period_jsoo -> period_jsoo Js.meth + method mul_period_ : period_jsoo -> int -> period_jsoo Js.meth + method period_of_string_ : Js.js_string Js.t -> period_jsoo Js.meth + method period_to_string_ : period_jsoo -> Js.js_string Js.t Js.meth + method period_to_days_ : period_jsoo -> int Js.meth + method period_to_ymds_ : period_jsoo -> int Js.js_array Js.t Js.meth +end + +type default = default_ct Js.t + +let default : default = + object%js + method make_date_ y m d = make_date_jsoo y m d + method add_dates_ d p r = add_dates_jsoo d p r + method sub_dates_ d1 d2 = sub_dates_jsoo d1 d2 + method compare_dates_ d1 d2 = compare_dates_jsoo d1 d2 + method date_to_ymd_ d = date_to_ymd_jsoo d + method date_of_string_ s = date_of_string_jsoo s + method date_to_string_ s = date_to_string_jsoo s + method first_day_of_month_ d = first_day_of_month_jsoo d + method last_day_of_month_ d = last_day_of_month_jsoo d + method is_leap_year_ y = is_leap_year_jsoo y + method make_period_ y m d = make_period_jsoo y m d + method neg_period_ p = neg_period_jsoo p + method add_periods_ p1 p2 = add_periods_jsoo p1 p2 + method sub_periods_ p1 p2 = sub_periods_jsoo p1 p2 + method mul_period_ p i = mul_period_jsoo p i + method period_of_string_ s = period_of_string_jsoo s + method period_to_string_ s = period_to_string_jsoo s + method period_to_days_ p = period_to_days_jsoo p + method period_to_ymds_ p = period_to_ymds_jsoo p + end + +let () = Js.export "Dates_calc" default diff --git a/runtimes/jsoo/dates_calc_jsoo.mli b/runtimes/jsoo/dates_calc_jsoo.mli new file mode 100644 index 000000000..7951a2263 --- /dev/null +++ b/runtimes/jsoo/dates_calc_jsoo.mli @@ -0,0 +1,83 @@ +open Js_of_ocaml +open Dates_calc + +class type date_jsoo_ct = object + method year : int Js.prop + method month : int Js.prop + method day : int Js.prop +end + +type date_jsoo = date_jsoo_ct Js.t + +val date_to_jsoo : date -> date_jsoo +val date_of_jsoo : date_jsoo -> date + +class type period_jsoo_ct = object + method years : int Js.prop + method months : int Js.prop + method days : int Js.prop +end + +type period_jsoo = period_jsoo_ct Js.t + +val period_to_jsoo : period -> period_jsoo +val period_of_jsoo : period_jsoo -> period + +type date_rounding_jsoo = Js.js_string Js.t + +val date_rounding_to_jsoo : date_rounding -> date_rounding_jsoo +val date_rounding_of_jsoo : date_rounding_jsoo -> date_rounding +val make_date_jsoo : int -> int -> int -> date_jsoo + +val add_dates_jsoo : + date_jsoo -> period_jsoo -> date_rounding_jsoo Js.optdef -> date_jsoo + +val sub_dates_jsoo : date_jsoo -> date_jsoo -> period_jsoo +val compare_dates_jsoo : date_jsoo -> date_jsoo -> int +val date_to_ymd_jsoo : date_jsoo -> int Js.js_array Js.t +val date_of_string_jsoo : Js.js_string Js.t -> date_jsoo +val date_to_string_jsoo : date_jsoo -> Js.js_string Js.t +val first_day_of_month_jsoo : date_jsoo -> date_jsoo +val last_day_of_month_jsoo : date_jsoo -> date_jsoo +val is_leap_year_jsoo : int -> bool Js.t +val make_period_jsoo : int -> int -> int -> period_jsoo +val neg_period_jsoo : period_jsoo -> period_jsoo +val add_periods_jsoo : period_jsoo -> period_jsoo -> period_jsoo +val sub_periods_jsoo : period_jsoo -> period_jsoo -> period_jsoo +val mul_period_jsoo : period_jsoo -> int -> period_jsoo +val period_of_string_jsoo : Js.js_string Js.t -> period_jsoo +val period_to_string_jsoo : period_jsoo -> Js.js_string Js.t +val period_to_days_jsoo : period_jsoo -> int +val period_to_ymds_jsoo : period_jsoo -> int Js.js_array Js.t + +class type default_ct = object + method make_date_ : int -> int -> int -> date_jsoo Js.meth + + method add_dates_ : + date_jsoo -> + period_jsoo -> + date_rounding_jsoo Js.optdef -> + date_jsoo Js.meth + + method sub_dates_ : date_jsoo -> date_jsoo -> period_jsoo Js.meth + method compare_dates_ : date_jsoo -> date_jsoo -> int Js.meth + method date_to_ymd_ : date_jsoo -> int Js.js_array Js.t Js.meth + method date_of_string_ : Js.js_string Js.t -> date_jsoo Js.meth + method date_to_string_ : date_jsoo -> Js.js_string Js.t Js.meth + method first_day_of_month_ : date_jsoo -> date_jsoo Js.meth + method last_day_of_month_ : date_jsoo -> date_jsoo Js.meth + method is_leap_year_ : int -> bool Js.t Js.meth + method make_period_ : int -> int -> int -> period_jsoo Js.meth + method neg_period_ : period_jsoo -> period_jsoo Js.meth + method add_periods_ : period_jsoo -> period_jsoo -> period_jsoo Js.meth + method sub_periods_ : period_jsoo -> period_jsoo -> period_jsoo Js.meth + method mul_period_ : period_jsoo -> int -> period_jsoo Js.meth + method period_of_string_ : Js.js_string Js.t -> period_jsoo Js.meth + method period_to_string_ : period_jsoo -> Js.js_string Js.t Js.meth + method period_to_days_ : period_jsoo -> int Js.meth + method period_to_ymds_ : period_jsoo -> int Js.js_array Js.t Js.meth +end + +type default = default_ct Js.t + +val default : default diff --git a/runtimes/jsoo/dune b/runtimes/jsoo/dune new file mode 100644 index 000000000..1854d1e77 --- /dev/null +++ b/runtimes/jsoo/dune @@ -0,0 +1,8 @@ +(library + (name runtime_jsoo) + (public_name catala.runtime_jsoo) + (modules catala_runtime_jsoo dates_calc_jsoo) + (preprocess + (pps js_of_ocaml-ppx)) + (wrapped false) + (libraries catala.runtime_ocaml js_of_ocaml zarith_stubs_js)) diff --git a/runtimes/jsoo/runtime_jsoo.ml b/runtimes/jsoo/runtime_jsoo.ml deleted file mode 100644 index 79eb6a86e..000000000 --- a/runtimes/jsoo/runtime_jsoo.ml +++ /dev/null @@ -1,193 +0,0 @@ -(* This file is part of the Catala compiler, a specification language for tax - and social benefits computation rules. Copyright (C) 2020 Inria, contributor: - Emile Rolley . - - Licensed under the Apache License, Version 2.0 (the "License"); you may not - use this file except in compliance with the License. You may obtain a copy of - the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, WITHOUT - WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the - License for the specific language governing permissions and limitations under - the License. *) - -open Js_of_ocaml -module R_ocaml = Catala_runtime - -class type code_location = object - method fileName : Js.js_string Js.t Js.prop - method startLine : int Js.prop - method endLine : int Js.prop - method startColumn : int Js.prop - method endColumn : int Js.prop - method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop -end - -class type raw_event = object - method eventType : Js.js_string Js.t Js.prop - method information : Js.js_string Js.t Js.js_array Js.t Js.prop - method sourcePosition : code_location Js.t Js.optdef Js.prop - method loggedIOJson : Js.js_string Js.t Js.prop - method loggedValueJson : Js.js_string Js.t Js.prop -end - -class type event = object - method data : Js.js_string Js.t Js.prop -end - -class type duration = object - method years : int Js.readonly_prop - method months : int Js.readonly_prop - method days : int Js.readonly_prop -end - -let duration_of_js d = R_ocaml.duration_of_numbers d##.years d##.months d##.days - -let duration_to_js d = - let years, months, days = R_ocaml.duration_to_years_months_days d in - object%js - val years = years - val months = months - val days = days - end - -let date_of_js d = - let d = Js.to_string d in - let d = - if String.contains d 'T' then d |> String.split_on_char 'T' |> List.hd - else d - in - let fail () = failwith "date_of_js: invalid date" in - match String.split_on_char '-' d with - | [year; month; day] -> ( - try - R_ocaml.date_of_numbers (int_of_string year) (int_of_string month) - (int_of_string day) - with Failure _ -> fail ()) - | _ -> fail () - -let date_to_js d = Js.string @@ R_ocaml.date_to_string d - -let position_of_js (jpos : code_location Js.t) : R_ocaml.code_location = - { - R_ocaml.filename = Js.to_string jpos##.fileName; - start_line = jpos##.startLine; - start_column = jpos##.startColumn; - end_line = jpos##.endLine; - end_column = jpos##.endColumn; - law_headings = - Js.to_array jpos##.lawHeadings |> Array.map Js.to_string |> Array.to_list; - } - -let position_to_js (pos : R_ocaml.code_location) : code_location Js.t = - object%js - val mutable fileName = Js.string pos.R_ocaml.filename - val mutable startLine = pos.R_ocaml.start_line - val mutable endLine = pos.R_ocaml.end_line - val mutable startColumn = pos.R_ocaml.start_column - val mutable endColumn = pos.R_ocaml.end_column - - val mutable lawHeadings = - Array.of_list pos.law_headings |> Array.map Js.string |> Js.array - end - -class type event_manager = object - method resetLog : unit Js.meth - method retrieveEvents : event Js.t Js.js_array Js.t Js.meth - method retrieveRawEvents : raw_event Js.t Js.js_array Js.t Js.meth -end - -let event_manager : event_manager Js.t = - object%js (_self) - method resetLog = R_ocaml.reset_log () - - method retrieveEvents = - R_ocaml.retrieve_log () - |> R_ocaml.EventParser.parse_raw_events - |> List.map (fun event -> - object%js - val mutable data = event |> R_ocaml.Json.event |> Js.string - end) - |> Array.of_list - |> Js.array - - method retrieveRawEvents = - let evt_to_js evt = - (* FIXME: ideally this could be just a Json.parse (R_ocaml.Json.event - foo) ? *) - object%js - val mutable eventType = - (match evt with - | R_ocaml.BeginCall _ -> "Begin call" - | EndCall _ -> "End call" - | VariableDefinition _ -> "Variable definition" - | DecisionTaken _ -> "Decision taken") - |> Js.string - - val mutable information = - (match evt with - | BeginCall info | EndCall info | VariableDefinition (info, _, _) - -> - List.map Js.string info - | DecisionTaken _ -> []) - |> Array.of_list - |> Js.array - - val mutable loggedIOJson = - match evt with - | VariableDefinition (_, io, _) -> - io |> R_ocaml.Json.io_log |> Js.string - | EndCall _ | BeginCall _ | DecisionTaken _ -> - "unavailable" |> Js.string - - val mutable loggedValueJson = - (match evt with - | VariableDefinition (_, _, v) -> v - | EndCall _ | BeginCall _ | DecisionTaken _ -> - R_ocaml.unembeddable ()) - |> R_ocaml.Json.runtime_value - |> Js.string - - val mutable sourcePosition = - match evt with - | DecisionTaken pos -> - Js.def - (object%js - val mutable fileName = Js.string pos.filename - val mutable startLine = pos.start_line - val mutable endLine = pos.end_line - val mutable startColumn = pos.start_column - val mutable endColumn = pos.end_column - - val mutable lawHeadings = - List.map Js.string pos.law_headings - |> Array.of_list - |> Js.array - end) - | _ -> Js.undefined - end - in - R_ocaml.retrieve_log () |> List.map evt_to_js |> Array.of_list |> Js.array - end - -let execute_or_throw_error f = - try f () - with R_ocaml.Error _ as exc -> - let msg = Js.string (Printexc.to_string exc) in - Js.Js_error.raise_ - (Js.Js_error.of_error - (object%js - val mutable name = Js.string "CatalaError" - val mutable message = msg - val mutable stack = Js.Optdef.empty - method toString = msg - end)) - -let () = - Js.export_all - (object%js - val eventsManager = event_manager - end) diff --git a/runtimes/ocaml/catala_runtime.ml b/runtimes/ocaml/catala_runtime.ml index 94bb5e183..32900cf71 100644 --- a/runtimes/ocaml/catala_runtime.ml +++ b/runtimes/ocaml/catala_runtime.ml @@ -71,6 +71,19 @@ let error_to_string = function | IndivisibleDurations -> "IndivisibleDurations" | Impossible -> "Impossible" +let error_of_string = function + | "AssertionFailed" -> AssertionFailed + | "NoValue" -> NoValue + | "Conflict" -> Conflict + | "DivisionByZero" -> DivisionByZero + | "ListEmpty" -> ListEmpty + | "NotSameLength" -> NotSameLength + | "InvalidDate" -> InvalidDate + | "UncomparableDurations" -> UncomparableDurations + | "AmbiguousDateRounding" -> AmbiguousDateRounding + | "IndivisibleDurations" -> IndivisibleDurations + | "Impossible" | _ -> Impossible + let error_message = function | AssertionFailed -> "an assertion doesn't hold" | NoValue -> "no applicable rule to define this variable in this situation" diff --git a/runtimes/ocaml/catala_runtime.mli b/runtimes/ocaml/catala_runtime.mli index 040c16220..9a3d6e528 100644 --- a/runtimes/ocaml/catala_runtime.mli +++ b/runtimes/ocaml/catala_runtime.mli @@ -87,6 +87,9 @@ type error = val error_to_string : error -> string (** Returns the capitalized tag of the error as a string *) +val error_of_string : string -> error +(** Tries to build the error constructor from a string *) + val error_message : error -> string (** Returns a short explanation message about the error *) diff --git a/stdlib/dune b/stdlib/dune index c65b503b3..b18cd0a46 100644 --- a/stdlib/dune +++ b/stdlib/dune @@ -4,6 +4,8 @@ (*.catala_* with_prefix runtime)) (glob_files_rec (ocaml/* with_prefix runtime/ocaml)) + (glob_files_rec + (jsoo/* with_prefix runtime/jsoo)) (glob_files_rec (c/* with_prefix runtime/c)) (glob_files_rec diff --git a/stdlib/jsoo/date_internal_jsoo.ml b/stdlib/jsoo/date_internal_jsoo.ml new file mode 100644 index 000000000..7987bf6dd --- /dev/null +++ b/stdlib/jsoo/date_internal_jsoo.ml @@ -0,0 +1,52 @@ +open Js_of_ocaml +open Catala_runtime_jsoo +open Date_internal + +let of_ymd_jsoo pos y m d = + date_to_jsoo + @@ of_ymd + (code_location_of_jsoo pos) + (integer_of_jsoo y) (integer_of_jsoo m) (integer_of_jsoo d) + +let to_ymd_jsoo d = + let y, m, d = to_ymd (date_of_jsoo d) in + Js.array [| integer_to_jsoo y; integer_to_jsoo m; integer_to_jsoo d |] + +let last_day_of_month_jsoo = Dates_calc_jsoo.last_day_of_month_jsoo + +let add_rounded_down_jsoo d dur = + date_to_jsoo + @@ Dates_calc.add_dates ~round:Dates_calc.RoundDown (date_of_jsoo d) + (duration_of_jsoo dur) + +let add_rounded_up_jsoo d dur = + date_to_jsoo + @@ Dates_calc.add_dates ~round:Dates_calc.RoundUp (date_of_jsoo d) + (duration_of_jsoo dur) + +class type default_ct = object + method of_ymd_ : + code_location_jsoo -> + integer_jsoo -> + integer_jsoo -> + integer_jsoo -> + date_jsoo Js.meth + + method to_ymd_ : date_jsoo -> integer_jsoo Js.js_array Js.t Js.meth + method last_day_of_month_ : date_jsoo -> date_jsoo Js.meth + method add_rounded_down_ : date_jsoo -> duration_jsoo -> date_jsoo Js.meth + method add_rounded_up_ : date_jsoo -> duration_jsoo -> date_jsoo Js.meth +end + +type default = default_ct Js.t + +let default : default = + object%js + method of_ymd_ pos y m d = of_ymd_jsoo pos y m d + method to_ymd_ d = to_ymd_jsoo d + method last_day_of_month_ d = last_day_of_month_jsoo d + method add_rounded_down_ d dur = add_rounded_down_jsoo d dur + method add_rounded_up_ d dur = add_rounded_up_jsoo d dur + end + +let () = Js.export "Date_internal" default diff --git a/stdlib/jsoo/date_internal_jsoo.mli b/stdlib/jsoo/date_internal_jsoo.mli new file mode 100644 index 000000000..b614f4d7d --- /dev/null +++ b/stdlib/jsoo/date_internal_jsoo.mli @@ -0,0 +1,20 @@ +open Js_of_ocaml +open Catala_runtime_jsoo + +class type default_ct = object + method of_ymd_ : + code_location_jsoo -> + integer_jsoo -> + integer_jsoo -> + integer_jsoo -> + date_jsoo Js.meth + + method to_ymd_ : date_jsoo -> integer_jsoo Js.js_array Js.t Js.meth + method last_day_of_month_ : date_jsoo -> date_jsoo Js.meth + method add_rounded_down_ : date_jsoo -> duration_jsoo -> date_jsoo Js.meth + method add_rounded_up_ : date_jsoo -> duration_jsoo -> date_jsoo Js.meth +end + +type default = default_ct Js.t + +val default : default diff --git a/stdlib/jsoo/decimal_internal_jsoo.ml b/stdlib/jsoo/decimal_internal_jsoo.ml new file mode 100644 index 000000000..35730909e --- /dev/null +++ b/stdlib/jsoo/decimal_internal_jsoo.ml @@ -0,0 +1,19 @@ +open Catala_runtime_jsoo +open Decimal_internal + +let round_to_decimal_jsoo m n = + decimal_to_jsoo @@ round_to_decimal (decimal_of_jsoo m) (integer_of_jsoo n) + +class type default_ct = object + method round_to_decimal_ : + decimal_jsoo -> integer_jsoo -> decimal_jsoo Js_of_ocaml.Js.meth +end + +type default = default_ct Js_of_ocaml.Js.t + +let default : default = + object%js + method round_to_decimal_ m n = round_to_decimal_jsoo m n + end + +let () = Js_of_ocaml.Js.export "Decimal_internal" default diff --git a/stdlib/jsoo/decimal_internal_jsoo.mli b/stdlib/jsoo/decimal_internal_jsoo.mli new file mode 100644 index 000000000..f3b19ca02 --- /dev/null +++ b/stdlib/jsoo/decimal_internal_jsoo.mli @@ -0,0 +1,10 @@ +open Catala_runtime_jsoo + +class type default_ct = object + method round_to_decimal_ : + decimal_jsoo -> integer_jsoo -> decimal_jsoo Js_of_ocaml.Js.meth +end + +type default = default_ct Js_of_ocaml.Js.t + +val default : default diff --git a/stdlib/jsoo/dune b/stdlib/jsoo/dune new file mode 100644 index 000000000..72e3ea22f --- /dev/null +++ b/stdlib/jsoo/dune @@ -0,0 +1,8 @@ +(library + (name stdlib_internals_jsoo) + (public_name catala.stdlib_internals_jsoo) + (preprocess + (pps js_of_ocaml-ppx)) + (libraries stdlib_internals catala.runtime_jsoo) + (flags + (:standard -open Stdlib_internals))) diff --git a/stdlib/jsoo/list_internal_jsoo.ml b/stdlib/jsoo/list_internal_jsoo.ml new file mode 100644 index 000000000..fd4901102 --- /dev/null +++ b/stdlib/jsoo/list_internal_jsoo.ml @@ -0,0 +1,46 @@ +open Js_of_ocaml +open Catala_runtime_jsoo +open List_internal + +let sequence_jsoo start stop = + Js.array + @@ Array.map integer_to_jsoo + @@ sequence (integer_of_jsoo start) (integer_of_jsoo stop) + +let nth_element_jsoo arr n = + Optional.to_jsoo Fun.id @@ nth_element (Js.to_array arr) (integer_of_jsoo n) + +let remove_nth_element_jsoo arr n = + Js.array @@ remove_nth_element (Js.to_array arr) (integer_of_jsoo n) + +let reverse_jsoo arr = Js.array (reverse (Js.to_array arr)) + +class type default_ct = object + method sequence : + integer_jsoo -> integer_jsoo -> integer_jsoo Js.js_array Js.t Js.meth + + method nth_element_ : + Js.Unsafe.any Js.js_array Js.t -> + integer_jsoo -> + Js.Unsafe.any Optional.jsoo Js.meth + + method remove_nth_element_ : + Js.Unsafe.any Js.js_array Js.t -> + integer_jsoo -> + Js.Unsafe.any Js.js_array Js.t Js.meth + + method reverse : + Js.Unsafe.any Js.js_array Js.t -> Js.Unsafe.any Js.js_array Js.t Js.meth +end + +type default = default_ct Js.t + +let default : default = + object%js + method sequence start stop = sequence_jsoo start stop + method nth_element_ arr n = nth_element_jsoo arr n + method remove_nth_element_ arr n = remove_nth_element_jsoo arr n + method reverse arr = reverse_jsoo arr + end + +let () = Js.export "List_internal" default diff --git a/stdlib/jsoo/list_internal_jsoo.mli b/stdlib/jsoo/list_internal_jsoo.mli new file mode 100644 index 000000000..a04f21e28 --- /dev/null +++ b/stdlib/jsoo/list_internal_jsoo.mli @@ -0,0 +1,24 @@ +open Js_of_ocaml +open Catala_runtime_jsoo + +class type default_ct = object + method sequence : + integer_jsoo -> integer_jsoo -> integer_jsoo Js.js_array Js.t Js.meth + + method nth_element_ : + Js.Unsafe.any Js.js_array Js.t -> + integer_jsoo -> + Js.Unsafe.any Optional.jsoo Js.meth + + method remove_nth_element_ : + Js.Unsafe.any Js.js_array Js.t -> + integer_jsoo -> + Js.Unsafe.any Js.js_array Js.t Js.meth + + method reverse : + Js.Unsafe.any Js.js_array Js.t -> Js.Unsafe.any Js.js_array Js.t Js.meth +end + +type default = default_ct Js.t + +val default : default diff --git a/stdlib/jsoo/money_internal_jsoo.ml b/stdlib/jsoo/money_internal_jsoo.ml new file mode 100644 index 000000000..9773891d3 --- /dev/null +++ b/stdlib/jsoo/money_internal_jsoo.ml @@ -0,0 +1,19 @@ +open Catala_runtime_jsoo +open Money_internal + +let round_to_decimal_jsoo m n = + money_to_jsoo (round_to_decimal (money_of_jsoo m) (integer_of_jsoo n)) + +class type default_ct = object + method round_to_decimal_ : + money_jsoo -> integer_jsoo -> money_jsoo Js_of_ocaml.Js.meth +end + +type default = default_ct Js_of_ocaml.Js.t + +let default : default = + object%js + method round_to_decimal_ m n = round_to_decimal_jsoo m n + end + +let () = Js_of_ocaml.Js.export "Money_internal" default diff --git a/stdlib/jsoo/money_internal_jsoo.mli b/stdlib/jsoo/money_internal_jsoo.mli new file mode 100644 index 000000000..64a6354bf --- /dev/null +++ b/stdlib/jsoo/money_internal_jsoo.mli @@ -0,0 +1,10 @@ +open Catala_runtime_jsoo + +class type default_ct = object + method round_to_decimal_ : + money_jsoo -> integer_jsoo -> money_jsoo Js_of_ocaml.Js.meth +end + +type default = default_ct Js_of_ocaml.Js.t + +val default : default diff --git a/stdlib/jsoo/period_internal_jsoo.ml b/stdlib/jsoo/period_internal_jsoo.ml new file mode 100644 index 000000000..696c8c0d0 --- /dev/null +++ b/stdlib/jsoo/period_internal_jsoo.ml @@ -0,0 +1,83 @@ +open Js_of_ocaml +open Catala_runtime_jsoo +open Period_internal + +let sort_jsoo a = + let a = + Array.map (fun a -> + let x = Option.get @@ Js.Optdef.to_option @@ Js.array_get a 0 in + let y = Option.get @@ Js.Optdef.to_option @@ Js.array_get a 1 in + let start = + date_of_jsoo + @@ Js.Unsafe.coerce + @@ Option.get + @@ Js.Optdef.to_option + @@ Js.array_get x 0 + in + let stop = + date_of_jsoo + @@ Js.Unsafe.coerce + @@ Option.get + @@ Js.Optdef.to_option + @@ Js.array_get x 1 + in + (start, stop), Js.Unsafe.coerce y) + @@ Js.to_array a + in + let a = sort a in + Js.array + @@ Array.map + (fun ((start, stop), b) -> + Js.array + [| + Js.array + [| + Js.Unsafe.inject @@ date_to_jsoo start; + Js.Unsafe.inject @@ date_to_jsoo stop; + |]; + Js.Unsafe.coerce b; + |]) + a + +let split_by_month_jsoo a = + let start = Option.get @@ Js.Optdef.to_option @@ Js.array_get a 0 in + let stop = Option.get @@ Js.Optdef.to_option @@ Js.array_get a 1 in + Js.array + (Array.map + (fun (d1, d2) -> Js.array [| date_to_jsoo d1; date_to_jsoo d2 |]) + (split_by_month (date_of_jsoo start, date_of_jsoo stop))) + +let split_by_year_jsoo start_month a = + let start_month = integer_of_jsoo start_month in + let start = Option.get @@ Js.Optdef.to_option @@ Js.array_get a 0 in + let stop = Option.get @@ Js.Optdef.to_option @@ Js.array_get a 1 in + Js.array + (Array.map + (fun (d1, d2) -> Js.array [| date_to_jsoo d1; date_to_jsoo d2 |]) + (split_by_year start_month (date_of_jsoo start, date_of_jsoo stop))) + +class type default_ct = object + method sort : + Js.Unsafe.any Js.js_array Js.t Js.js_array Js.t Js.js_array Js.t -> + Js.Unsafe.any Js.js_array Js.t Js.js_array Js.t Js.js_array Js.t Js.meth + + method split_by_month_ : + date_jsoo Js.js_array Js.t -> + date_jsoo Js.js_array Js.t Js.js_array Js.t Js.meth + + method split_by_year_ : + integer_jsoo -> + date_jsoo Js.js_array Js.t -> + date_jsoo Js.js_array Js.t Js.js_array Js.t Js.meth +end + +type default = default_ct Js.t + +let default : default = + object%js + method sort a = sort_jsoo a + method split_by_month_ a = split_by_month_jsoo a + method split_by_year_ s a = split_by_year_jsoo s a + end + +let () = Js.export "Period_internal" default diff --git a/stdlib/jsoo/period_internal_jsoo.mli b/stdlib/jsoo/period_internal_jsoo.mli new file mode 100644 index 000000000..318b4150e --- /dev/null +++ b/stdlib/jsoo/period_internal_jsoo.mli @@ -0,0 +1,21 @@ +open Js_of_ocaml +open Catala_runtime_jsoo + +class type default_ct = object + method sort : + Js.Unsafe.any Js.js_array Js.t Js.js_array Js.t Js.js_array Js.t -> + Js.Unsafe.any Js.js_array Js.t Js.js_array Js.t Js.js_array Js.t Js.meth + + method split_by_month_ : + date_jsoo Js.js_array Js.t -> + date_jsoo Js.js_array Js.t Js.js_array Js.t Js.meth + + method split_by_year_ : + integer_jsoo -> + date_jsoo Js.js_array Js.t -> + date_jsoo Js.js_array Js.t Js.js_array Js.t Js.meth +end + +type default = default_ct Js.t + +val default : default