mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 00:15:39 +03:00
Fixing linking across modules for backends
- This adds a `catala depends` command that recursively tracks module dependency. It can then be used by Clerk for linking. - Generation of cmo object files are added for OCaml (we only built native objects, but jsoo requires bytecode). - Some fixes to the generation of value embed/deembed shims (related to types coming from different modules ; add support for options ; etc.)
This commit is contained in:
Louis Gesbert
parent
70cbfdb9ac
commit
ff06ddf40c
7
Makefile
7
Makefile
@ -108,6 +108,13 @@ install: prepare-install
|
||||
# registering with opam.
|
||||
# --assume-built is broken in 2.1.5
|
||||
|
||||
inst: prepare-install
|
||||
@opam custom-install \
|
||||
catala.$$(_build/install/default/bin/catala --version) \
|
||||
--solver=builtin-mccs+glpk -- \
|
||||
dune install catala
|
||||
# This is better, but 'opam custom-install' is still an experimental plugin
|
||||
|
||||
#> runtimes : Builds the OCaml and js_of_ocaml runtimes
|
||||
runtimes:
|
||||
dune build runtimes/
|
||||
|
||||
@ -435,8 +435,9 @@ module Var = struct
|
||||
let catala_flags_ocaml = make "CATALA_FLAGS_OCAML"
|
||||
let catala_flags_python = make "CATALA_FLAGS_PYTHON"
|
||||
let clerk_flags = make "CLERK_FLAGS"
|
||||
let ocamlc_exe = make "OCAMLC_EXE"
|
||||
let ocamlopt_exe = make "OCAMLOPT_EXE"
|
||||
let ocamlopt_flags = make "OCAMLOPT_FLAGS"
|
||||
let ocaml_flags = make "OCAML_FLAGS"
|
||||
let runtime_ocaml_libs = make "RUNTIME_OCAML_LIBS"
|
||||
let diff = make "DIFF"
|
||||
let post_test = make "POST_TEST"
|
||||
@ -447,6 +448,7 @@ module Var = struct
|
||||
let output = make "out"
|
||||
let pool = make "pool"
|
||||
let src = make "src"
|
||||
let orig_src = make "orig-src"
|
||||
let scope = make "scope"
|
||||
let test_id = make "test-id"
|
||||
let test_command = make "test-command"
|
||||
@ -477,7 +479,7 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
|
||||
| _ -> false)
|
||||
test_flags
|
||||
in
|
||||
let ocamlopt_flags = ["-I"; Lazy.force Poll.ocaml_runtime_dir] in
|
||||
let ocaml_flags = ["-I"; Lazy.force Poll.ocaml_runtime_dir] in
|
||||
[
|
||||
Nj.binding Var.ninja_required_version ["1.7"];
|
||||
(* use of implicit outputs *)
|
||||
@ -498,8 +500,9 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
|
||||
:: ("--test-flags=" ^ String.concat "," test_flags)
|
||||
:: includes
|
||||
@ List.map (fun f -> "--catala-opts=" ^ f) catala_flags);
|
||||
Nj.binding Var.ocamlc_exe ["ocamlc"];
|
||||
Nj.binding Var.ocamlopt_exe ["ocamlopt"];
|
||||
Nj.binding Var.ocamlopt_flags (ocamlopt_flags @ includes);
|
||||
Nj.binding Var.ocaml_flags (ocaml_flags @ includes);
|
||||
Nj.binding Var.runtime_ocaml_libs (Lazy.force Poll.ocaml_link_flags);
|
||||
Nj.binding Var.diff (Lazy.force Poll.diff_command);
|
||||
Nj.binding Var.post_test [Var.(!diff)];
|
||||
@ -508,36 +511,43 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
|
||||
let[@ocamlformat "disable"] static_base_rules =
|
||||
let open Var in
|
||||
let color = Message.has_color stdout in
|
||||
let shellout l = Format.sprintf "$$(%s)" (String.concat " " l) in
|
||||
[
|
||||
Nj.rule "copy"
|
||||
~command:["cp"; "-f"; !input; !output]
|
||||
~description:["<copy>"; !input];
|
||||
|
||||
Nj.rule "catala-ocaml"
|
||||
~command:[!catala_exe; "ocaml"; !catala_flags; !catala_flags_ocaml; !input; "-o"; !output]
|
||||
~command:[!catala_exe; "ocaml"; !catala_flags; !catala_flags_ocaml;
|
||||
!input; "-o"; !output]
|
||||
~description:["<catala>"; "ocaml"; "⇒"; !output];
|
||||
|
||||
Nj.rule "ocaml-module"
|
||||
~command:
|
||||
[!ocamlopt_exe; "-shared"; !ocamlopt_flags; !input; "-o"; !output]
|
||||
[!ocamlc_exe; "-c"; !ocaml_flags; !input; "&&";
|
||||
!ocamlopt_exe; "-shared"; !ocaml_flags; !input; "-o"; !output]
|
||||
~description:["<ocaml>"; "⇒"; !output];
|
||||
|
||||
Nj.rule "ocaml-exec"
|
||||
~command: [
|
||||
!ocamlopt_exe; !runtime_ocaml_libs; !ocamlopt_flags;
|
||||
!ocamlopt_exe; !runtime_ocaml_libs; !ocaml_flags;
|
||||
shellout [!catala_exe; "depends";
|
||||
"--prefix="^ !builddir; "--extension=cmx";
|
||||
!catala_flags; !orig_src];
|
||||
!input;
|
||||
"-o"; !output;
|
||||
]
|
||||
~description:["<ocaml>"; "⇒"; !output];
|
||||
|
||||
Nj.rule "python"
|
||||
~command:[!catala_exe; "python"; !catala_flags; !catala_flags_python; !input; "-o"; !output]
|
||||
~command:[!catala_exe; "python"; !catala_flags; !catala_flags_python;
|
||||
!input; "-o"; !output]
|
||||
~description:["<catala>"; "python"; "⇒"; !output];
|
||||
|
||||
Nj.rule "out-test"
|
||||
~command: [
|
||||
!catala_exe; !test_command; "--plugin-dir="; "-o -"; !catala_flags; !input;
|
||||
">"; !output; "2>&1";
|
||||
!catala_exe; !test_command; "--plugin-dir="; "-o -"; !catala_flags;
|
||||
!input; ">"; !output; "2>&1";
|
||||
"||"; "true";
|
||||
]
|
||||
~description:
|
||||
@ -545,7 +555,8 @@ let[@ocamlformat "disable"] static_base_rules =
|
||||
|
||||
Nj.rule "inline-tests"
|
||||
~command:
|
||||
[!clerk_exe; "runtest"; !clerk_flags; !input; ">"; !output; "2>&1"; "||"; "true"]
|
||||
[!clerk_exe; "runtest"; !clerk_flags; !input; ">"; !output; "2>&1";
|
||||
"||"; "true"]
|
||||
~description:["<catala>"; "inline-tests"; "⇐"; !input];
|
||||
|
||||
Nj.rule "post-test"
|
||||
@ -658,7 +669,7 @@ let gen_build_statements
|
||||
~implicit_in:[!Var.catala_exe] ~outputs:[py_file] )
|
||||
in
|
||||
let ocamlopt =
|
||||
let implicit_out_exts = ["cmi"; "cmx"; "cmt"; "o"] in
|
||||
let implicit_out_exts = ["cmi"; "cmo"; "cmx"; "cmt"; "o"] in
|
||||
match item.module_def with
|
||||
| Some m ->
|
||||
let target ext = (!Var.builddir / src /../ m) ^ "." ^ ext in
|
||||
@ -668,8 +679,8 @@ let gen_build_statements
|
||||
~implicit_out:(List.map target implicit_out_exts)
|
||||
~vars:
|
||||
[
|
||||
( Var.ocamlopt_flags,
|
||||
!Var.ocamlopt_flags
|
||||
( Var.ocaml_flags,
|
||||
!Var.ocaml_flags
|
||||
:: "-I"
|
||||
:: (!Var.builddir / src /../ "")
|
||||
:: List.concat_map
|
||||
@ -682,42 +693,18 @@ let gen_build_statements
|
||||
]
|
||||
| None ->
|
||||
let target ext = (!Var.builddir / !Var.src) ^ "." ^ ext in
|
||||
let inputs, modules =
|
||||
List.partition_map
|
||||
let implicit_in =
|
||||
List.map
|
||||
(fun m ->
|
||||
if List.mem m same_dir_modules then
|
||||
Left ((!Var.builddir / src /../ m) ^ ".cmx")
|
||||
else Right m)
|
||||
(!Var.builddir / src /../ m) ^ ".cmx"
|
||||
else m ^ "@module")
|
||||
modules
|
||||
in
|
||||
let inputs = inputs @ [ml_file] in
|
||||
(* Note: this rule is incomplete in that it only provide the direct module
|
||||
dependencies, and ocamlopt needs the transitive closure of dependencies
|
||||
for linking, which we can't provide here ; catala does that work for
|
||||
the interpret case, so we should probably add a [catala link] (or
|
||||
[clerk link]) command that gathers these dependencies and wraps
|
||||
[ocamlopt]. *)
|
||||
Nj.build "ocaml-exec" ~inputs
|
||||
~implicit_in:(List.map (fun m -> m ^ "@module") modules)
|
||||
Nj.build "ocaml-exec" ~inputs:[ml_file] ~implicit_in
|
||||
~outputs:[target "exe"]
|
||||
~implicit_out:(List.map target implicit_out_exts)
|
||||
~vars:
|
||||
[
|
||||
( Var.ocamlopt_flags,
|
||||
!Var.ocamlopt_flags
|
||||
:: "-I"
|
||||
:: (!Var.builddir / src /../ "")
|
||||
:: List.concat_map
|
||||
(fun d ->
|
||||
[
|
||||
"-I";
|
||||
(if Filename.is_relative d then !Var.builddir / d else d);
|
||||
])
|
||||
include_dirs
|
||||
@ List.map (fun m -> m ^ ".cmx") modules );
|
||||
(* FIXME: This doesn't work for module used through file
|
||||
inclusion *)
|
||||
]
|
||||
~vars:[Var.orig_src, [!Var.src ^ Filename.extension src]]
|
||||
in
|
||||
let expose_module =
|
||||
match item.module_def with
|
||||
|
||||
@ -478,6 +478,18 @@ module Flags = struct
|
||||
~doc:
|
||||
"Compile all the way to lcalc before interpreting (the default is to \
|
||||
interpret at dcalc stage). For debugging purposes."
|
||||
|
||||
let extension =
|
||||
value
|
||||
& opt (some string) None
|
||||
& info ["extension"; "e"] ~docv:"EXT"
|
||||
~doc:"Replace the original file extensions with $(i,.EXT)."
|
||||
|
||||
let prefix =
|
||||
value
|
||||
& opt (some string) None
|
||||
& info ["prefix"] ~docv:"PATH"
|
||||
~doc:"Prepend the given path to each of the files in the returned list."
|
||||
end
|
||||
|
||||
(* Retrieve current version from dune *)
|
||||
|
||||
@ -141,6 +141,12 @@ module Flags : sig
|
||||
|
||||
val lcalc : bool Term.t
|
||||
(** for the 'interpret' command *)
|
||||
|
||||
val extension : string option Term.t
|
||||
(** for the 'depends' command *)
|
||||
|
||||
val prefix : string option Term.t
|
||||
(** for the 'depends' command *)
|
||||
end
|
||||
|
||||
(** {2 Command-line application} *)
|
||||
|
||||
@ -138,7 +138,10 @@ let check_exec t =
|
||||
let ( / ) a b = if a = Filename.current_dir_name then b else Filename.concat a b
|
||||
let dirname = Filename.dirname
|
||||
let ( /../ ) a b = dirname a / b
|
||||
let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext
|
||||
|
||||
let ( -.- ) file ext =
|
||||
let base = Filename.chop_extension file in
|
||||
match ext with "" -> base | ext -> base ^ "." ^ ext
|
||||
|
||||
let path_to_list path =
|
||||
String.split_on_char dir_sep_char path
|
||||
|
||||
@ -108,7 +108,8 @@ val ( /../ ) : t -> t -> t
|
||||
|
||||
val ( -.- ) : t -> string -> t
|
||||
(** Extension replacement: chops the given filename extension, and replaces it
|
||||
with the given one (which shouldn't contain a dot) *)
|
||||
with the given one (which shouldn't contain a dot). No dot is appended if
|
||||
the provided extension is empty. *)
|
||||
|
||||
val path_to_list : t -> string list
|
||||
(** Empty elements or current-directory (".") are skipped in the resulting list *)
|
||||
|
||||
@ -989,6 +989,55 @@ module Commands = struct
|
||||
$ Cli.Flags.optimize
|
||||
$ Cli.Flags.check_invariants)
|
||||
|
||||
let depends options includes prefix extension =
|
||||
let prg = Passes.surface options in
|
||||
let prg = { prg with program_items = [] } in
|
||||
let mod_uses, modules = load_module_interfaces options includes prg in
|
||||
let d_ctx =
|
||||
Desugared.Name_resolution.form_context (prg, mod_uses) modules
|
||||
in
|
||||
let prg = Desugared.From_surface.translate_program d_ctx prg in
|
||||
let modules_list_topo =
|
||||
Program.modules_to_list prg.program_ctx.ctx_modules
|
||||
in
|
||||
Format.open_hbox ();
|
||||
Format.pp_print_list ~pp_sep:Format.pp_print_space
|
||||
(fun ppf m ->
|
||||
let f = Pos.get_file (Mark.get (ModuleName.get_info m)) in
|
||||
let f =
|
||||
match prefix with
|
||||
| None -> f
|
||||
| Some pfx ->
|
||||
if not (Filename.is_relative f) then (
|
||||
Message.emit_warning
|
||||
"Not adding prefix to %s, which is an absolute path" f;
|
||||
f)
|
||||
else File.(pfx / f)
|
||||
in
|
||||
let f =
|
||||
match extension with None -> f | Some ext -> File.(f -.- ext)
|
||||
in
|
||||
Format.pp_print_string ppf f)
|
||||
Format.std_formatter modules_list_topo;
|
||||
Format.close_box ();
|
||||
Format.print_newline ()
|
||||
|
||||
let depends_cmd =
|
||||
Cmd.v
|
||||
(Cmd.info "depends"
|
||||
~doc:
|
||||
"Lists the dependencies of a given catala file, in linking order. \
|
||||
This includes recursive dependencies and is useful for linking an \
|
||||
application in a target language. The space-separated list is \
|
||||
printed to stdout. The names are printed as expected of module \
|
||||
identifiers, $(i,i.e.) capitalized.")
|
||||
Term.(
|
||||
const depends
|
||||
$ Cli.Flags.Global.options
|
||||
$ Cli.Flags.include_dirs
|
||||
$ Cli.Flags.prefix
|
||||
$ Cli.Flags.extension)
|
||||
|
||||
let pygmentize_cmd =
|
||||
Cmd.v
|
||||
(Cmd.info "pygmentize"
|
||||
@ -1019,6 +1068,7 @@ module Commands = struct
|
||||
lcalc_cmd;
|
||||
scalc_cmd;
|
||||
exceptions_cmd;
|
||||
depends_cmd;
|
||||
pygmentize_cmd;
|
||||
]
|
||||
end
|
||||
|
||||
@ -129,58 +129,77 @@ let avoid_keywords (s : string) : string =
|
||||
(* Fixme: this could cause clashes if the user program contains both e.g. [new]
|
||||
and [new_user] *)
|
||||
|
||||
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
|
||||
Format.asprintf "%a" StructName.format v
|
||||
let ppclean fmt str =
|
||||
str |> String.to_ascii |> avoid_keywords |> Format.pp_print_string fmt
|
||||
|
||||
let ppsnake fmt str =
|
||||
str
|
||||
|> String.to_ascii
|
||||
|> String.to_snake_case
|
||||
|> avoid_keywords
|
||||
|> Format.fprintf fmt "%s"
|
||||
|> Format.pp_print_string fmt
|
||||
|
||||
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
|
||||
(match StructName.path v with
|
||||
| [] -> ()
|
||||
| path ->
|
||||
ppclean fmt (Uid.Path.to_string path);
|
||||
Format.pp_print_char fmt '.');
|
||||
ppsnake fmt (Mark.remove (StructName.get_info v))
|
||||
|
||||
let format_to_module_name
|
||||
(fmt : Format.formatter)
|
||||
(name : [< `Ename of EnumName.t | `Sname of StructName.t ]) =
|
||||
(match name with
|
||||
| `Ename v -> Format.asprintf "%a" EnumName.format v
|
||||
| `Sname v -> Format.asprintf "%a" StructName.format v)
|
||||
|> String.to_ascii
|
||||
|> avoid_keywords
|
||||
|> Format.pp_print_string fmt
|
||||
ppclean fmt
|
||||
(match name with
|
||||
| `Ename v -> EnumName.to_string v
|
||||
| `Sname v -> StructName.to_string v)
|
||||
|
||||
let format_struct_field_name
|
||||
(fmt : Format.formatter)
|
||||
((sname_opt, v) : StructName.t option * StructField.t) : unit =
|
||||
(match sname_opt with
|
||||
| Some sname ->
|
||||
Format.fprintf fmt "%a.%s" format_to_module_name (`Sname sname)
|
||||
| None -> Format.fprintf fmt "%s")
|
||||
(avoid_keywords
|
||||
(String.to_ascii (Format.asprintf "%a" StructField.format v)))
|
||||
Option.iter
|
||||
(fun sname ->
|
||||
format_to_module_name fmt (`Sname sname);
|
||||
Format.pp_print_char fmt '.')
|
||||
sname_opt;
|
||||
ppclean fmt (StructField.to_string v)
|
||||
|
||||
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(String.to_snake_case
|
||||
(String.to_ascii (Format.asprintf "%a" EnumName.format v))))
|
||||
(match EnumName.path v with
|
||||
| [] -> ()
|
||||
| path ->
|
||||
ppclean fmt (Uid.Path.to_string path);
|
||||
Format.pp_print_char fmt '.');
|
||||
ppsnake fmt (Mark.remove (EnumName.get_info v))
|
||||
|
||||
let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
|
||||
unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(String.to_ascii (Format.asprintf "%a" EnumConstructor.format v)))
|
||||
ppclean fmt (EnumConstructor.to_string v)
|
||||
|
||||
let rec typ_embedding_name (fmt : Format.formatter) (ty : typ) : unit =
|
||||
match Mark.remove ty with
|
||||
| TLit TUnit -> Format.fprintf fmt "embed_unit"
|
||||
| TLit TBool -> Format.fprintf fmt "embed_bool"
|
||||
| TLit TInt -> Format.fprintf fmt "embed_integer"
|
||||
| TLit TRat -> Format.fprintf fmt "embed_decimal"
|
||||
| TLit TMoney -> Format.fprintf fmt "embed_money"
|
||||
| TLit TDate -> Format.fprintf fmt "embed_date"
|
||||
| TLit TDuration -> Format.fprintf fmt "embed_duration"
|
||||
| TStruct s_name -> Format.fprintf fmt "embed_%a" format_struct_name s_name
|
||||
| TEnum e_name -> Format.fprintf fmt "embed_%a" format_enum_name e_name
|
||||
| TLit TUnit -> Format.pp_print_string fmt "embed_unit"
|
||||
| TLit TBool -> Format.pp_print_string fmt "embed_bool"
|
||||
| TLit TInt -> Format.pp_print_string fmt "embed_integer"
|
||||
| TLit TRat -> Format.pp_print_string fmt "embed_decimal"
|
||||
| TLit TMoney -> Format.pp_print_string fmt "embed_money"
|
||||
| TLit TDate -> Format.pp_print_string fmt "embed_date"
|
||||
| TLit TDuration -> Format.pp_print_string fmt "embed_duration"
|
||||
| TStruct s_name ->
|
||||
Format.fprintf fmt "%a%sembed_%a" ppclean
|
||||
(Uid.Path.to_string (StructName.path s_name))
|
||||
(if StructName.path s_name = [] then "" else ".")
|
||||
ppsnake
|
||||
(Uid.MarkedString.to_string (StructName.get_info s_name))
|
||||
| TEnum e_name ->
|
||||
Format.fprintf fmt "%a%sembed_%a" ppclean
|
||||
(Uid.Path.to_string (EnumName.path e_name))
|
||||
(if EnumName.path e_name = [] then "" else ".")
|
||||
ppsnake
|
||||
(Uid.MarkedString.to_string (EnumName.get_info e_name))
|
||||
| TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
|
||||
| _ -> Format.fprintf fmt "unembeddable"
|
||||
| _ -> Format.pp_print_string fmt "unembeddable"
|
||||
|
||||
let typ_needs_parens (e : typ) : bool =
|
||||
match Mark.remove e with TArrow _ | TArray _ -> true | _ -> false
|
||||
@ -457,45 +476,48 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
|
||||
let format_struct_embedding
|
||||
(fmt : Format.formatter)
|
||||
((struct_name, struct_fields) : StructName.t * typ StructField.Map.t) =
|
||||
if StructField.Map.is_empty struct_fields then
|
||||
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
|
||||
format_struct_name struct_name format_to_module_name (`Sname struct_name)
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>let embed_%a (x: %a.t) : runtime_value =@ Struct(\"%a\",@ \
|
||||
@[<hov 2>[%a]@])@]@\n\
|
||||
@\n"
|
||||
format_struct_name struct_name format_to_module_name (`Sname struct_name)
|
||||
StructName.format struct_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
|
||||
(fun fmt (struct_field, struct_field_type) ->
|
||||
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructField.format
|
||||
struct_field typ_embedding_name struct_field_type
|
||||
format_struct_field_name
|
||||
(Some struct_name, struct_field)))
|
||||
(StructField.Map.bindings struct_fields)
|
||||
if StructName.path struct_name = [] then
|
||||
if StructField.Map.is_empty struct_fields then
|
||||
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
|
||||
format_struct_name struct_name format_to_module_name
|
||||
(`Sname struct_name)
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>let embed_%a (x: %a.t) : runtime_value =@ Struct(\"%a\",@ \
|
||||
@[<hov 2>[%a]@])@]@\n\
|
||||
@\n"
|
||||
format_struct_name struct_name format_to_module_name
|
||||
(`Sname struct_name) StructName.format struct_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
|
||||
(fun fmt (struct_field, struct_field_type) ->
|
||||
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructField.format
|
||||
struct_field typ_embedding_name struct_field_type
|
||||
format_struct_field_name
|
||||
(Some struct_name, struct_field)))
|
||||
(StructField.Map.bindings struct_fields)
|
||||
|
||||
let format_enum_embedding
|
||||
(fmt : Format.formatter)
|
||||
((enum_name, enum_cases) : EnumName.t * typ EnumConstructor.Map.t) =
|
||||
if EnumConstructor.Map.is_empty enum_cases then
|
||||
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
|
||||
format_to_module_name (`Ename enum_name) format_enum_name enum_name
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hv 2>@[<hov 2>let embed_%a@ @[<hov 2>(x:@ %a.t)@]@ : runtime_value \
|
||||
=@]@ Enum(\"%a\",@ @[<hov 2>match x with@ %a@])@]@\n\
|
||||
@\n"
|
||||
format_enum_name enum_name format_to_module_name (`Ename enum_name)
|
||||
EnumName.format enum_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun fmt (enum_cons, enum_cons_type) ->
|
||||
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]"
|
||||
format_enum_cons_name enum_cons EnumConstructor.format enum_cons
|
||||
typ_embedding_name enum_cons_type))
|
||||
(EnumConstructor.Map.bindings enum_cases)
|
||||
if EnumName.path enum_name = [] then
|
||||
if EnumConstructor.Map.is_empty enum_cases then
|
||||
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
|
||||
format_enum_name enum_name format_to_module_name (`Ename enum_name)
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hv 2>@[<hov 2>let embed_%a@ @[<hov 2>(x:@ %a.t)@]@ : runtime_value \
|
||||
=@]@ Enum(\"%a\",@ @[<hov 2>match x with@ %a@])@]@\n\
|
||||
@\n"
|
||||
format_enum_name enum_name format_to_module_name (`Ename enum_name)
|
||||
EnumName.format enum_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun fmt (enum_cons, enum_cons_type) ->
|
||||
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]"
|
||||
format_enum_cons_name enum_cons EnumConstructor.format enum_cons
|
||||
typ_embedding_name enum_cons_type))
|
||||
(EnumConstructor.Map.bindings enum_cases)
|
||||
|
||||
let format_ctx
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list)
|
||||
|
||||
@ -25,23 +25,32 @@ module D = Dcalc.Ast
|
||||
(** Contains all format functions used to generating the [js_of_ocaml] wrapper
|
||||
of the corresponding Catala program. *)
|
||||
module To_jsoo = struct
|
||||
let to_camel_case (s : string) : string =
|
||||
String.split_on_char '_' s
|
||||
|> (function
|
||||
| hd :: tl -> hd :: List.map String.capitalize_ascii tl | l -> l)
|
||||
|> String.concat ""
|
||||
|
||||
let format_struct_field_name_camel_case
|
||||
(fmt : Format.formatter)
|
||||
(ppf : Format.formatter)
|
||||
(v : StructField.t) : unit =
|
||||
let s =
|
||||
Format.asprintf "%a" StructField.format v
|
||||
|> String.to_ascii
|
||||
|> String.to_snake_case
|
||||
|> avoid_keywords
|
||||
|> to_camel_case
|
||||
in
|
||||
Format.fprintf fmt "%s" s
|
||||
StructField.to_string v
|
||||
|> String.to_camel_case
|
||||
|> String.uncapitalize_ascii
|
||||
|> avoid_keywords
|
||||
|> Format.pp_print_string ppf
|
||||
|
||||
(* Supersedes [To_ocaml.format_struct_name], which can refer to enums from
|
||||
other modules: here everything is flattened in the current namespace *)
|
||||
let format_struct_name ppf name =
|
||||
StructName.to_string name
|
||||
|> String.map (function '.' -> '_' | c -> c)
|
||||
|> String.to_snake_case
|
||||
|> avoid_keywords
|
||||
|> Format.pp_print_string ppf
|
||||
|
||||
(* Supersedes [To_ocaml.format_enum_name], which can refer to enums from other
|
||||
modules: here everything is flattened in the current namespace *)
|
||||
let format_enum_name ppf name =
|
||||
EnumName.to_string name
|
||||
|> String.map (function '.' -> '_' | c -> c)
|
||||
|> String.to_snake_case
|
||||
|> avoid_keywords
|
||||
|> Format.pp_print_string ppf
|
||||
|
||||
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
|
||||
Print.base_type fmt
|
||||
@ -80,50 +89,78 @@ module To_jsoo = struct
|
||||
t1 format_typ_with_parens t2
|
||||
| TClosureEnv -> Format.fprintf fmt "Js.Unsafe.any Js.t"
|
||||
|
||||
let rec format_typ_to_jsoo fmt typ =
|
||||
let rec format_to_js fmt typ =
|
||||
match Mark.remove typ with
|
||||
| TLit TUnit -> ()
|
||||
| TLit TBool -> Format.fprintf fmt "Js.bool"
|
||||
| TLit TInt -> Format.fprintf fmt "integer_to_int"
|
||||
| TLit TRat -> Format.fprintf fmt "Js.number_of_float %@%@ decimal_to_float"
|
||||
| TLit TMoney -> Format.fprintf fmt "Js.number_of_float %@%@ money_to_float"
|
||||
| TLit TDuration -> Format.fprintf fmt "duration_to_jsoo"
|
||||
| TLit TDate -> Format.fprintf fmt "date_to_jsoo"
|
||||
| TEnum ename -> Format.fprintf fmt "%a_to_jsoo" format_enum_name ename
|
||||
| TStruct sname -> Format.fprintf fmt "%a_to_jsoo" format_struct_name sname
|
||||
| TLit TDuration -> Format.fprintf fmt "duration_to_js"
|
||||
| TLit TDate -> Format.fprintf fmt "date_to_js"
|
||||
| TEnum ename -> Format.fprintf fmt "%a_to_js" format_enum_name ename
|
||||
| TStruct sname -> Format.fprintf fmt "%a_to_js" format_struct_name sname
|
||||
| TArray t ->
|
||||
Format.fprintf fmt "Js.array %@%@ Array.map (fun x -> %a x)"
|
||||
format_typ_to_jsoo t
|
||||
| TDefault t -> format_typ_to_jsoo fmt t
|
||||
| TAny | TTuple _ -> Format.fprintf fmt "Js.Unsafe.inject"
|
||||
| _ -> Format.fprintf fmt ""
|
||||
Format.fprintf fmt "Js.array %@%@ Array.map (fun x -> %a x)" format_to_js
|
||||
t
|
||||
| TDefault t -> format_to_js fmt t
|
||||
| TTuple tl ->
|
||||
let pp_sep fmt () = Format.fprintf fmt ",@ " in
|
||||
let elts = List.mapi (fun i t -> i, t) tl in
|
||||
Format.fprintf fmt "(fun (%a) -> Js.array [|%a|])"
|
||||
(Format.pp_print_list ~pp_sep (fun fmt (i, _) ->
|
||||
Format.fprintf fmt "x%d" i))
|
||||
elts
|
||||
(Format.pp_print_list ~pp_sep (fun fmt (i, t) ->
|
||||
Format.fprintf fmt "%a x%d" format_to_js t i))
|
||||
elts
|
||||
| TOption t ->
|
||||
Format.fprintf fmt
|
||||
"(function Eoption.ENone -> Js.null | Eoption.ESome x -> %a x)"
|
||||
format_to_js t
|
||||
| TAny -> Format.fprintf fmt "Js.Unsafe.inject"
|
||||
| TArrow _ | TClosureEnv -> ()
|
||||
|
||||
let rec format_typ_of_jsoo fmt typ =
|
||||
let rec format_of_js fmt typ =
|
||||
match Mark.remove typ with
|
||||
| TLit TUnit -> ()
|
||||
| TLit TBool -> Format.fprintf fmt "Js.to_bool"
|
||||
| TLit TInt -> Format.fprintf fmt "integer_of_int"
|
||||
| TLit TRat -> Format.fprintf fmt "decimal_of_float %@%@ Js.float_of_number"
|
||||
| TLit TMoney ->
|
||||
Format.fprintf fmt
|
||||
"money_of_decimal %@%@ decimal_of_float %@%@ Js.float_of_number"
|
||||
| TLit TDuration -> Format.fprintf fmt "duration_of_jsoo"
|
||||
| TLit TDate -> Format.fprintf fmt "date_of_jsoo"
|
||||
| TEnum ename -> Format.fprintf fmt "%a_of_jsoo" format_enum_name ename
|
||||
| TStruct sname -> Format.fprintf fmt "%a_of_jsoo" format_struct_name sname
|
||||
| TLit TDuration -> Format.fprintf fmt "duration_of_js"
|
||||
| TLit TDate -> Format.fprintf fmt "date_of_js"
|
||||
| TEnum ename -> Format.fprintf fmt "%a_of_js" format_enum_name ename
|
||||
| TStruct sname -> Format.fprintf fmt "%a_of_js" format_struct_name sname
|
||||
| TArray t ->
|
||||
Format.fprintf fmt "Array.map (fun x -> %a x) %@%@ Js.to_array"
|
||||
format_typ_of_jsoo t
|
||||
| _ -> Format.fprintf fmt ""
|
||||
format_of_js t
|
||||
| TDefault t -> format_of_js fmt t
|
||||
| TTuple tl ->
|
||||
let pp_sep fmt () = Format.fprintf fmt ",@ " in
|
||||
let elts = List.mapi (fun i t -> i, t) tl in
|
||||
Format.fprintf fmt "(fun t -> (%a))"
|
||||
(Format.pp_print_list ~pp_sep (fun fmt (i, t) ->
|
||||
Format.fprintf fmt "%a (Js.array_get t %d)" format_of_js t i))
|
||||
elts
|
||||
| TOption t ->
|
||||
Format.fprintf fmt
|
||||
"(fun o -> Js.Opt.case o (fun () -> Eoption.ENone) (fun x -> \
|
||||
Eoption.ESome (%a x)))"
|
||||
format_of_js t
|
||||
| TAny -> Format.fprintf fmt "Js.Unsafe.inject"
|
||||
| TArrow _ | TClosureEnv -> Format.fprintf fmt ""
|
||||
|
||||
let format_var_camel_case (fmt : Format.formatter) (v : 'm Var.t) : unit =
|
||||
let lowercase_name =
|
||||
Bindlib.name_of v
|
||||
|> String.to_ascii
|
||||
|> String.to_snake_case
|
||||
|> String.to_camel_case
|
||||
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ ->
|
||||
"_dot_")
|
||||
|> String.to_ascii
|
||||
|> String.uncapitalize_ascii
|
||||
|> avoid_keywords
|
||||
|> to_camel_case
|
||||
in
|
||||
if
|
||||
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|
||||
@ -142,11 +179,12 @@ module To_jsoo = struct
|
||||
| _ -> Format.fprintf fmt "Js.readonly_prop"
|
||||
in
|
||||
let format_struct_decl fmt (struct_name, struct_fields) =
|
||||
(* if StructName.path struct_name <> [] then () else *)
|
||||
let fmt_struct_name fmt _ = format_struct_name fmt struct_name in
|
||||
let fmt_module_struct_name fmt _ =
|
||||
To_ocaml.format_to_module_name fmt (`Sname struct_name)
|
||||
in
|
||||
let fmt_to_jsoo fmt _ =
|
||||
let fmt_to_js fmt _ =
|
||||
Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun fmt (struct_field, struct_field_type) ->
|
||||
@ -156,28 +194,34 @@ module To_jsoo = struct
|
||||
ListLabels.mapi t1 ~f:(fun i _ ->
|
||||
"function_input" ^ string_of_int i)
|
||||
in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
|
||||
fun _ %a ->@ %a (%a.%a %a))@]@]"
|
||||
format_struct_field_name_camel_case struct_field
|
||||
Format.fprintf fmt "@[<hov 2>method %a =@ Js.wrap_meth_callback@ "
|
||||
format_struct_field_name_camel_case struct_field;
|
||||
Format.fprintf fmt "@[<hv 2>(@,fun _ %a ->@ "
|
||||
(Format.pp_print_list (fun fmt (arg_i, ti) ->
|
||||
Format.fprintf fmt "(%s: %a)" arg_i format_typ ti))
|
||||
(List.combine args_names t1)
|
||||
format_typ_to_jsoo t2 fmt_struct_name ()
|
||||
format_struct_field_name (None, struct_field)
|
||||
(Format.pp_print_list (fun fmt (i, ti) ->
|
||||
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" format_typ_of_jsoo
|
||||
ti Format.pp_print_string i))
|
||||
(List.combine args_names t1)
|
||||
(List.combine args_names t1);
|
||||
format_to_js fmt t2;
|
||||
Format.pp_print_string fmt " (";
|
||||
fmt_struct_name fmt ();
|
||||
Format.pp_print_char fmt '.';
|
||||
format_struct_field_name fmt (None, struct_field);
|
||||
Format.pp_print_char fmt ' ';
|
||||
Format.pp_print_list
|
||||
(fun fmt (i, ti) ->
|
||||
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" format_of_js ti
|
||||
Format.pp_print_string i)
|
||||
fmt
|
||||
(List.combine args_names t1);
|
||||
Format.fprintf fmt "))@]@]"
|
||||
| _ ->
|
||||
Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]"
|
||||
format_struct_field_name_camel_case struct_field
|
||||
format_typ_to_jsoo struct_field_type fmt_struct_name ()
|
||||
format_struct_field_name (None, struct_field))
|
||||
format_struct_field_name_camel_case struct_field format_to_js
|
||||
struct_field_type fmt_struct_name () format_struct_field_name
|
||||
(None, struct_field))
|
||||
fmt
|
||||
(StructField.Map.bindings struct_fields)
|
||||
in
|
||||
let fmt_of_jsoo fmt _ =
|
||||
let fmt_of_js fmt _ =
|
||||
Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
|
||||
(fun fmt (struct_field, struct_field_type) ->
|
||||
@ -191,7 +235,7 @@ module To_jsoo = struct
|
||||
| _ ->
|
||||
Format.fprintf fmt
|
||||
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]"
|
||||
format_struct_field_name (None, struct_field) format_typ_of_jsoo
|
||||
format_struct_field_name (None, struct_field) format_of_js
|
||||
struct_field_type fmt_struct_name ()
|
||||
format_struct_field_name_camel_case struct_field)
|
||||
fmt
|
||||
@ -199,24 +243,23 @@ module To_jsoo = struct
|
||||
in
|
||||
let fmt_conv_funs fmt _ =
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>let %a_to_jsoo@ (%a@ : %a.t)@ : %a Js.t =@ @[<hv \
|
||||
2>object%%js@\n\
|
||||
"@[<hov 2>let %a_to_js@ (%a@ : %a.t)@ : %a Js.t =@ @[<hv 2>object%%js@\n\
|
||||
%a@\n\
|
||||
@]@]end@\n\
|
||||
@[<hov 2>let %a_of_jsoo@ @[<hov 2>(%a@ : %a Js.t)@] :@ %a.t =@ \
|
||||
@[<hv 2>{@,\
|
||||
@[<hov 2>let %a_of_js@ @[<hov 2>(%a@ : %a Js.t)@] :@ %a.t =@ @[<hv \
|
||||
2>{@,\
|
||||
%a@]@\n\
|
||||
}@]"
|
||||
fmt_struct_name () fmt_struct_name () fmt_module_struct_name ()
|
||||
fmt_struct_name () fmt_to_jsoo () fmt_struct_name () fmt_struct_name
|
||||
() fmt_struct_name () fmt_module_struct_name () fmt_of_jsoo ()
|
||||
fmt_struct_name () fmt_to_js () fmt_struct_name () fmt_struct_name ()
|
||||
fmt_struct_name () fmt_module_struct_name () fmt_of_js ()
|
||||
in
|
||||
|
||||
if StructField.Map.is_empty struct_fields then
|
||||
Format.fprintf fmt
|
||||
"class type %a =@ object end@\n\
|
||||
let %a_to_jsoo (_ : %a.t) : %a Js.t = object%%js end@\n\
|
||||
let %a_of_jsoo (_ : %a Js.t) : %a.t = ()" fmt_struct_name ()
|
||||
let %a_to_js (_ : %a.t) : %a Js.t = object%%js end@\n\
|
||||
let %a_of_js (_ : %a Js.t) : %a.t = ()" fmt_struct_name ()
|
||||
fmt_struct_name () fmt_module_struct_name () fmt_struct_name ()
|
||||
fmt_struct_name () fmt_struct_name () fmt_module_struct_name ()
|
||||
else
|
||||
@ -234,31 +277,26 @@ module To_jsoo = struct
|
||||
in
|
||||
let format_enum_decl fmt (enum_name, (enum_cons : typ EnumConstructor.Map.t))
|
||||
=
|
||||
(* if EnumName.path enum_name <> [] then () else *)
|
||||
let fmt_enum_name fmt _ = format_enum_name fmt enum_name in
|
||||
let fmt_module_enum_name fmt () =
|
||||
To_ocaml.format_to_module_name fmt (`Ename enum_name)
|
||||
in
|
||||
let fmt_to_jsoo fmt _ =
|
||||
let fmt_to_js fmt _ =
|
||||
Format.fprintf fmt "%a"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun fmt (cname, typ) ->
|
||||
match Mark.remove typ with
|
||||
| TTuple _ ->
|
||||
Message.raise_spanned_error (Mark.get typ)
|
||||
"Tuples aren't supported yet in the conversion to JS"
|
||||
| _ ->
|
||||
Format.fprintf fmt
|
||||
"@[<v 2>@[<v 4>| %a arg -> object%%js@\n\
|
||||
val kind = Js.string \"%a\"@\n\
|
||||
val payload = Js.Unsafe.coerce (Js.Unsafe.inject (%a \
|
||||
arg))@]@\n\
|
||||
end@]"
|
||||
format_enum_cons_name cname format_enum_cons_name cname
|
||||
format_typ_to_jsoo typ))
|
||||
Format.fprintf fmt
|
||||
"@[<v 2>@[<v 4>| %a arg -> object%%js@\n\
|
||||
val kind = Js.string \"%a\"@\n\
|
||||
val payload = Js.Unsafe.coerce (Js.Unsafe.inject (%a arg))@]@\n\
|
||||
end@]"
|
||||
format_enum_cons_name cname format_enum_cons_name cname
|
||||
format_to_js typ))
|
||||
(EnumConstructor.Map.bindings enum_cons)
|
||||
in
|
||||
let fmt_of_jsoo fmt _ =
|
||||
let fmt_of_js fmt _ =
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>match@ %a##.kind@ |> Js.to_string@ with@]@\n\
|
||||
@[<hv>%a@\n\
|
||||
@ -280,21 +318,20 @@ module To_jsoo = struct
|
||||
Format.fprintf fmt
|
||||
"| \"%a\" ->@\n%a.%a (%a (Js.Unsafe.coerce %a##.payload))"
|
||||
format_enum_cons_name cname fmt_module_enum_name ()
|
||||
format_enum_cons_name cname format_typ_of_jsoo typ
|
||||
fmt_enum_name ()))
|
||||
format_enum_cons_name cname format_of_js typ fmt_enum_name ()))
|
||||
(EnumConstructor.Map.bindings enum_cons)
|
||||
fmt_module_enum_name ()
|
||||
in
|
||||
|
||||
let fmt_conv_funs fmt _ =
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>let %a_to_jsoo@ : %a.t -> %a Js.t@ = function@\n\
|
||||
"@[<hov 2>let %a_to_js@ : %a.t -> %a Js.t@ = function@\n\
|
||||
%a@]@\n\
|
||||
@\n\
|
||||
@[<hov 2>let %a_of_jsoo@ @[<hov 2>(%a@ : %a Js.t)@]@ : %a.t =@ %a@]@\n"
|
||||
fmt_enum_name () fmt_module_enum_name () fmt_enum_name () fmt_to_jsoo
|
||||
() fmt_enum_name () fmt_enum_name () fmt_enum_name ()
|
||||
fmt_module_enum_name () fmt_of_jsoo ()
|
||||
@[<hov 2>let %a_of_js@ @[<hov 2>(%a@ : %a Js.t)@]@ : %a.t =@ %a@]@\n"
|
||||
fmt_enum_name () fmt_module_enum_name () fmt_enum_name () fmt_to_js ()
|
||||
fmt_enum_name () fmt_enum_name () fmt_enum_name ()
|
||||
fmt_module_enum_name () fmt_of_js ()
|
||||
in
|
||||
Format.fprintf fmt
|
||||
"@[<v 2>class type %a =@ @[<v 2>object@ @[<hov 2>method kind :@ \
|
||||
@ -359,7 +396,7 @@ module To_jsoo = struct
|
||||
let fmt_fun_call fmt _ =
|
||||
Format.fprintf fmt
|
||||
"@[<hv>@[<hv 2>execute_or_throw_error@ (@[<hv 2>fun () ->@ %a@ \
|
||||
|> %a_of_jsoo@ |> %a@ |> %a_to_jsoo@])@]@]"
|
||||
|> %a_of_js@ |> %a@ |> %a_to_js@])@]@]"
|
||||
fmt_input_struct_name body fmt_input_struct_name body format_var
|
||||
var fmt_output_struct_name body
|
||||
in
|
||||
@ -437,32 +474,13 @@ let run
|
||||
avoid_exceptions
|
||||
closure_conversion
|
||||
monomorphize_types
|
||||
options =
|
||||
if not options.Cli.trace then
|
||||
Message.raise_error "This plugin requires the --trace flag.";
|
||||
_options =
|
||||
let options = Cli.enforce_globals ~trace:true () in
|
||||
let prg, type_ordering =
|
||||
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
|
||||
~monomorphize_types
|
||||
in
|
||||
let modname =
|
||||
(* TODO: module directive support *)
|
||||
match options.Cli.input_src with
|
||||
| FileName n -> Some (Driver.modname_of_file n)
|
||||
| _ -> None
|
||||
in
|
||||
let () =
|
||||
(* First compile to ocaml (with --trace on) *)
|
||||
let output_file, with_output =
|
||||
Driver.Commands.get_output_format options ~ext:".ml" output
|
||||
in
|
||||
with_output
|
||||
@@ fun fmt ->
|
||||
Message.emit_debug "Compiling program into OCaml...";
|
||||
Message.emit_debug "Writing to %s..."
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
Lcalc.To_ocaml.format_program fmt prg ~exec_args:false type_ordering
|
||||
in
|
||||
let jsoo_output_file, with_formatter =
|
||||
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
|
||||
in
|
||||
@ -470,7 +488,7 @@ let run
|
||||
Message.emit_debug "Writing JSOO API code to %s..."
|
||||
(Option.value ~default:"stdout" jsoo_output_file);
|
||||
To_jsoo.format_program fmt
|
||||
(Option.map (( ^ ) "open ") modname)
|
||||
(Option.map (fun m -> "open " ^ ModuleName.to_string m) prg.module_name)
|
||||
prg type_ordering)
|
||||
|
||||
let term =
|
||||
|
||||
@ -44,10 +44,9 @@ class type duration = object
|
||||
method days : int Js.readonly_prop
|
||||
end
|
||||
|
||||
let duration_of_jsoo d =
|
||||
R_ocaml.duration_of_numbers d##.years d##.months d##.days
|
||||
let duration_of_js d = R_ocaml.duration_of_numbers d##.years d##.months d##.days
|
||||
|
||||
let duration_to_jsoo d =
|
||||
let duration_to_js d =
|
||||
let years, months, days = R_ocaml.duration_to_years_months_days d in
|
||||
object%js
|
||||
val years = years
|
||||
@ -55,7 +54,7 @@ let duration_to_jsoo d =
|
||||
val days = days
|
||||
end
|
||||
|
||||
let date_of_jsoo d =
|
||||
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
|
||||
@ -65,9 +64,9 @@ let date_of_jsoo d =
|
||||
| [year; month; day] ->
|
||||
R_ocaml.date_of_numbers (int_of_string year) (int_of_string month)
|
||||
(int_of_string day)
|
||||
| _ -> failwith "date_of_jsoo: invalid date"
|
||||
| _ -> failwith "date_of_js: invalid date"
|
||||
|
||||
let date_to_jsoo d = Js.string @@ R_ocaml.date_to_string d
|
||||
let date_to_js d = Js.string @@ R_ocaml.date_to_string d
|
||||
|
||||
class type event_manager = object
|
||||
method resetLog : (unit, unit) Js.meth_callback Js.meth
|
||||
|
||||
@ -98,8 +98,8 @@ class type duration = object
|
||||
method days : int Js.readonly_prop
|
||||
end
|
||||
|
||||
val duration_of_jsoo : duration Js.t -> Runtime_ocaml.Runtime.duration
|
||||
val duration_to_jsoo : Runtime_ocaml.Runtime.duration -> duration Js.t
|
||||
val duration_of_js : duration Js.t -> Runtime_ocaml.Runtime.duration
|
||||
val duration_to_js : Runtime_ocaml.Runtime.duration -> duration Js.t
|
||||
|
||||
(** {1 Date conversion} *)
|
||||
|
||||
@ -107,8 +107,8 @@ val duration_to_jsoo : Runtime_ocaml.Runtime.duration -> duration Js.t
|
||||
{{:https://www.iso.org/iso-8601-date-and-time-format.html} ISO8601 format}:
|
||||
'YYYY-MM-DD'. *)
|
||||
|
||||
val date_of_jsoo : Js.js_string Js.t -> Runtime_ocaml.Runtime.date
|
||||
val date_to_jsoo : Runtime_ocaml.Runtime.date -> Js.js_string Js.t
|
||||
val date_of_js : Js.js_string Js.t -> Runtime_ocaml.Runtime.date
|
||||
val date_to_js : Runtime_ocaml.Runtime.date -> Js.js_string Js.t
|
||||
|
||||
(** {1 Error management} *)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user