CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Some tweaks helping with separate compilation of the examples (#586)

Browse Source
This commit is contained in:
Louis Gesbert 2024-03-25 16:54:10 +01:00 committed by GitHub
commit 60b2e6f205
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
58 changed files with 1143 additions and 744 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.github/workflows/harness.yml vendored
View File

@ -127,7 +127,7 @@ jobs:
- name: Build examples
run: |
cd ~/catala-examples
opam --cli=2.1 exec -- make build pass_all_tests install
opam --cli=2.1 exec -- make all testsuite install
- name: Checkout french-law repo
run: |
git clone https://github.com/CatalaLang/french-law --depth 1 ~/french-law -b "${{ github.head_ref || github.ref_name }}" ||
@ -145,9 +145,9 @@ jobs:
mv catala/doc/syntax/syntax.pdf artifacts/
mv catala/_build/default/*.html artifacts/
mv ~/.opam/catala/doc/catala-examples/tuto*/*.html artifacts/
tar czf "artifacts/french_law_ocaml.tar.gz" french-law/ocaml
tar czf "artifacts/french_law_js.tar.gz" french-law/js
tar czf "artifacts/french_law_python.tar.gz" french-law/python
tar cz -hf "artifacts/french-law_ocaml.tar.gz" -C french-law/_build/install/default/lib french-law
cp catala-examples/_build/french-law_npm.tar.gz artifacts/
cp catala-examples/_build/french_law_python.tar.gz artifacts/
- name: Upload artifacts
continue-on-error: true
# Uploading artifacts works but then return failure with:

71
Makefile
View File

@ -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/
@ -187,8 +194,8 @@ syntax:
# High-level test and benchmarks commands
##########################################
CATALA_OPTS?=
CLERK_OPTS?=--makeflags="$(MAKEFLAGS)"
CATALA_OPTS ?=
CLERK_OPTS ?=
CATALA_BIN=_build/default/$(COMPILER_DIR)/catala.exe
CLERK_BIN=_build/default/$(BUILD_SYSTEM_DIR)/clerk.exe
@ -204,7 +211,7 @@ unit-tests: .FORCE
#> test : Run interpreter tests
test: .FORCE unit-tests
$(CLERK_TEST)
$(CLERK_TEST) tests
tests: test
@ -218,7 +225,7 @@ testsuite-base: .FORCE
@for F in $(TEST_FLAGS_LIST); do \
echo >&2; \
[ -z "$$F" ] || echo ">> RE-RUNNING TESTS WITH FLAGS: $$F" >&2; \
$(CLERK_TEST) --test-flags="$$F" || break; \
$(CLERK_TEST) tests --test-flags="$$F" || break; \
done
#> testsuite : Run interpreter tests over a selection of configurations
@ -227,7 +234,7 @@ testsuite: unit-tests
#> reset-tests : Update the expected test results from current run
reset-tests: .FORCE $(CLERK_BIN)
$(CLERK_TEST) --reset
$(CLERK_TEST) tests --reset
tests/%: .FORCE
$(CLERK_TEST) test $@
@ -244,19 +251,23 @@ WEBSITE_ASSETS_EXAMPLES = \
tutorial_en/tutorial_en.html \
tutoriel_fr/tutoriel_fr.html \
us_tax_code/us_tax_code.html \
allocations_familiales/allocations_familiales.html \
allocations_familiales/allocations_familiales_schema.json \
aides_logement/aides_logement.html \
aides_logement/aides_logement_schema.json
allocations_familiales/Allocations_familiales.html \
allocations_familiales/Allocations_familiales_schema.json \
aides_logement/Aides_logement.html \
aides_logement/Aides_logement_schema.json
WEBSITE_ASSETS_ALL = $(WEBSITE_ASSETS) $(addprefix catala-examples.tmp/,$(WEBSITE_ASSETS_EXAMPLES))
website-assets-base: build
$(call local_tmp_clone,catala-examples) && \
dune build $(addprefix _build/default/,$(WEBSITE_ASSETS_ALL)) --profile=release
$(MAKE) -C catala-examples.tmp \
CATALA=../$(CATALA_BIN) \
CLERK=../$(CLERK_BIN) \
BUILD=../_build/default \
$(addprefix ../_build/default/,$(WEBSITE_ASSETS_EXAMPLES))
dune build $(addprefix _build/default/,$(WEBSITE_ASSETS_ALL)) $(WEBSITE_ASSETS)
website-assets.tar:
# $(MAKE) DUNE_PROFILE=release website-assets-base
website-assets.tar: website-assets-base
tar cf $@ $(foreach file,$(WEBSITE_ASSETS_ALL),-C $(CURDIR)/$(dir _build/default/$(file)) $(notdir $(file)))
#> website-assets : Builds all the assets necessary for the Catala website
@ -290,19 +301,38 @@ local_tmp_clone = { \
git clone https://github.com/CatalaLang/$1 \
--depth 1 --reference-if-able ../$1 \
$1.tmp || \
git clone -s ../$1 $1.tmp $(BRANCH) || \
git clone -s ../$1 $1.tmp master; \
git clone -s ../$1 $1.tmp -b $(BRANCH) || \
git clone -s ../$1 $1.tmp -b master; \
}
test_title = printf "\n\# \e[33m=========== \e[1m%-30s \e[2m===========\e[m \n"
#> alltest : Runs more extensive tests, including the examples and french-law. Use before push!
alltest: dependencies-python
@export DUNE_PROFILE=check && \
@export DUNE_PROFILE=check OCAMLPATH=$(CURDIR)/_build/install/default/lib && \
$(test_title) "Local build and unit tests" && \
dune build @update-parser-messages @install @runtest && \
$(test_title) "Local testsuite" && \
$(MAKE) testsuite && \
$(test_title) "Running catala-examples" && \
$(call local_tmp_clone,catala-examples) && \
$(CLERK_BIN) test catala-examples.tmp && \
$(MAKE) -C catala-examples.tmp \
CATALA=$(CURDIR)/_build/install/default/bin/catala \
CLERK=$(CURDIR)/_build/install/default/bin/clerk \
BUILD=../_build/default \
all testsuite local-install && \
$(test_title) "Running french-law tests" && \
$(call local_tmp_clone,french-law) && \
make -C french-law.tmp all PY_VENV_DIR=$(ROOT_DIR)/_python_venv
touch french-law.tmp/dune-workspace && \
$(MAKE) -C french-law.tmp \
OCAMLPATH=$(CURDIR)/_build/install/default/lib \
PY_VENV_DIR=$(ROOT_DIR)/_python_venv \
dependencies \
bench_ocaml \
bench_js \
bench_python && \
printf "\n# \e[42;30m[ ALL TESTS PASSED ]\e[m \e[32m☺\e[m\n" || \
{ printf "\n# \e[41;30m[ TESTS FAILED ]\e[m \e[31m☹\e[m\n" ; exit 1; }
#> clean : Clean build artifacts
clean:
@ -323,7 +353,6 @@ help_catala:
##########################################
# Special targets
##########################################
.PHONY: inspect clean all english allocations_familiales \
pygments install build_dev build doc format dependencies \
dependencies-ocaml catala.html help parser-messages plugins \
website-assets.tar website-assets-base
.PHONY: inspect clean all english alltest pygments install build_dev build doc \
format dependencies dependencies-ocaml catala.html help parser-messages \
plugins website-assets.tar website-assets-base

159
build_system/clerk_driver.ml
View File

@ -51,12 +51,18 @@ module Cli = struct
to '_build'.")
let include_dirs =
Arg.(
value
& opt_all string []
& info ["I"; "include"] ~docv:"DIR"
~doc:
"Make modules from the given directory available from everywhere.")
let arg =
Arg.(
value
& opt_all (list ~sep:':' string) []
& info ["I"; "include"] ~docv:"DIR"
~env:(Cmd.Env.info "CATALA_INCLUDE")
~doc:
"Make modules from the given directory available from \
everywhere. Several dirs can be specified by repeating the flag \
or separating them with '$(b,:)'.")
in
Term.(const List.flatten $ arg)
let test_flags =
Arg.(
@ -81,7 +87,7 @@ module Cli = struct
catala_opts:string list ->
build_dir:File.t option ->
include_dirs:string list ->
color:Cli.when_enum ->
color:Global.when_enum ->
debug:bool ->
ninja_output:File.t option ->
'a) ->
@ -97,7 +103,7 @@ module Cli = struct
let color =
Arg.(
value
& opt ~vopt:Cli.Always Cli.when_opt Auto
& opt ~vopt:Global.Always Cli.when_opt Auto
& info ["color"]
~env:(Cmd.Env.info "CATALA_COLOR")
~doc:
@ -278,11 +284,7 @@ module Poll = struct
Some root
| _ -> None)
let exec_dir : File.t =
(* Do not use Sys.executable_name, which may resolve symlinks: we want the
original path. (e.g. _build/install/default/bin/foo is a symlink) *)
Filename.dirname Sys.argv.(0)
let exec_dir : File.t = Catala_utils.Cli.exec_dir
let clerk_exe : File.t Lazy.t = lazy (Unix.realpath Sys.executable_name)
let catala_exe : File.t Lazy.t =
@ -298,14 +300,9 @@ module Poll = struct
let build_dir : ?dir:File.t -> unit -> File.t =
fun ?(dir = "_build") () ->
match Sys.is_directory dir with
| exception Sys_error _ ->
Sys.mkdir dir 0o770;
dir
| true -> dir
| false ->
Message.raise_error "Build directory %a exists but is not a directory"
File.format dir
let d = File.clean_path dir in
File.ensure_dir d;
d
(* Note: it could be safer here to use File.(Sys.getcwd () / "_build") by
default, but Ninja treats relative and absolute paths separately so that
you wouldn't then be able to build target _build/foo.ml but would have to
@ -413,9 +410,7 @@ let fix_path =
let from_dir = Sys.getcwd () in
fun d ->
let to_dir = Lazy.force Poll.project_root_relative in
match Catala_utils.Cli.reverse_path ~from_dir ~to_dir d with
| "" -> "."
| f -> f
Catala_utils.File.reverse_path ~from_dir ~to_dir d
(**{1 Building rules}*)
@ -433,8 +428,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"
@ -445,6 +441,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"
@ -475,7 +472,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 *)
@ -496,8 +493,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)];
@ -506,36 +504,48 @@ 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-object"
~command:[!ocamlc_exe; "-i"; !ocaml_flags; !input; ">"; !input^"i"; "&&";
!ocamlc_exe; "-opaque"; !ocaml_flags; !input^"i"; "&&";
!ocamlc_exe; "-c"; !ocaml_flags; !input; "&&";
!ocamlopt_exe; "-c"; "-intf-suffix"; ".ml"; !ocaml_flags; !input]
~description:["<ocaml>"; "⇒"; !output];
Nj.rule "ocaml-module"
~command:
[!ocamlopt_exe; "-shared"; !ocamlopt_flags; !input; "-o"; !output]
[!ocamlopt_exe; "-shared"; !ocaml_flags; !input; "-o"; !output]
~description:["<ocaml>"; "⇒"; !output];
Nj.rule "ocaml-exec"
~command: [
!ocamlopt_exe; !runtime_ocaml_libs; !ocamlopt_flags;
!input;
!ocamlopt_exe; !runtime_ocaml_libs; !ocaml_flags;
shellout [!catala_exe; "depends";
"--prefix="^ !builddir; "--extension=cmx";
!catala_flags; !orig_src];
"-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:
@ -543,7 +553,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"
@ -656,18 +667,20 @@ let gen_build_statements
~implicit_in:[!Var.catala_exe] ~outputs:[py_file] )
in
let ocamlopt =
let implicit_out_exts = ["cmi"; "cmx"; "cmt"; "o"] in
match item.module_def with
| Some m ->
let obj =
let m =
match item.module_def with
| Some m -> m
| None -> Filename.(basename (remove_extension src))
in
let target ext = (!Var.builddir / src /../ m) ^ "." ^ ext in
Nj.build "ocaml-module" ~inputs:[ml_file]
Nj.build "ocaml-object" ~inputs:[ml_file]
~implicit_in:(!Var.catala_exe :: List.map modd modules)
~outputs:[target "cmxs"]
~implicit_out:(List.map target implicit_out_exts)
~outputs:(List.map target ["mli"; "cmi"; "cmo"; "cmx"; "cmt"; "o"])
~vars:
[
( Var.ocamlopt_flags,
!Var.ocamlopt_flags
( Var.ocaml_flags,
!Var.ocaml_flags
:: "-I"
:: (!Var.builddir / src /../ "")
:: List.concat_map
@ -678,44 +691,20 @@ let gen_build_statements
])
include_dirs );
]
| None ->
let target ext = (!Var.builddir / !Var.src) ^ "." ^ ext in
let inputs, modules =
List.partition_map
(fun m ->
if List.mem m same_dir_modules then
Left ((!Var.builddir / src /../ m) ^ ".cmx")
else Right m)
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)
~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 *)
]
in
let modexec =
match item.module_def with
| Some _ ->
Nj.build "ocaml-module"
~inputs:[target_file "cmx"]
~outputs:[target_file "cmxs"]
| None ->
Nj.build "ocaml-exec"
~inputs:[target_file "cmx"]
~outputs:[target_file "exe"]
~vars:[Var.orig_src, [inc srcv]]
in
[obj; modexec]
in
let expose_module =
match item.module_def with
@ -821,7 +810,7 @@ let gen_build_statements
Option.to_seq module_deps;
Option.to_seq expose_module;
Seq.return ocaml;
Seq.return ocamlopt;
List.to_seq ocamlopt;
Seq.return python;
List.to_seq tests;
Seq.return interpret;
@ -901,7 +890,7 @@ let ninja_init
~debug
~ninja_output :
extra:def Seq.t -> test_flags:string list -> (File.t -> 'a) -> 'a =
let _options = Catala_utils.Cli.enforce_globals ~debug ~color () in
let _options = Catala_utils.Global.enforce_options ~debug ~color () in
let chdir =
match chdir with None -> Lazy.force Poll.project_root | some -> some
in
@ -939,7 +928,7 @@ let ninja_cmdline ninja_flags nin_file targets =
:: "-f"
:: nin_file
:: (if ninja_flags = "" then [] else [ninja_flags])
@ (if Catala_utils.Cli.globals.debug then ["-v"] else [])
@ (if Catala_utils.Global.options.debug then ["-v"] else [])
@ targets)
open Cmdliner
@ -1080,7 +1069,7 @@ let main () =
| Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit content Error;
if Catala_utils.Cli.globals.debug then
if Catala_utils.Global.options.debug then
Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
| Sys_error msg ->

3
build_system/clerk_scan.ml
View File

@ -54,7 +54,8 @@ let test_command_args =
fun str ->
exec_opt re str |> Option.map (fun g -> String.trim (Re.Group.get g 1))
let catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : item =
let catala_file (file : File.t) (lang : Catala_utils.Global.backend_lang) : item
=
let module L = Surface.Lexer_common in
let rec parse lines n acc =
match Seq.uncons lines with

4
build_system/clerk_scan.mli
View File

@ -46,10 +46,10 @@ type item = {
(** Contains all the data extracted from a single Catala file. Lists are in
reverse file order. *)
val get_lang : File.t -> Cli.backend_lang option
val get_lang : File.t -> Global.backend_lang option
(** Guesses Catala dialect from file-name and global options *)
val catala_file : File.t -> Catala_utils.Cli.backend_lang -> item
val catala_file : File.t -> Global.backend_lang -> item
(** Scans a single Catala file into an item *)
val tree : File.t -> (File.t * File.t list * item list) Seq.t

1
catala.opam
View File

@ -19,7 +19,6 @@ homepage: "https://github.com/CatalaLang/catala"
bug-reports: "https://github.com/CatalaLang/catala/issues"
depends: [
"ocolor" {>= "1.3.0"}
"benchmark" {>= "1.6"}
"bindlib" {>= "5.0.1"}
"cmdliner" {>= "1.1.0"}
"cppo" {>= "1"}

181
compiler/catala_utils/cli.ml
View File

@ -15,87 +15,30 @@
License for the specific language governing permissions and limitations under
the License. *)
(* Types used by flags & options *)
open Global
type file = string
type raw_file = file
type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU
type input_src = FileName of file | Contents of string * file | Stdin of file
(* Manipulation of types used by flags & options *)
(** Associates a {!type: Cli.backend_lang} with its string represtation. *)
(** Associates a {!type: Global.backend_lang} with its string represtation. *)
let languages = ["en", En; "fr", Fr; "pl", Pl]
let language_code =
let rl = List.map (fun (a, b) -> b, a) languages in
fun l -> List.assoc l rl
let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
let message_format_opt = ["human", Human; "gnu", GNU]
type options = {
mutable input_src : input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(* Note: we force that the global options (ie options common to all commands)
and the options available through global refs are the same. While this is a
bit arbitrary, it makes some sense code-wise and provides some safeguard
against explosion of the number of global references. Reducing the number of
globals further would be nice though. *)
let globals =
{
input_src = Stdin "-stdin-";
language = None;
debug = false;
color = Auto;
message_format = Human;
trace = false;
plugins_dirs = [];
disable_warnings = false;
max_prec_digits = 20;
path_rewrite = (fun _ -> assert false);
}
let enforce_globals
?input_src
?language
?debug
?color
?message_format
?trace
?plugins_dirs
?disable_warnings
?max_prec_digits
?path_rewrite
() =
Option.iter (fun x -> globals.input_src <- x) input_src;
Option.iter (fun x -> globals.language <- x) language;
Option.iter (fun x -> globals.debug <- x) debug;
Option.iter (fun x -> globals.color <- x) color;
Option.iter (fun x -> globals.message_format <- x) message_format;
Option.iter (fun x -> globals.trace <- x) trace;
Option.iter (fun x -> globals.plugins_dirs <- x) plugins_dirs;
Option.iter (fun x -> globals.disable_warnings <- x) disable_warnings;
Option.iter (fun x -> globals.max_prec_digits <- x) max_prec_digits;
Option.iter (fun x -> globals.path_rewrite <- x) path_rewrite;
globals
open Cmdliner
(* Arg converters for our custom types *)
let when_opt = Arg.enum ["auto", Auto; "always", Always; "never", Never]
let raw_file =
Arg.conv ~docv:"FILE"
( (fun f -> Result.map raw_file (Arg.conv_parser Arg.string f)),
fun ppf f -> Format.pp_print_string ppf (f :> string) )
(* Some helpers for catala sources *)
let extensions = [".catala_fr", Fr; ".catala_en", En; ".catala_pl", Pl]
@ -105,7 +48,7 @@ let file_lang filename =
|> function
| Some lang -> lang
| None -> (
match globals.language with
match Global.options.language with
| Some lang -> lang
| None ->
Format.kasprintf failwith
@ -113,30 +56,14 @@ let file_lang filename =
@{<yellow>%s@}, and @{<bold>--language@} was not specified"
filename)
let reverse_path ?(from_dir = Sys.getcwd ()) ~to_dir f =
if Filename.is_relative from_dir then invalid_arg "File.with_reverse_path"
else if not (Filename.is_relative f) then f
else if not (Filename.is_relative to_dir) then Filename.concat from_dir f
else
let rec aux acc rbase = function
| [] -> acc
| dir :: p -> (
if dir = Filename.parent_dir_name then
match rbase with
| base1 :: rbase -> aux (base1 :: acc) rbase p
| [] -> aux acc [] p
else
match acc with
| dir1 :: acc when dir1 = dir -> aux acc rbase p
| _ -> aux (Filename.parent_dir_name :: acc) rbase p)
in
let path_to_list path =
String.split_on_char Filename.dir_sep.[0] path
|> List.filter (function "" | "." -> false | _ -> true)
in
let rbase = List.rev (path_to_list from_dir) in
String.concat Filename.dir_sep
(aux (path_to_list f) rbase (path_to_list to_dir))
let exec_dir =
let cmd = Sys.argv.(0) in
if String.contains cmd '/' then
(* Do not use Sys.executable_name, which may resolve symlinks: we want the
original path. (e.g. _build/install/default/bin/foo is a symlink) *)
Filename.dirname cmd
else (* searched in PATH *)
Filename.dirname Sys.executable_name
(** CLI flags and options *)
@ -151,11 +78,14 @@ module Flags = struct
let converter =
conv ~docv:"FILE"
( (fun s ->
if s = "-" then Ok (Stdin "-stdin-")
else Result.map (fun f -> FileName f) (conv_parser non_dir_file s)),
if s = "-" then Ok (Stdin (Global.raw_file "-stdin-"))
else
Result.map
(fun f -> FileName (Global.raw_file f))
(conv_parser non_dir_file s)),
fun ppf -> function
| Stdin _ -> Format.pp_print_string ppf "-"
| FileName f -> conv_printer non_dir_file ppf f
| FileName f -> conv_printer non_dir_file ppf (f :> file)
| _ -> assert false )
in
required
@ -225,7 +155,6 @@ module Flags = struct
let env = Cmd.Env.info "CATALA_PLUGINS" in
let default =
let ( / ) = Filename.concat in
let exec_dir = Filename.(dirname Sys.argv.(0)) in
let dev_plugin_dir = exec_dir / "plugins" in
if Sys.file_exists dev_plugin_dir then
(* When running tests in place, may need to lookup in _build/default
@ -283,13 +212,16 @@ module Flags = struct
if debug then Printexc.record_backtrace true;
let path_rewrite =
match directory with
| None -> fun f -> f
| None -> fun (f : Global.raw_file) -> (f :> file)
| Some to_dir -> (
function "-" -> "-" | f -> reverse_path ~to_dir f)
fun (f : Global.raw_file) ->
match (f :> file) with
| "-" -> "-"
| f -> File.reverse_path ~to_dir f)
in
(* This sets some global refs for convenience, but most importantly
returns the options record. *)
enforce_globals ~language ~debug ~color ~message_format ~trace
Global.enforce_options ~language ~debug ~color ~message_format ~trace
~plugins_dirs ~disable_warnings ~max_prec_digits ~path_rewrite ()
in
Term.(
@ -308,34 +240,33 @@ module Flags = struct
let make input_src name directory options : options =
(* Set some global refs for convenience *)
let input_src =
match name with
| None -> input_src
| Some name -> (
match input_src with
| FileName f -> FileName f
| Contents (str, _) -> Contents (str, name)
| Stdin _ -> Stdin name)
in
let input_src =
let rename f =
match name with None -> f | Some n -> Global.raw_file n
in
match input_src with
| FileName f -> FileName (options.path_rewrite f)
| Contents (str, f) -> Contents (str, options.path_rewrite f)
| Stdin f -> Stdin (options.path_rewrite f)
| Contents (str, f) -> Contents (str, options.path_rewrite (rename f))
| Stdin f -> Stdin (options.path_rewrite (rename f))
in
let plugins_dirs = List.map options.path_rewrite options.plugins_dirs in
Option.iter Sys.chdir directory;
globals.input_src <- input_src;
globals.plugins_dirs <- plugins_dirs;
{ options with input_src; plugins_dirs }
Global.enforce_options ~input_src ()
in
Term.(const make $ input_src $ name_flag $ directory $ flags)
end
let include_dirs =
value
& opt_all string []
& info ["I"; "include"] ~docv:"DIR"
~doc:"Include directory to lookup for compiled module files."
let arg =
Arg.(
value
& opt_all (list ~sep:':' raw_file) []
& info ["I"; "include"] ~docv:"DIR"
~env:(Cmd.Env.info "CATALA_INCLUDE")
~doc:
"Make modules from the given directory available from \
everywhere. Several dirs can be specified by repeating the flag \
or separating them with '$(b,:)'.")
in
Term.(const List.flatten $ arg)
let check_invariants =
value
@ -378,7 +309,7 @@ module Flags = struct
let output =
value
& opt (some string) None
& opt (some raw_file) None
& info ["output"; "o"] ~docv:"OUTPUT"
~env:(Cmd.Env.info "CATALA_OUT")
~doc:
@ -452,7 +383,7 @@ module Flags = struct
let extra_files =
value
& pos_right 0 file []
& Arg.info [] ~docv:"FILE" ~docs:Manpage.s_arguments
& Arg.info [] ~docv:"FILES" ~docs:Manpage.s_arguments
~doc:"Additional input files."
let lcalc =
@ -462,6 +393,20 @@ 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_all string []
& info ["extension"; "e"] ~docv:"EXT"
~doc:
"Replace the original file extensions with $(i,.EXT). If repeated, \
the file will be listed once which each supplied extension."
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 *)

93
compiler/catala_utils/cli.mli
View File

@ -15,33 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
type file = string
(** File names ; equal to [File.t] but let's avoid cyclic dependencies *)
type raw_file
(** A file name that has not yet been resolved, [options.path_rewrite] must be
called on it *)
type backend_lang = En | Fr | Pl
(** The usual auto/always/never option argument *)
type when_enum = Auto | Always | Never
val when_opt : when_enum Cmdliner.Arg.conv
type message_format_enum =
| Human
| GNU (** Format of error and warning messages output by the compiler. *)
(** Sources for program input *)
type input_src =
| FileName of file (** A file path to read from disk *)
| Contents of string * file
(** A raw string containing the code, and the corresponding (fake)
filename *)
| Stdin of file
(** Read from stdin; the specified filename will be used for file lookups,
error reportings, etc. *)
open Global
val languages : (string * backend_lang) list
@ -49,59 +23,13 @@ val language_code : backend_lang -> string
(** Returns the lowercase two-letter language code *)
val file_lang : file -> backend_lang
(** Associates a file extension with its corresponding {!type: Cli.backend_lang}
string representation. *)
val input_src_file : input_src -> file
val reverse_path : ?from_dir:file -> to_dir:file -> file -> file
(** If [to_dir] is a path to a given directory and [f] a path to a file as seen
from absolute path [from_dir], [reverse_path ~from_dir ~to_dir f] is a path
leading to [f] from [to_dir]. The results attempts to be relative to
[to_dir]. *)
(** {2 Configuration globals} *)
type options = private {
mutable input_src : input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : string list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(** Global options, common to all subcommands (note: the fields are internally
mutable only for purposes of the [globals] toplevel value defined below) *)
val globals : options
(** A global definition to the global options is provided for convenience, e.g.
choosing the proper output in formatting functions. Prefer the use of the
options returned by the command-line parsing whenever possible. *)
val enforce_globals :
?input_src:input_src ->
?language:backend_lang option ->
?debug:bool ->
?color:when_enum ->
?message_format:message_format_enum ->
?trace:bool ->
?plugins_dirs:string list ->
?disable_warnings:bool ->
?max_prec_digits:int ->
?path_rewrite:(file -> file) ->
unit ->
options
(** Sets up the global options (side-effect); for specific use-cases only, this
should never be called from the compiler or when going through normal
command-line parsing. Proper uses include setting up the compiler library
when using it directly through a specific front-end. *)
(** Associates a file extension with its corresponding
{!type: Global.backend_lang} string representation. *)
(** {2 CLI flags and options} *)
val when_opt : when_enum Cmdliner.Arg.conv
module Flags : sig
open Cmdliner
@ -141,6 +69,12 @@ module Flags : sig
val lcalc : bool Term.t
(** for the 'interpret' command *)
val extension : string list Term.t
(** for the 'depends' command *)
val prefix : string option Term.t
(** for the 'depends' command *)
end
(** {2 Command-line application} *)
@ -154,3 +88,8 @@ val s_plugins : string
exception Exit_with of int
(** Exit with a specific exit code (but less brutally than [Sys.exit] which
would bypass all finalisers) *)
(** {2 Other helpers} *)
val exec_dir : file
(** Returns the directory of the currently running executable *)

87
compiler/catala_utils/file.ml
View File

@ -16,6 +16,8 @@
type t = string
let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
(** Run finaliser [f] unconditionally after running [k ()], propagating any
raised exception. *)
let finally f k =
@ -30,11 +32,80 @@ let finally f k =
let temp_file pfx sfx =
let f = Filename.temp_file pfx sfx in
if not Cli.globals.debug then
if not Global.options.debug then
at_exit (fun () -> try Sys.remove f with _ -> ());
f
let ( / ) a b = if a = Filename.current_dir_name then b else Filename.concat a b
let dir_sep_char = Filename.dir_sep.[0]
let rec parent f =
let base = Filename.basename f in
if base = Filename.parent_dir_name || base = Filename.current_dir_name then
parent (Filename.dirname f) / base
else Filename.dirname f
let clean_path p =
let ( / ) a b = if b = "" then a else a / b in
let nup, p =
List.fold_right
(fun d (nup, acc) ->
if d = Filename.current_dir_name then nup, acc
else if d = Filename.parent_dir_name then nup + 1, acc
else if nup > 0 then nup - 1, acc
else nup, d / acc)
(String.split_on_char dir_sep_char p)
(0, "")
in
let p =
if nup = 0 then p
else
String.concat Filename.dir_sep
(List.init nup (fun _ -> Filename.parent_dir_name))
/ p
in
if p = "" then "." else p
let rec ensure_dir dir =
match Sys.is_directory dir with
| true -> ()
| false ->
Message.raise_error "Directory %a exists but is not a directory" format dir
| exception Sys_error _ ->
let pdir = parent dir in
if pdir <> dir then ensure_dir pdir;
Sys.mkdir dir
0o777 (* will be affected by umask, most likely restricted to 0o755 *)
let reverse_path ?(from_dir = Sys.getcwd ()) ~to_dir f =
clean_path
@@
if Filename.is_relative from_dir then invalid_arg "File.reverse_path"
else if not (Filename.is_relative f) then f
else if not (Filename.is_relative to_dir) then Filename.concat from_dir f
else
let rec aux acc rbase = function
| [] -> acc
| dir :: p -> (
if dir = Filename.parent_dir_name then
match rbase with
| base1 :: rbase -> aux (base1 :: acc) rbase p
| [] -> aux acc [] p
else
match acc with
| dir1 :: acc when dir1 = dir -> aux acc rbase p
| _ -> aux (Filename.parent_dir_name :: acc) rbase p)
in
let path_to_list path =
String.split_on_char Filename.dir_sep.[0] path
|> List.filter (function "" | "." -> false | _ -> true)
in
let rbase = List.rev (path_to_list from_dir) in
String.concat Filename.dir_sep
(aux (path_to_list f) rbase (path_to_list to_dir))
let with_out_channel filename f =
ensure_dir (Filename.dirname filename);
let oc = open_out filename in
finally (fun () -> close_out oc) (fun () -> f oc)
@ -59,7 +130,7 @@ let get_out_channel ~source_file ~output_file ?ext () =
| Some "-", _ | None, None -> None, fun f -> f stdout
| Some f, _ -> Some f, with_out_channel f
| None, Some ext ->
let src = Cli.input_src_file source_file in
let src = Global.input_src_file source_file in
let f = Filename.remove_extension src ^ ext in
Some f, with_out_channel f
@ -126,8 +197,6 @@ let get_command t =
"/bin/sh"
["-c"; "command -v " ^ Filename.quote t]
let dir_sep_char = Filename.dir_sep.[0]
let check_exec t =
try if String.contains t dir_sep_char then Unix.realpath t else get_command t
with Unix.Unix_error _ | Sys_error _ ->
@ -135,10 +204,12 @@ let check_exec t =
"Could not find the @{<yellow>%s@} program, please fix your installation"
(Filename.quote 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 ( /../ ) a b = parent a / b
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
@ -150,8 +221,6 @@ let equal a b =
let compare a b =
String.compare (String.lowercase_ascii a) (String.lowercase_ascii b)
let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
module Set = Set.Make (struct
type nonrec t = t

28
compiler/catala_utils/file.mli
View File

@ -44,7 +44,7 @@ val with_formatter_of_opt_file : t option -> (Format.formatter -> 'a) -> 'a
{!with_formatter_of_file}), otherwise, uses the [Format.std_formatter]. *)
val get_out_channel :
source_file:Cli.input_src ->
source_file:t Global.input_src ->
output_file:t option ->
?ext:string ->
unit ->
@ -54,7 +54,7 @@ val get_out_channel :
equal to [Some "-"] returns a wrapper around [stdout]. *)
val get_formatter_of_out_channel :
source_file:Cli.input_src ->
source_file:t Global.input_src ->
output_file:t option ->
?ext:string ->
unit ->
@ -85,6 +85,10 @@ val check_directory : t -> t option
(** Checks if the given directory exists and returns it normalised (as per
[Unix.realpath]). *)
val ensure_dir : t -> unit
(** Creates the directory (and parents recursively) if it doesn't exist already.
Errors out if the file exists but is not a directory *)
val check_file : t -> t option
(** Returns its argument if it exists and is a plain file, [None] otherwise.
Does not do resolution like [check_directory]. *)
@ -103,12 +107,28 @@ val ( / ) : t -> t -> t
val dirname : t -> t
(** [Filename.dirname], re-exported for convenience *)
val parent : t -> t
(** Similar to [dirname], except it strips the last **non-"." or ".."** element
in the supplied file name, if it exists *)
val clean_path : t -> t
(** Rewrites a path by removing intermediate relative lookups ("." and "..").
E.g. [../foo/./bar/../baz/] becomes [../foo/baz]. No disk lookup is made by
this function. *)
val reverse_path : ?from_dir:t -> to_dir:t -> t -> t
(** If [to_dir] is a path to a given directory and [f] a path to a file as seen
from absolute path [from_dir], [reverse_path ~from_dir ~to_dir f] is a path
leading to [f] from [to_dir]. The results attempts to be relative to
[to_dir]. *)
val ( /../ ) : t -> t -> t
(** Sugar for [Filename.dirname "a" / b] *)
(** Sugar for [parent a / b] *)
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 *)

86
compiler/catala_utils/global.ml Normal file
View File

@ -0,0 +1,86 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2024 Inria,
contributors: Louis Gesbert <louis.gesbert@inria.fr>
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. *)
type file = string
type raw_file = file
type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU
type 'file input_src =
| FileName of 'file
| Contents of string * 'file
| Stdin of 'file
(* ['file] is expected to be [file] or [raw_file] *)
type options = {
mutable input_src : file input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(* Note: we force that the global options (ie options common to all commands)
and the options available through global refs are the same. While this is a
bit arbitrary, it makes some sense code-wise and provides some safeguard
against explosion of the number of global references. Reducing the number of
globals further would be nice though. *)
let options =
{
input_src = Stdin "-stdin-";
language = None;
debug = false;
color = Auto;
message_format = Human;
trace = false;
plugins_dirs = [];
disable_warnings = false;
max_prec_digits = 20;
path_rewrite = (fun _ -> assert false);
}
let enforce_options
?input_src
?language
?debug
?color
?message_format
?trace
?plugins_dirs
?disable_warnings
?max_prec_digits
?path_rewrite
() =
Option.iter (fun x -> options.input_src <- x) input_src;
Option.iter (fun x -> options.language <- x) language;
Option.iter (fun x -> options.debug <- x) debug;
Option.iter (fun x -> options.color <- x) color;
Option.iter (fun x -> options.message_format <- x) message_format;
Option.iter (fun x -> options.trace <- x) trace;
Option.iter (fun x -> options.plugins_dirs <- x) plugins_dirs;
Option.iter (fun x -> options.disable_warnings <- x) disable_warnings;
Option.iter (fun x -> options.max_prec_digits <- x) max_prec_digits;
Option.iter (fun x -> options.path_rewrite <- x) path_rewrite;
options
let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
let raw_file f = f

89
compiler/catala_utils/global.mli Normal file
View File

@ -0,0 +1,89 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2024 Inria,
contributors: Louis Gesbert <louis.gesbert@inria.fr>
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. *)
(** This module contains definitions of global flags and types used throughout.
They should be defined from the command-line and never modified afterwards. *)
type file = string
(** File names ; equal to [File.t] but let's avoid cyclic dependencies *)
type raw_file = private file
(** A file name that has not yet been resolved, [options.path_rewrite] must be
called on it *)
type backend_lang = En | Fr | Pl
(** The usual auto/always/never option argument *)
type when_enum = Auto | Always | Never
type message_format_enum =
| Human
| GNU (** Format of error and warning messages output by the compiler. *)
(** Sources for program input *)
type 'file input_src =
| FileName of 'file (** A file path to read from disk *)
| Contents of string * 'file
(** A raw string containing the code, and the corresponding (fake)
filename *)
| Stdin of 'file
(** Read from stdin; the specified filename will be used for file lookups,
error reportings, etc. *)
(** {2 Configuration globals} *)
type options = private {
mutable input_src : file input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(** Global options, common to all subcommands (note: the fields are internally
mutable only for purposes of the [globals] toplevel value defined below) *)
val options : options
(** A global definition to the global options is provided for convenience, e.g.
choosing the proper output in formatting functions. Prefer the use of the
options returned by the command-line parsing whenever possible. *)
val enforce_options :
?input_src:file input_src ->
?language:backend_lang option ->
?debug:bool ->
?color:when_enum ->
?message_format:message_format_enum ->
?trace:bool ->
?plugins_dirs:file list ->
?disable_warnings:bool ->
?max_prec_digits:int ->
?path_rewrite:(raw_file -> file) ->
unit ->
options
(** Sets up the global options (side-effect); for specific use-cases only, this
should never be called from the compiler outside of the [Cli] module. Other
proper uses include setting up the compiler library when using it directly
through a specific front-end. *)
val input_src_file : file input_src -> file
val raw_file : string -> raw_file
(** Create a [raw_file], for use directly after parsing from the cmdline *)

14
compiler/catala_utils/message.ml
View File

@ -39,8 +39,8 @@ let () = ignore (unstyle_formatter Format.str_formatter)
below std_ppf / err_ppf *)
let has_color oc =
match Cli.globals.color with
| Cli.Never -> false
match Global.options.color with
| Global.Never -> false
| Always -> true
| Auto -> Unix.(isatty (descr_of_out_channel oc))
@ -78,8 +78,8 @@ type content_type = Error | Warning | Debug | Log | Result
let get_ppf = function
| Result -> Lazy.force std_ppf
| Debug when not Cli.globals.debug -> Lazy.force ignore_ppf
| Warning when Cli.globals.disable_warnings -> Lazy.force ignore_ppf
| Debug when not Global.options.debug -> Lazy.force ignore_ppf
| Warning when Global.options.disable_warnings -> Lazy.force ignore_ppf
| Error | Log | Debug | Warning -> Lazy.force err_ppf
(**{3 Markers}*)
@ -150,8 +150,8 @@ module Content = struct
[MainMessage (fun ppf -> Format.pp_print_string ppf s)]
let emit (content : t) (target : content_type) : unit =
match Cli.globals.message_format with
| Cli.Human ->
match Global.options.message_format with
| Global.Human ->
let ppf = get_ppf target in
Format.fprintf ppf "@[<hv>%t%t%a@]@." (pp_marker target)
(fun (ppf : Format.formatter) ->
@ -174,7 +174,7 @@ module Content = struct
Suggestions.format ppf suggestions_list)
ppf message_elements)
content
| Cli.GNU ->
| Global.GNU ->
(* The top message doesn't come with a position, which is not something
the GNU standard allows. So we look the position list and put the top
message everywhere there is not a more precise message. If we can't

2
compiler/catala_utils/pos.ml
View File

@ -130,7 +130,7 @@ let format_loc_text ppf (pos : t) =
let eline = get_end_line pos in
let ic, input_line_opt =
let from_contents =
match Cli.globals.input_src with
match Global.options.input_src with
| Contents (str, _) when str = filename -> Some str
| _ -> None
in

70
compiler/catala_utils/string.ml
View File

@ -23,30 +23,26 @@ let begins_with_uppercase (s : string) : bool =
"" <> s && is_uppercase_ascii (get (to_ascii s) 0)
let to_snake_case (s : string) : string =
let out = ref "" in
to_ascii s
let out = Buffer.create (2 * length s) in
s
|> to_ascii
|> iteri (fun i c ->
out :=
!out
^ (if is_uppercase_ascii c && 0 <> i then "_" else "")
^ lowercase_ascii (make 1 c));
!out
if is_uppercase_ascii c && 0 <> i then Buffer.add_char out '_';
Buffer.add_char out (Char.lowercase_ascii c));
Buffer.contents out
let to_camel_case (s : string) : string =
let last_was_underscore = ref false in
let out = ref "" in
to_ascii s
|> iteri (fun i c ->
let is_underscore = c = '_' in
let c_string = make 1 c in
out :=
!out
^
if is_underscore then ""
else if !last_was_underscore || 0 = i then uppercase_ascii c_string
else c_string;
last_was_underscore := is_underscore);
!out
let last_was_underscore = ref true in
let out = Buffer.create (length s) in
s
|> to_ascii
|> iter (function
| '_' -> last_was_underscore := true
| c ->
Buffer.add_char out
(if !last_was_underscore then Char.uppercase_ascii c else c);
last_was_underscore := false);
Buffer.contents out
let remove_prefix ~prefix s =
if starts_with ~prefix s then
@ -72,7 +68,39 @@ module Arg = struct
include Stdlib.String
let format = format
let compare s1 s2 =
let len1 = length s1 in
let len2 = length s2 in
let int c = int_of_char c - int_of_char '0' in
let rec readnum acc s i =
if i >= length s then acc, i
else
match get s i with
| '0' .. '9' as c -> readnum ((acc * 10) + int c) s (i + 1)
| _ -> acc, i
in
let rec aux i1 i2 =
if i1 >= len1 then if i2 >= len2 then 0 else -1
else if i2 >= len2 then 1
else
match get s1 i1, get s2 i2 with
| ('0' .. '9' as c1), ('0' .. '9' as c2) -> (
let x1, i1' = readnum (int c1) s1 (i1 + 1) in
let x2, i2' = readnum (int c2) s2 (i2 + 1) in
match Int.compare x1 x2 with
| 0 -> (
match Int.compare (i1' - i1) (i2' - i2) with
| 0 -> aux i1' i2'
| n -> n)
| n -> n)
| c1, c2 -> (
match Char.compare c1 c2 with 0 -> aux (i1 + 1) (i2 + 1) | n -> n)
in
aux 0 0
end
let compare = Arg.compare
module Set = Set.Make (Arg)
module Map = Map.Make (Arg)

3
compiler/catala_utils/string.mli
View File

@ -20,6 +20,9 @@ module Map : Map.S with type key = string
(** Helper functions used for string manipulation. *)
val compare : string -> string -> int
(** String comparison with natural ordering of numbers within strings *)
val to_ascii : string -> string
(** Removes all non-ASCII diacritics from a string by converting them to their
base letter in the Latin alphabet. *)

2
compiler/catala_web_interpreter.ml
View File

@ -19,7 +19,7 @@ let () =
Message.raise_error "Unrecognised input locale %S" language
in
let options =
Cli.enforce_globals
Global.enforce_options
~input_src:(Contents (contents, "-inline-"))
~language:(Some language) ~debug:false ~color:Never ~trace ()
in

2
compiler/dcalc/from_scopelang.ml
View File

@ -140,7 +140,7 @@ let tag_with_log_entry
(markings : Uid.MarkedString.info list) : 'm Ast.expr boxed =
let m = mark_tany (Mark.get e) (Expr.pos e) in
if Cli.globals.trace then
if Global.options.trace then
Expr.eappop ~op:(Log (l, markings)) ~tys:[TAny, Expr.pos e] ~args:[e] m
else e

2
compiler/desugared/ast.ml
View File

@ -238,7 +238,7 @@ type program = {
program_ctx : decl_ctx;
program_modules : modul ModuleName.Map.t;
program_root : modul;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
let rec locations_used e : LocationSet.t =

2
compiler/desugared/ast.mli
View File

@ -126,7 +126,7 @@ type program = {
program_modules : modul ModuleName.Map.t;
(** Contains all submodules of the program, in a flattened structure *)
program_root : modul;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
(** {1 Helpers} *)

23
compiler/desugared/from_surface.ml
View File

@ -159,6 +159,17 @@ let rec disambiguate_constructor
try Ident.Map.find (Mark.remove constructor) ctxt.local.constructor_idmap
with Ident.Map.Not_found _ -> raise_error_cons_not_found ctxt constructor
in
let possible_c_uids =
(* Eliminate candidates from other modules if there exists some from the
current one *)
let current_module =
EnumName.Map.filter
(fun struc _ -> EnumName.path struc = [])
possible_c_uids
in
if EnumName.Map.is_empty current_module then possible_c_uids
else current_module
in
match path with
| [] ->
if EnumName.Map.cardinal possible_c_uids > 1 then
@ -622,7 +633,17 @@ let rec translate_expr
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
let get_possible_c_uids ctxt =
try
Ident.Map.find constructor ctxt.Name_resolution.local.constructor_idmap
let possible =
Ident.Map.find constructor
ctxt.Name_resolution.local.constructor_idmap
in
(* Eliminate candidates from other modules if there exists some from the
current one *)
let current_module =
EnumName.Map.filter (fun struc _ -> EnumName.path struc = []) possible
in
if EnumName.Map.is_empty current_module then possible
else current_module
with Ident.Map.Not_found _ ->
raise_error_cons_not_found ctxt (constructor, pos_constructor)
in

147
compiler/driver.ml
View File

@ -18,22 +18,27 @@
open Catala_utils
open Shared_ast
(** Associates a file extension with its corresponding {!type: Cli.backend_lang}
string representation. *)
(** Associates a file extension with its corresponding
{!type: Global.backend_lang} string representation. *)
let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
let modname_of_file f =
(* Fixme: make this more robust *)
String.capitalize_ascii Filename.(basename (remove_extension f))
let load_module_interfaces options includes program =
let load_module_interfaces
options
includes
?(more_includes = [])
?(allow_notmodules = false)
program =
(* Recurse into program modules, looking up files in [using] and loading
them *)
if program.Surface.Ast.program_used_modules <> [] then
Message.emit_debug "Loading module interfaces...";
let includes =
includes
|> List.map (fun d -> File.Tree.build (options.Cli.path_rewrite d))
List.map options.Global.path_rewrite includes @ more_includes
|> List.map File.Tree.build
|> List.fold_left File.Tree.union File.Tree.empty
in
let err_req_pos chain =
@ -80,7 +85,13 @@ let load_module_interfaces options includes program =
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
"Circular module dependency"
| None ->
let intf = Surface.Parser_driver.load_interface (Cli.FileName f) in
let default_module_name =
if allow_notmodules then Some (modname_of_file f) else None
in
let intf =
Surface.Parser_driver.load_interface ?default_module_name
(Global.FileName f)
in
let modname = ModuleName.fresh intf.intf_modname in
let seen = File.Map.add f None seen in
let seen, sub_use_map =
@ -126,7 +137,7 @@ module Passes = struct
let surface options : Surface.Ast.program =
debug_pass_name "surface";
let prg =
Surface.Parser_driver.parse_top_level_file options.Cli.input_src
Surface.Parser_driver.parse_top_level_file options.Global.input_src
in
Surface.Fill_positions.fill_pos_with_legislative_info prg
@ -158,8 +169,8 @@ module Passes = struct
let dcalc :
type ty.
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
typed:ty mark ->
@ -391,18 +402,19 @@ module Commands = struct
second_part )
let get_output ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in
File.get_out_channel ~source_file:options.Cli.input_src ~output_file ?ext ()
let output_file = Option.map options.Global.path_rewrite output_file in
File.get_out_channel ~source_file:options.Global.input_src ~output_file ?ext
()
let get_output_format ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in
File.get_formatter_of_out_channel ~source_file:options.Cli.input_src
let output_file = Option.map options.Global.path_rewrite output_file in
File.get_formatter_of_out_channel ~source_file:options.Global.input_src
~output_file ?ext ()
let makefile options output =
let prg = Passes.surface options in
let backend_extensions_list = [".tex"] in
let source_file = Cli.input_src_file options.Cli.input_src in
let source_file = Global.input_src_file options.Global.input_src in
let output_file, with_output = get_output options ~ext:".d" output in
Message.emit_debug "Writing list of dependencies to %s..."
(Option.value ~default:"stdout" output_file);
@ -433,7 +445,9 @@ module Commands = struct
in
with_output
@@ fun fmt ->
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
let language =
Cli.file_lang (Global.input_src_file options.Global.input_src)
in
let weave_output = Literate.Html.ast_to_html language ~print_only_law in
Message.emit_debug "Writing to %s"
(Option.value ~default:"stdout" output_file);
@ -469,7 +483,9 @@ module Commands = struct
in
with_output
@@ fun fmt ->
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
let language =
Cli.file_lang (Global.input_src_file options.Global.input_src)
in
let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in
Message.emit_debug "Writing to %s"
(Option.value ~default:"stdout" output_file);
@ -538,11 +554,11 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.program_ctx scope in
Scopelang.Print.scope ~debug:options.Cli.debug prg.program_ctx fmt
Scopelang.Print.scope ~debug:options.Global.debug prg.program_ctx fmt
(scope_uid, ScopeName.Map.find scope_uid prg.program_scopes);
Format.pp_print_newline fmt ()
| None ->
Scopelang.Print.program ~debug:options.Cli.debug fmt prg;
Scopelang.Print.program ~debug:options.Global.debug fmt prg;
Format.pp_print_newline fmt ()
let scopelang_cmd =
@ -604,7 +620,7 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.decl_ctx scope in
Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt
Print.scope ~debug:options.Global.debug prg.decl_ctx fmt
( scope_uid,
BoundList.find
~f:(function
@ -618,7 +634,7 @@ module Commands = struct
(* TODO: ??? *)
let prg_dcalc_expr = Expr.unbox (Program.to_expr prg scope_uid) in
Format.fprintf fmt "%a\n"
(Print.expr ~debug:options.Cli.debug ())
(Print.expr ~debug:options.Global.debug ())
prg_dcalc_expr
let dcalc_cmd =
@ -683,11 +699,13 @@ module Commands = struct
in
Message.emit_result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
let language =
Cli.file_lang (Global.input_src_file options.Global.input_src)
in
List.iter
(fun ((var, _), result) ->
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
(if options.Cli.debug then Print.expr ~debug:false ()
(if options.Global.debug then Print.expr ~debug:false ()
else Print.UserFacing.value language)
result)
results
@ -722,11 +740,11 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.decl_ctx scope in
Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt
Print.scope ~debug:options.Global.debug prg.decl_ctx fmt
(scope_uid, Program.get_scope_body prg scope_uid);
Format.pp_print_newline fmt ()
| None ->
Print.program ~debug:options.Cli.debug fmt prg;
Print.program ~debug:options.Global.debug fmt prg;
Format.pp_print_newline fmt ()
let lcalc_cmd =
@ -869,7 +887,7 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.ctx.decl_ctx scope in
Scalc.Print.format_item ~debug:options.Cli.debug prg.ctx.decl_ctx fmt
Scalc.Print.format_item ~debug:options.Global.debug prg.ctx.decl_ctx fmt
(List.find
(function
| Scalc.Ast.SScope { scope_body_name; _ } ->
@ -989,6 +1007,80 @@ module Commands = struct
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants)
let depends options includes prefix extension extra_files =
let file = Global.input_src_file options.Global.input_src in
let more_includes = List.map Filename.dirname (file :: extra_files) in
let prg =
Surface.Ast.
{
program_module_name = None;
program_items = [];
program_source_files = [];
program_used_modules =
List.map
(fun f ->
let name = modname_of_file f in
{
mod_use_name = name, Pos.no_pos;
mod_use_alias = name, Pos.no_pos;
})
(file :: extra_files);
program_lang = Cli.file_lang file;
}
in
let mod_uses, modules =
load_module_interfaces options includes ~more_includes
~allow_notmodules:true 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 = File.clean_path f in
if extension = [] then Format.pp_print_string ppf f
else
Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun ppf ext -> Format.pp_print_string ppf File.(f -.- ext))
ppf extension)
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 the given catala files, 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.\n\
NOTE: the files specified are also included in the returned list.")
Term.(
const depends
$ Cli.Flags.Global.options
$ Cli.Flags.include_dirs
$ Cli.Flags.prefix
$ Cli.Flags.extension
$ Cli.Flags.extra_files)
let pygmentize_cmd =
Cmd.v
(Cmd.info "pygmentize"
@ -1019,6 +1111,7 @@ module Commands = struct
lcalc_cmd;
scalc_cmd;
exceptions_cmd;
depends_cmd;
pygmentize_cmd;
]
end
@ -1066,7 +1159,7 @@ let main () =
Cmdliner.Cmd.eval_peek_opts ~argv Cli.Flags.Global.flags
~version_opt:true
with
| Some opts, _ -> opts.Cli.plugins_dirs
| Some opts, _ -> opts.Global.plugins_dirs
| None, _ -> []
in
Passes.debug_pass_name "init";
@ -1096,7 +1189,7 @@ let main () =
| exception Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit content Error;
if Cli.globals.debug then Printexc.print_raw_backtrace stderr bt;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
| exception Failure msg ->
let bt = Printexc.get_raw_backtrace () in

32
compiler/driver.mli
View File

@ -25,29 +25,29 @@ val main : unit -> unit
Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *)
module Passes : sig
val surface : Cli.options -> Surface.Ast.program
val surface : Global.options -> Surface.Ast.program
val desugared :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
Desugared.Ast.program * Desugared.Name_resolution.context
val scopelang :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
Shared_ast.untyped Scopelang.Ast.program
val dcalc :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
typed:'m Shared_ast.mark ->
'm Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list
val lcalc :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
typed:'m Shared_ast.mark ->
@ -57,8 +57,8 @@ module Passes : sig
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
val scalc :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
avoid_exceptions:bool ->
@ -75,15 +75,15 @@ module Commands : sig
val get_output :
?ext:string ->
Cli.options ->
Cli.raw_file option ->
Global.options ->
Global.raw_file option ->
string option * ((out_channel -> 'a) -> 'a)
(** bounded open of the expected output file *)
val get_output_format :
?ext:string ->
Cli.options ->
Cli.raw_file option ->
Global.options ->
Global.raw_file option ->
string option * ((Format.formatter -> 'a) -> 'a)
val get_scope_uid : Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
@ -110,6 +110,6 @@ module Plugin : sig
string ->
?man:Cmdliner.Manpage.block list ->
?doc:string ->
(Cli.options -> unit) Cmdliner.Term.t ->
(Global.options -> unit) Cmdliner.Term.t ->
unit
end

204
compiler/lcalc/to_ocaml.ml
View File

@ -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
@ -373,11 +392,11 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
args = [arg];
_;
}
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
format_with_parens f format_with_parens arg
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1]; _ }
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt
"(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)"
format_uid_list info
@ -389,7 +408,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(var_def_info.log_typ, Pos.no_pos)
format_with_parens arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ }
when Cli.globals.trace ->
when Global.options.trace ->
let pos = Expr.pos e in
Format.fprintf fmt
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
@ -397,8 +416,8 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) format_with_parens arg1
| EAppOp { op = Log (EndCall, info); args = [arg1]; _ } when Cli.globals.trace
->
| EAppOp { op = Log (EndCall, info); args = [arg1]; _ }
when Global.options.trace ->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
format_with_parens arg1
| EAppOp { op = Log _; args = [arg1]; _ } ->
@ -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)
@ -518,7 +540,7 @@ let format_ctx
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
(None, struct_field) format_typ struct_field_type))
(StructField.Map.bindings struct_fields);
if Cli.globals.trace then
if Global.options.trace then
format_struct_embedding fmt (struct_name, struct_fields)
in
let format_enum_decl fmt (enum_name, enum_cons) =
@ -531,7 +553,7 @@ let format_ctx
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
enum_cons format_typ enum_cons_type))
(EnumConstructor.Map.bindings enum_cons);
if Cli.globals.trace then format_enum_embedding fmt (enum_name, enum_cons)
if Global.options.trace then format_enum_embedding fmt (enum_name, enum_cons)
in
let is_in_type_ordering s =
List.exists
@ -705,6 +727,13 @@ let commands = if commands = [] then entry_scopes else commands
name format_var var name)
scopes_with_no_input
let reexport_used_modules fmt modules =
List.iter
(fun m ->
Format.fprintf fmt "@[<hv 2>module %a@ = %a@]@," ModuleName.format m
ModuleName.format m)
modules
let format_module_registration
fmt
(bnd : ('m Ast.expr Var.t * _) String.Map.t)
@ -750,17 +779,22 @@ let format_program
?(exec_args = true)
(p : 'm Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
Format.pp_open_vbox fmt 0;
Format.pp_print_string fmt header;
reexport_used_modules fmt (Program.modules_to_list p.decl_ctx.ctx_modules);
format_ctx type_ordering fmt p.decl_ctx;
let bnd = format_code_items p.decl_ctx fmt p.code_items in
Format.pp_print_newline fmt ();
match p.module_name, exec_scope with
| Some modname, None -> format_module_registration fmt bnd modname
| None, Some scope_name ->
let scope_body = Program.get_scope_body p scope_name in
format_scope_exec p.decl_ctx fmt bnd scope_name scope_body
| None, None -> if exec_args then format_scope_exec_args p.decl_ctx fmt bnd
| Some _, Some _ ->
Message.raise_error
"OCaml generation: both module registration and top-level scope \
execution where required at the same time."
Format.pp_print_cut fmt ();
let () =
match p.module_name, exec_scope with
| Some modname, None -> format_module_registration fmt bnd modname
| None, Some scope_name ->
let scope_body = Program.get_scope_body p scope_name in
format_scope_exec p.decl_ctx fmt bnd scope_name scope_body
| None, None -> if exec_args then format_scope_exec_args p.decl_ctx fmt bnd
| Some _, Some _ ->
Message.raise_error
"OCaml generation: both module registration and top-level scope \
execution where required at the same time."
in
Format.pp_close_box fmt ()

6
compiler/literate/html.ml
View File

@ -23,7 +23,7 @@ open Literate_common
module A = Surface.Ast
module P = Printf
module R = Re.Pcre
module C = Cli
module C = Global
(** {1 Helpers} *)
@ -47,7 +47,7 @@ let remove_cb_last_lines : string -> string =
Prints an HTML complete page structure around the [wrapped] content. *)
let wrap_html
(source_files : string list)
(language : Cli.backend_lang)
(language : Global.backend_lang)
(fmt : Format.formatter)
(wrapped : Format.formatter -> unit) : unit =
let css_as_string =
@ -140,7 +140,7 @@ let rec law_structure_to_html
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<div class='law-text'>%s</div>" t
| A.CodeBlock (_, c, metadata) when not print_only_law ->
let start_line = Pos.get_start_line (Mark.get c) - 1 in
let start_line = Pos.get_start_line (Mark.get c) + 1 in
let filename = Pos.get_file (Mark.get c) in
let block_content = Mark.remove c in
check_exceeding_lines start_line filename block_content;

4
compiler/literate/html.mli
View File

@ -23,7 +23,7 @@ open Catala_utils
val wrap_html :
string list ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
(Format.formatter -> unit) ->
unit
@ -34,7 +34,7 @@ val wrap_html :
(** {1 API} *)
val ast_to_html :
Cli.backend_lang ->
Global.backend_lang ->
print_only_law:bool ->
Format.formatter ->
Surface.Ast.program ->

6
compiler/literate/latex.ml
View File

@ -21,7 +21,7 @@
open Catala_utils
open Literate_common
module A = Surface.Ast
module C = Cli
module C = Global
(** {1 Helpers} *)
@ -34,7 +34,7 @@ let update_lines_of_code c =
- Pos.get_start_line (Mark.get c)
- 1
(** Espaces various LaTeX-sensitive characters *)
(** Escapes various LaTeX-sensitive characters *)
let pre_latexify (s : string) : string =
(* Then we send to pandoc, to ensure the markdown features used in the
original document are correctly printed! *)
@ -296,7 +296,7 @@ let rec law_structure_to_latex
(pre_latexify (Mark.remove al)))
| A.LawText t -> Format.fprintf fmt "%s" (pre_latexify t)
| A.CodeBlock (_, c, false) when not print_only_law ->
let start_line = Pos.get_start_line (Mark.get c) - 1 in
let start_line = Pos.get_start_line (Mark.get c) + 1 in
let filename = Pos.get_file (Mark.get c) in
let block_content = Mark.remove c in
check_exceeding_lines start_line filename block_content;

4
compiler/literate/latex.mli
View File

@ -23,7 +23,7 @@ open Catala_utils
val wrap_latex :
string list ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
(Format.formatter -> unit) ->
unit
@ -34,7 +34,7 @@ val wrap_latex :
(** {1 API} *)
val ast_to_latex :
Cli.backend_lang ->
Global.backend_lang ->
print_only_law:bool ->
Format.formatter ->
Surface.Ast.program ->

13
compiler/literate/literate_common.ml
View File

@ -15,7 +15,7 @@
the License. *)
open Catala_utils
open Cli
open Global
let literal_title = function
| En -> "Legislative text implementation"
@ -113,13 +113,10 @@ let check_exceeding_lines
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
in
if len_s > max_len then
Message.emit_warning
"@[<v>The line @{<bold;yellow>%d@} in @{<bold;magenta>%s@} is \
exceeding @{<bold;red}%d@} characters:@,\
%s@{<red>%s@}@]"
(start_line + i + 1)
filename max_len (String.sub s 0 max_len)
(String.sub s max_len (len_s - max_len)))
Message.emit_spanned_warning
(Pos.from_info filename (start_line + i) (max_len + 1)
(start_line + i) (len_s + 1))
"This line is exceeding @{<bold;red>%d@} characters" max_len)
let with_pygmentize_lexer lang f =
let lexer_py =

28
compiler/literate/literate_common.mli
View File

@ -16,30 +16,30 @@
open Catala_utils
val literal_title : Cli.backend_lang -> string
val literal_title : Global.backend_lang -> string
(** Return the title traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_generated_by : Cli.backend_lang -> string
val literal_generated_by : Global.backend_lang -> string
(** Return the 'generated by' traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_source_files : Cli.backend_lang -> string
val literal_source_files : Global.backend_lang -> string
(** Return the 'source files weaved' traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_disclaimer_and_link : Cli.backend_lang -> string
val literal_disclaimer_and_link : Global.backend_lang -> string
(** Return the traduction of a paragraph giving a basic disclaimer about Catala
and a link to the website according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_last_modification : Cli.backend_lang -> string
val literal_last_modification : Global.backend_lang -> string
(** Return the 'last modification' traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val get_language_extension : Cli.backend_lang -> string
val get_language_extension : Global.backend_lang -> string
(** Return the file extension corresponding to the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val run_pandoc : string -> [ `Html | `Latex ] -> string
(** Runs the [pandoc] on a string to pretty-print markdown features into the
@ -49,11 +49,11 @@ val check_exceeding_lines : ?max_len:int -> int -> string -> string -> unit
(** [check_exceeding_lines ~max_len start_line filename content] prints a
warning message for each lines of [content] exceeding [max_len] characters. *)
val call_pygmentize : ?lang:Cli.backend_lang -> string list -> string
val call_pygmentize : ?lang:Global.backend_lang -> string list -> string
(** Calls the [pygmentize] command with the given arguments, and returns the
results as a string. If [lang] is specified, the proper arguments for the
Catala lexer are already passed. *)
val with_pygmentize_lexer : Cli.backend_lang -> (string list -> 'a) -> 'a
val with_pygmentize_lexer : Global.backend_lang -> (string list -> 'a) -> 'a
(** Creates the required lexer file and returns the corresponding [pygmentize]
command-line arguments *)

6
compiler/literate/pygmentize.ml
View File

@ -20,9 +20,9 @@ open Literate_common
let lang_of_ext s =
if String.starts_with ~prefix:"catala_" s then
match s with
| "catala_en" -> Some Cli.En
| "catala_fr" -> Some Cli.Fr
| "catala_pl" -> Some Cli.Pl
| "catala_en" -> Some Global.En
| "catala_fr" -> Some Global.Fr
| "catala_pl" -> Some Global.Pl
| _ -> failwith "Unknown Catala dialect"
else None

2
compiler/plugin.mli
View File

@ -21,7 +21,7 @@ type t = unit Cmdliner.Cmd.t
val register :
Cmdliner.Cmd.info ->
(Catala_utils.Cli.options -> unit) Cmdliner.Term.t ->
(Catala_utils.Global.options -> unit) Cmdliner.Term.t ->
unit
(** Plugins are registerd as [Cmdliner] commands, which must take at least the
default global options as arguments (this is required for e.g.

246
compiler/plugins/api_web.ml
View File

@ -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
@ -396,7 +433,7 @@ module To_jsoo = struct
Format.fprintf fmt "%sLib"
(Option.fold ~none:""
~some:(fun name ->
List.nth (String.split_on_char ' ' name) 1
name
|> String.split_on_char '_'
|> List.map String.capitalize_ascii
|> String.concat "")
@ -421,7 +458,7 @@ module To_jsoo = struct
@[<v 2>let () =@ @[<hov 2> Js.export \"%a\"@\n\
@[<v 2>(object%%js@ %a@]@\n\
end)@]@]@?"
(Option.fold ~none:"" ~some:(fun name -> name) module_name)
(Option.fold ~none:"" ~some:(fun name -> "open " ^ name) module_name)
(format_ctx type_ordering) prgm.decl_ctx
(format_scopes_to_fun prgm.decl_ctx)
prgm.code_items fmt_lib_name ()
@ -437,41 +474,30 @@ 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 = Global.enforce_options ~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
with_formatter (fun fmt ->
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)
prg type_ordering)
let modname =
match prg.module_name with
| Some m -> ModuleName.to_string m
| None ->
String.capitalize_ascii
Filename.(
basename
(remove_extension
(Global.input_src_file options.Global.input_src)))
in
To_jsoo.format_program fmt (Some modname) prg type_ordering)
let term =
let open Cmdliner.Term in

14
compiler/plugins/explain.ml
View File

@ -23,7 +23,7 @@ type flags = {
merge_level : int;
format : [ `Dot | `Convert of string ];
show : string option;
output : Cli.raw_file option;
output : Global.raw_file option;
base_src_url : string;
}
@ -264,7 +264,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
e
in
let e =
Interpreter.evaluate_operator eval op m Cli.En
Interpreter.evaluate_operator eval op m Global.En
(* Default language to English but this should not raise any error
messages so we don't care. *)
args
@ -989,7 +989,7 @@ let rec graph_cleanup options g base_vars =
let expr_to_dot_label0 :
type a.
Cli.backend_lang ->
Global.backend_lang ->
decl_ctx ->
Env.t ->
Format.formatter ->
@ -997,7 +997,7 @@ let expr_to_dot_label0 :
unit =
fun lang ctx env ->
let xlang ~en ?(pl = en) ~fr () =
match lang with Cli.Fr -> fr | Cli.En -> en | Cli.Pl -> pl
match lang with Global.Fr -> fr | Global.En -> en | Global.Pl -> pl
in
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
fun ppf e -> Print.UserFacing.value ~fallback lang ppf e
@ -1369,7 +1369,9 @@ let run includes optimize ex_scope explain_options global_options =
graph_cleanup explain_options g base_vars
else g
in
let lang = Cli.file_lang (Cli.input_src_file global_options.Cli.input_src) in
let lang =
Cli.file_lang (Global.input_src_file global_options.Global.input_src)
in
let dot_content =
to_dot lang Format.str_formatter prg.decl_ctx env base_vars g
~base_src_url:explain_options.base_src_url;
@ -1386,7 +1388,7 @@ let run includes optimize ex_scope explain_options global_options =
fun f ->
f
(Option.value ~default:"-"
(Option.map Cli.globals.path_rewrite output))
(Option.map Global.options.path_rewrite output))
in
with_dot_file
@@ fun dotfile ->

2
compiler/plugins/lazy_interp.ml
View File

@ -112,7 +112,7 @@ let rec lazy_eval :
renv := env;
e
in
( Interpreter.evaluate_operator eval op m Cli.En
( Interpreter.evaluate_operator eval op m Global.En
(* Default language to English but this should not raise any error
messages so we don't care. *)
args,

8
compiler/scalc/from_lcalc.ml
View File

@ -644,7 +644,13 @@ let translate_program ~(config : translation_config) (p : 'm L.program) :
let modules =
List.fold_left
(fun acc m ->
ModuleName.Map.add m (A.VarName.fresh (ModuleName.get_info m)) acc)
let vname = Mark.map (( ^ ) "Module_") (ModuleName.get_info m) in
(* The "Module_" prefix is a workaround name clashes for same-name
structs and modules, Python in particular mixes everything in one
namespaces. It can be removed once we have full clash-free variable
renaming in the Python backend (requiring all idents to go through
one stage of being bindlib vars) *)
ModuleName.Map.add m (A.VarName.fresh vname) acc)
ModuleName.Map.empty
(Program.modules_to_list p.decl_ctx.ctx_modules)
in

16
compiler/scalc/to_python.ml
View File

@ -136,12 +136,10 @@ end)
let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
s
|> String.to_ascii
|> String.to_snake_case
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_")
|> String.to_ascii
|> avoid_keywords
|> Format.fprintf fmt "%s"
|> Format.pp_print_string fmt
(** For each `VarName.t` defined by its string and then by its hash, we keep
track of which local integer id we've given it. This is used to keep
@ -321,11 +319,11 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(op, Pos.no_pos) (format_expression ctx) arg2
| EApp
{ f = EAppOp { op = Log (BeginCall, info); args = [f] }, _; args = [arg] }
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
(format_expression ctx) f (format_expression ctx) arg
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1] }
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt
"log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \
output_io=%s),@ %a)"
@ -337,7 +335,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(if var_def_info.log_io_output then "True" else "False")
(format_expression ctx) arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] }
when Cli.globals.trace ->
when Global.options.trace ->
let pos = Mark.get e in
Format.fprintf fmt
"log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ \
@ -345,7 +343,8 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos) (format_expression ctx) arg1
| EAppOp { op = Log (EndCall, info); args = [arg1] } when Cli.globals.trace ->
| EAppOp { op = Log (EndCall, info); args = [arg1] } when Global.options.trace
->
Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1
| EAppOp { op = Log _; args = [arg1] } ->
@ -666,7 +665,8 @@ let format_program
Format.pp_print_list Format.pp_print_string fmt header;
ModuleName.Map.iter
(fun m v ->
Format.fprintf fmt "import %a as %a@," ModuleName.format m format_var v)
Format.fprintf fmt "from . import %a as %a@," ModuleName.format m
format_var v)
p.ctx.modules;
Format.pp_print_cut fmt ();
format_ctx type_ordering fmt p.ctx;

2
compiler/scopelang/ast.ml
View File

@ -62,7 +62,7 @@ type 'm program = {
program_modules : nil scope_decl Mark.pos ScopeName.Map.t ModuleName.Map.t;
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
let type_rule decl_ctx env = function

2
compiler/scopelang/ast.mli
View File

@ -58,7 +58,7 @@ type 'm program = {
the scope signatures needed to respect the call convention *)
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
val type_program : 'm program -> typed program

2
compiler/scopelang/from_desugared.ml
View File

@ -37,7 +37,7 @@ let tag_with_log_entry
(e : untyped Ast.expr boxed)
(l : log_entry)
(markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
if Cli.globals.trace then
if Global.options.trace then
Expr.eappop
~op:(Log (l, markings))
~tys:[TAny, Expr.pos e]

2
compiler/shared_ast/definitions.ml
View File

@ -699,6 +699,6 @@ type decl_ctx = {
type 'e program = {
decl_ctx : decl_ctx;
code_items : 'e code_item_list;
lang : Cli.backend_lang;
lang : Global.backend_lang;
module_name : ModuleName.t option;
}

8
compiler/shared_ast/interpreter.ml
View File

@ -35,13 +35,13 @@ let indent_str = ref ""
(** {1 Evaluation} *)
let print_log lang entry infos pos e =
if Cli.globals.trace then
if Global.options.trace then
match entry with
| VarDef _ ->
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
entry Print.uid_list infos
(Message.unformat (fun ppf ->
(if Cli.globals.debug then Print.expr ~debug:true ()
(if Global.options.debug then Print.expr ~debug:true ()
else Print.UserFacing.expr lang)
ppf e))
| PosRecordIfTrueBool -> (
@ -609,7 +609,7 @@ and val_to_runtime :
let rec evaluate_expr :
type d e.
decl_ctx ->
Cli.backend_lang ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
@ -817,7 +817,7 @@ let rec evaluate_expr :
and partially_evaluate_expr_for_assertion_failure_message :
type d e.
decl_ctx ->
Cli.backend_lang ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->

4
compiler/shared_ast/interpreter.mli
View File

@ -26,7 +26,7 @@ val evaluate_operator :
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator ->
'm mark ->
Cli.backend_lang ->
Global.backend_lang ->
('a, 'm) gexpr list ->
('a, 'm) gexpr
(** Evaluates the result of applying the given operator to the given arguments,
@ -36,7 +36,7 @@ val evaluate_operator :
val evaluate_expr :
decl_ctx ->
Cli.backend_lang ->
Global.backend_lang ->
(('a, 'b, _) interpr_kind, 'm) gexpr ->
(('a, 'b, yes) interpr_kind, 'm) gexpr
(** Evaluates an expression according to the semantics of the default calculus. *)

2
compiler/shared_ast/optimizations.ml
View File

@ -184,7 +184,7 @@ let rec optimize_expr :
feed the expression to the interpreter that will print the beautiful
right error message *)
let (_ : _ gexpr) =
Interpreter.evaluate_expr ctx.decl_ctx Cli.En
Interpreter.evaluate_expr ctx.decl_ctx Global.En
(* Default language to English, no errors should be raised normally
so we don't care *)
e

38
compiler/shared_ast/print.ml
View File

@ -180,7 +180,8 @@ let lit (fmt : Format.formatter) (l : lit) : unit =
| LUnit -> lit_style fmt "()"
| LRat i ->
lit_style fmt
(Runtime.decimal_to_string ~max_prec_digits:Cli.globals.max_prec_digits i)
(Runtime.decimal_to_string ~max_prec_digits:Global.options.max_prec_digits
i)
| LMoney e ->
lit_style fmt (Format.asprintf "¤%s" (Runtime.money_to_string e))
| LDate d -> lit_style fmt (Runtime.date_to_string d)
@ -771,7 +772,7 @@ end
module ExprDebug = ExprGen (ExprDebugParam)
let expr ?(debug = Cli.globals.debug) () ppf e =
let expr ?(debug = Global.options.debug) () ppf e =
if debug then ExprDebug.expr ppf e else ExprConcise.expr ppf e
let scope_let_kind ?debug:(_debug = true) _ctx fmt k =
@ -958,15 +959,16 @@ module UserFacing = struct
(* Refs:
https://en.wikipedia.org/wiki/Wikipedia:Manual_of_Style/Dates_and_numbers#Grouping_of_digits
https://fr.wikipedia.org/wiki/Wikip%C3%A9dia:Conventions_concernant_les_nombres#Pour_un_comptage_ou_une_mesure *)
let bigsep (lang : Cli.backend_lang) =
let bigsep (lang : Global.backend_lang) =
match lang with En -> ",", 3 | Fr -> " ", 3 | Pl -> ",", 3
let decsep (lang : Cli.backend_lang) =
let decsep (lang : Global.backend_lang) =
match lang with En -> "." | Fr -> "," | Pl -> "."
let unit (_lang : Cli.backend_lang) ppf () = Format.pp_print_string ppf "()"
let unit (_lang : Global.backend_lang) ppf () =
Format.pp_print_string ppf "()"
let bool (lang : Cli.backend_lang) ppf b =
let bool (lang : Global.backend_lang) ppf b =
let s =
match lang, b with
| En, true -> "true"
@ -978,7 +980,7 @@ module UserFacing = struct
in
Format.pp_print_string ppf s
let integer (lang : Cli.backend_lang) ppf n =
let integer (lang : Global.backend_lang) ppf n =
let sep, nsep = bigsep lang in
let nsep = Z.pow (Z.of_int 10) nsep in
if Z.sign n < 0 then Format.pp_print_char ppf '-';
@ -991,7 +993,7 @@ module UserFacing = struct
in
aux (Z.abs n)
let money (lang : Cli.backend_lang) ppf n =
let money (lang : Global.backend_lang) ppf n =
let num = Z.abs n in
let units, cents = Z.div_rem num (Z.of_int 100) in
if Z.sign n < 0 then Format.pp_print_char ppf '-';
@ -1004,7 +1006,7 @@ module UserFacing = struct
| Fr -> Format.pp_print_string ppf " €"
| Pl -> Format.pp_print_string ppf " PLN"
let decimal (lang : Cli.backend_lang) ppf r =
let decimal (lang : Global.backend_lang) ppf r =
let den = Q.den r in
let num = Z.abs (Q.num r) in
let int_part, rem = Z.div_rem num den in
@ -1021,7 +1023,7 @@ module UserFacing = struct
| None ->
if Z.equal n Z.zero then None, false
else
let r = Cli.globals.max_prec_digits in
let r = Global.options.max_prec_digits in
Some (r - 1), r <= 1
| Some r -> Some (r - 1), r <= 1
in
@ -1037,19 +1039,19 @@ module UserFacing = struct
in
aux 0
(if Z.equal int_part Z.zero then None
else Some (Cli.globals.max_prec_digits - ndigits int_part))
else Some (Global.options.max_prec_digits - ndigits int_part))
rem
(* It would be nice to print ratios as % but that's impossible to guess.
Trying would lead to inconsistencies where some comparable numbers are in %
and some others not, adding confusion. *)
let date (lang : Cli.backend_lang) ppf d =
let date (lang : Global.backend_lang) ppf d =
let y, m, d = Dates_calc.Dates.date_to_ymd d in
match lang with
| En | Pl -> Format.fprintf ppf "%04d-%02d-%02d" y m d
| Fr -> Format.fprintf ppf "%02d/%02d/%04d" d m y
let duration (lang : Cli.backend_lang) ppf dr =
let duration (lang : Global.backend_lang) ppf dr =
let y, m, d = Dates_calc.Dates.period_to_ymds dr in
let rec filter0 = function
| (0, _) :: (_ :: _ as r) -> filter0 r
@ -1069,7 +1071,7 @@ module UserFacing = struct
ppf;
Format.pp_print_char ppf ']'
let lit_raw (lang : Cli.backend_lang) ppf lit : unit =
let lit_raw (lang : Global.backend_lang) ppf lit : unit =
match lit with
| LUnit -> unit lang ppf ()
| LBool b -> bool lang ppf b
@ -1079,20 +1081,20 @@ module UserFacing = struct
| LDate d -> date lang ppf d
| LDuration dr -> duration lang ppf dr
let lit_to_string (lang : Cli.backend_lang) lit =
let lit_to_string (lang : Global.backend_lang) lit =
let buf = Buffer.create 32 in
let ppf = Format.formatter_of_buffer buf in
lit_raw lang ppf lit;
Format.pp_print_flush ppf ();
Buffer.contents buf
let lit (lang : Cli.backend_lang) ppf lit : unit =
let lit (lang : Global.backend_lang) ppf lit : unit =
with_color (lit_raw lang) Ocolor_types.yellow ppf lit
let rec value :
type a.
?fallback:(Format.formatter -> (a, 't) gexpr -> unit) ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
(a, 't) gexpr ->
unit =
@ -1132,7 +1134,7 @@ module UserFacing = struct
fallback ppf e
let expr :
type a. Cli.backend_lang -> Format.formatter -> (a, 't) gexpr -> unit =
type a. Global.backend_lang -> Format.formatter -> (a, 't) gexpr -> unit =
fun lang ->
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
fun ppf e -> value ~fallback lang ppf e

27
compiler/shared_ast/print.mli
View File

@ -96,22 +96,27 @@ val program : ?debug:bool -> Format.formatter -> ('a, 'm) gexpr program -> unit
(** User-facing, localised printer *)
module UserFacing : sig
val unit : Cli.backend_lang -> Format.formatter -> Runtime.unit -> unit
val bool : Cli.backend_lang -> Format.formatter -> Runtime.bool -> unit
val integer : Cli.backend_lang -> Format.formatter -> Runtime.integer -> unit
val decimal : Cli.backend_lang -> Format.formatter -> Runtime.decimal -> unit
val money : Cli.backend_lang -> Format.formatter -> Runtime.money -> unit
val date : Cli.backend_lang -> Format.formatter -> Runtime.date -> unit
val unit : Global.backend_lang -> Format.formatter -> Runtime.unit -> unit
val bool : Global.backend_lang -> Format.formatter -> Runtime.bool -> unit
val integer :
Global.backend_lang -> Format.formatter -> Runtime.integer -> unit
val decimal :
Global.backend_lang -> Format.formatter -> Runtime.decimal -> unit
val money : Global.backend_lang -> Format.formatter -> Runtime.money -> unit
val date : Global.backend_lang -> Format.formatter -> Runtime.date -> unit
val duration :
Cli.backend_lang -> Format.formatter -> Runtime.duration -> unit
Global.backend_lang -> Format.formatter -> Runtime.duration -> unit
val lit : Cli.backend_lang -> Format.formatter -> lit -> unit
val lit_to_string : Cli.backend_lang -> lit -> string
val lit : Global.backend_lang -> Format.formatter -> lit -> unit
val lit_to_string : Global.backend_lang -> lit -> string
val value :
?fallback:(Format.formatter -> ('a, 't) gexpr -> unit) ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
('a, 't) gexpr ->
unit
@ -121,7 +126,7 @@ module UserFacing : sig
is called upon non-value expressions (by default, [Invalid_argument] is
raised) *)
val expr : Cli.backend_lang -> Format.formatter -> (_, _) gexpr -> unit
val expr : Global.backend_lang -> Format.formatter -> (_, _) gexpr -> unit
(** This combines the user-facing value printer and the generic expression
printer to handle all AST nodes *)
end

10
compiler/shared_ast/typing.ml
View File

@ -159,14 +159,14 @@ let rec format_typ
")" (format_typ ~colors) t2
| TArray t1 -> (
match Mark.remove (UnionFind.get (UnionFind.find t1)) with
| TAny _ when not Cli.globals.debug -> Format.pp_print_string fmt "list"
| TAny _ when not Global.options.debug -> Format.pp_print_string fmt "list"
| _ -> Format.fprintf fmt "@[list of@ %a@]" (format_typ ~colors) t1)
| TDefault t1 ->
Format.pp_print_as fmt 1 "⟨";
format_typ ~colors fmt t1;
Format.pp_print_as fmt 1 "⟩"
| TAny v ->
if Cli.globals.debug then Format.fprintf fmt "<a%d>" (Any.hash v)
if Global.options.debug then Format.fprintf fmt "<a%d>" (Any.hash v)
else Format.pp_print_string fmt "<any>"
| TClosureEnv -> Format.fprintf fmt "closure_env"
@ -234,7 +234,8 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
( (fun ppf ->
Format.fprintf ppf "@[<hv 2>@[<hov>%a@ %a@]:" Format.pp_print_text
"This expression has type" (format_typ ctx) t1;
if Cli.globals.debug then Format.fprintf ppf "@ %a@]" Expr.format e
if Global.options.debug then
Format.fprintf ppf "@ %a@]" Expr.format e
else Format.pp_close_box ppf ()),
e_pos );
( (fun ppf ->
@ -248,7 +249,8 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
( (fun ppf ->
Format.fprintf ppf "@[<hv 2>@[<hov>%a:@]" Format.pp_print_text
"While typechecking the following expression";
if Cli.globals.debug then Format.fprintf ppf "@ %a@]" Expr.format e
if Global.options.debug then
Format.fprintf ppf "@ %a@]" Expr.format e
else Format.pp_close_box ppf ()),
e_pos );
( (fun ppf ->

2
compiler/surface/ast.ml
View File

@ -333,7 +333,7 @@ and program = {
program_items : law_structure list;
program_source_files : (string[@opaque]) list;
program_used_modules : module_use list;
program_lang : Cli.backend_lang; [@opaque]
program_lang : Global.backend_lang; [@opaque]
}
and source_file = law_structure list

27
compiler/surface/parser_driver.ml
View File

@ -198,14 +198,15 @@ module Parser_En = ParserAux (Lexer_en)
module Parser_Fr = ParserAux (Lexer_fr)
module Parser_Pl = ParserAux (Lexer_pl)
let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function
let localised_parser : Global.backend_lang -> lexbuf -> Ast.source_file =
function
| En -> Parser_En.commands_or_includes
| Fr -> Parser_Fr.commands_or_includes
| Pl -> Parser_Pl.commands_or_includes
(** Lightweight lexer for dependency *)
let lines (file : File.t) (language : Cli.backend_lang) =
let lines (file : File.t) (language : Global.backend_lang) =
let lex_line =
match language with
| En -> Lexer_en.lex_line
@ -387,12 +388,12 @@ let get_interface program =
let with_sedlex_source source_file f =
match source_file with
| Cli.FileName file -> with_sedlex_file file f
| Cli.Contents (str, file) ->
| Global.FileName file -> with_sedlex_file file f
| Global.Contents (str, file) ->
let lexbuf = Sedlexing.Utf8.from_string str in
Sedlexing.set_filename lexbuf file;
f lexbuf
| Cli.Stdin file ->
| Global.Stdin file ->
let lexbuf = Sedlexing.Utf8.from_channel stdin in
Sedlexing.set_filename lexbuf file;
f lexbuf
@ -400,7 +401,7 @@ let with_sedlex_source source_file f =
let check_modname program source_file =
match program.Ast.program_module_name, source_file with
| ( Some (mname, pos),
(Cli.FileName file | Cli.Contents (_, file) | Cli.Stdin file) )
(Global.FileName file | Global.Contents (_, file) | Global.Stdin file) )
when not File.(equal mname Filename.(remove_extension (basename file))) ->
Message.raise_spanned_error pos
"@[<hov>Module declared as@ @{<blue>%s@},@ which@ does@ not@ match@ the@ \
@ -412,18 +413,20 @@ let check_modname program source_file =
File.((dirname file / mname) ^ Filename.extension file)
| _ -> ()
let load_interface source_file =
let load_interface ?default_module_name source_file =
let program = with_sedlex_source source_file parse_source in
check_modname program source_file;
let modname =
match program.Ast.program_module_name with
| Some mname -> mname
| None ->
match program.Ast.program_module_name, default_module_name with
| Some mname, _ -> mname
| None, Some n ->
n, Pos.from_info (Global.input_src_file source_file) 0 0 0 0
| None, None ->
Message.raise_error
"%a doesn't define a module name. It should contain a '@{<cyan>> \
Module %s@}' directive."
File.format
(Cli.input_src_file source_file)
(Global.input_src_file source_file)
(match source_file with
| FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s))
@ -436,7 +439,7 @@ let load_interface source_file =
Ast.intf_submodules = used_modules;
}
let parse_top_level_file (source_file : Cli.input_src) : Ast.program =
let parse_top_level_file (source_file : File.t Global.input_src) : Ast.program =
let program = with_sedlex_source source_file parse_source in
check_modname program source_file;
{

7
compiler/surface/parser_driver.mli
View File

@ -20,16 +20,17 @@
open Catala_utils
val lines :
File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq.t
File.t -> Global.backend_lang -> (string * Lexer_common.line_token) Seq.t
(** Raw file parser that doesn't interpret any includes and returns the flat law
structure as is *)
val load_interface : Cli.input_src -> Ast.interface
val load_interface :
?default_module_name:string -> File.t Global.input_src -> Ast.interface
(** Reads only declarations in metadata in the supplied input file, and only
keeps type information. The list of submodules is initialised with names
only and empty contents. *)
val parse_top_level_file : Cli.input_src -> Ast.program
val parse_top_level_file : File.t Global.input_src -> Ast.program
(** Parses a catala file (handling file includes) and returns a program.
Interfaces of the used modules are returned empty, use [load_interface] to
fill them. *)

2
compiler/verification/z3backend.real.ml
View File

@ -139,7 +139,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
Catala sources *)
| TUnit -> ""
| TInt -> Expr.to_string e
| TRat -> Arithmetic.Real.to_decimal_string e Cli.globals.max_prec_digits
| TRat -> Arithmetic.Real.to_decimal_string e Global.options.max_prec_digits
(* TODO: Print the right money symbol according to language *)
| TMoney ->
let z3_str = Expr.to_string e in

10
runtimes/dune
View File

@ -1,7 +1,7 @@
(documentation
(package catala))
(dirs jsoo ocaml python r)
(dirs jsoo ocaml python r rescript)
; Installation is done as source under catala lib directory
; For dev version this makes it easy to install the proper runtime with just
@ -14,3 +14,11 @@
(glob_files_rec
(python/** with_prefix runtime_python)))
(section lib))
; Rescript runtime
(install
(files
(glob_files_rec
(rescript/** with_prefix runtime_rescript)))
(section lib))

35
runtimes/jsoo/runtime.ml
View File

@ -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,27 +64,21 @@ 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
method retrieveEvents :
(unit, event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
method retrieveRawEvents :
(unit, raw_event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
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
method resetLog = Js.wrap_meth_callback R_ocaml.reset_log
object%js (_self)
method resetLog = R_ocaml.reset_log ()
method retrieveEvents =
Js.wrap_meth_callback
@@ fun () ->
R_ocaml.retrieve_log ()
|> R_ocaml.EventParser.parse_raw_events
|> List.map (fun event ->
@ -150,8 +143,6 @@ let event_manager : event_manager Js.t =
| _ -> Js.undefined
end
in
Js.wrap_meth_callback
@@ fun () ->
R_ocaml.retrieve_log () |> List.map evt_to_js |> Array.of_list |> Js.array
end
@ -181,3 +172,9 @@ let execute_or_throw_error f =
"A conflict happened between two rules giving a value to the variable" pos
| R_ocaml.AssertionFailed pos ->
throw_error "A failure happened in the assertion" pos
let () =
Js.export_all
(object%js
val eventsManager = event_manager
end)

18
runtimes/jsoo/runtime.mli
View File

@ -77,13 +77,9 @@ class type event = object
end
class type event_manager = object
method resetLog : (unit, unit) Js.meth_callback Js.meth
method retrieveEvents :
(unit, event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
method retrieveRawEvents :
(unit, raw_event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
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
val event_manager : event_manager Js.t
@ -98,8 +94,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 +103,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} *)

7
runtimes/ocaml/runtime.ml
View File

@ -21,7 +21,12 @@ type money = Z.t
type integer = Z.t
type decimal = Q.t
type date = Dates_calc.Dates.date
type date_rounding = Dates_calc.Dates.date_rounding
type date_rounding = Dates_calc.Dates.date_rounding =
| RoundUp
| RoundDown
| AbortOnRound
type duration = Dates_calc.Dates.period
module Eoption = struct

6
runtimes/ocaml/runtime.mli
View File

@ -29,7 +29,11 @@ type integer = Z.t
type decimal = Q.t
type date = Dates_calc.Dates.date
type duration = Dates_calc.Dates.period
type date_rounding = Dates_calc.Dates.date_rounding
type date_rounding = Dates_calc.Dates.date_rounding =
| RoundUp
| RoundDown
| AbortOnRound
type source_position = {
filename : string;

6
runtimes/rescript/package.json
View File

@ -1,6 +1,6 @@
{
"name": "@catala-lang/rescript-catala",
"version": "0.8.1-b.0",
"version": "0.9.0",
"description": "ReScript wrapper for the Catala runtime",
"scripts": {
"clean": "rescript clean",
@ -8,11 +8,11 @@
"watch": "yarn run build -w"
},
"main": "index.js",
"repository": "git@github.com:CatalaLang/catala-explain.git",
"repository": "https://github.com/CatalaLang/catala",
"author": "Emile Rolley <emile.rolley@tuta.io>",
"license": "Apache-2.0",
"bugs": {
"url": "https://github.com/CatalaLang/catala-explain/issues"
"url": "https://github.com/CatalaLang/catala/issues"
},
"homepage": "https://github.com/CatalaLang/catala/tree/master/runtimes/rescript/README.md",
"keywords": [

2
tests/scope/good/191_fix_record_name_confusion.catala_en
View File

@ -25,6 +25,7 @@ $ catala Typecheck --check-invariants
```catala-test-inline
$ catala OCaml -O
Generating entry points for scopes: ScopeA ScopeB
(** This file has been generated by the Catala compiler, do not edit! *)
@ -60,7 +61,6 @@ let scope_b (scope_b_in: ScopeB_in.t) : ScopeB.t =
let a_: bool = scope_a_dot_a_ in
{ScopeB.a = a_}
Generating entry points for scopes: ScopeA ScopeB
let entry_scopes = [
"ScopeA";