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

Add support for backend plugins using dynlink

Browse Source
This commit is contained in:
Louis Gesbert 2022-03-04 18:32:03 +01:00
parent 5635eb0c6f
commit 9a95a3554c
15 changed files with 450 additions and 294 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
build_system/clerk_driver.ml
View File

@ -143,7 +143,7 @@ type expected_output_descr = {
base_filename : string; base_filename : string;
output_dir : string; output_dir : string;
complete_filename : string; complete_filename : string;
backend : Cli.backend_option; backend : string Cli.backend_option;
scope : string option; scope : string option;
} }
@ -156,18 +156,18 @@ let filename_to_expected_output_descr (output_dir : string) (filename : string)
let filename = Filename.remove_extension filename in let filename = Filename.remove_extension filename in
let backend = let backend =
match String.lowercase_ascii first_extension with match String.lowercase_ascii first_extension with
| ".dcalc" -> Some Cli.Dcalc | ".dcalc" -> Some `Dcalc
| ".d" -> Some Cli.Makefile | ".d" -> Some `Makefile
| ".html" -> Some Cli.Html | ".html" -> Some `Html
| ".interpret" -> Some Cli.Interpret | ".interpret" -> Some `Interpret
| ".lcalc" -> Some Cli.Lcalc | ".lcalc" -> Some `Lcalc
| ".ml" -> Some Cli.OCaml | ".ml" -> Some `OCaml
| ".proof" -> Some Cli.Proof | ".proof" -> Some `Proof
| ".py" -> Some Cli.Python | ".py" -> Some `Python
| ".scalc" -> Some Cli.Scalc | ".scalc" -> Some `Scalc
| ".scopelang" -> Some Cli.Scopelang | ".scopelang" -> Some `Scopelang
| ".tex" -> Some Cli.Latex | ".tex" -> Some `Latex
| ".typecheck" -> Some Cli.Typecheck | ".typecheck" -> Some `Typecheck
| _ -> None | _ -> None
in in
match backend with match backend with
@ -419,8 +419,7 @@ let collect_all_ninja_build
[ [
( "catala_cmd", ( "catala_cmd",
Nj.Expr.Lit Nj.Expr.Lit
(Cli.catala_backend_option_to_string expected_output.backend) (Cli.backend_option_to_string expected_output.backend) );
);
"tested_file", Nj.Expr.Lit tested_file; "tested_file", Nj.Expr.Lit tested_file;
( "expected_output", ( "expected_output",
Nj.Expr.Lit Nj.Expr.Lit
@ -429,7 +428,7 @@ let collect_all_ninja_build
] ]
and output_build_kind = if reset_test_outputs then "reset" else "test" and output_build_kind = if reset_test_outputs then "reset" else "test"
and catala_backend = and catala_backend =
Cli.catala_backend_option_to_string expected_output.backend Cli.backend_option_to_string expected_output.backend
in in
let get_rule_infos ?(rule_postfix = "") : let get_rule_infos ?(rule_postfix = "") :
@ -465,14 +464,14 @@ let collect_all_ninja_build
in in
match expected_output.backend with match expected_output.backend with
| Cli.Interpret | Cli.Proof | Cli.Typecheck | Cli.Dcalc | `Interpret | `Proof | `Typecheck | `Dcalc | `Scopelang | `Scalc
| Cli.Scopelang | Cli.Scalc | Cli.Lcalc -> | `Lcalc ->
let rule_output, rule_name, rule_vars = let rule_output, rule_name, rule_vars =
get_rule_infos expected_output.scope get_rule_infos expected_output.scope
in in
let rule_vars = let rule_vars =
match expected_output.backend with match expected_output.backend with
| Cli.Proof -> | `Proof ->
("extra_flags", Nj.Expr.Lit "--disable_counterexamples") ("extra_flags", Nj.Expr.Lit "--disable_counterexamples")
:: rule_vars :: rule_vars
(* Counterexamples can be different at each call because of the (* Counterexamples can be different at each call because of the
@ -483,7 +482,7 @@ let collect_all_ninja_build
in in
( ninja_add_new_rule rule_output rule_name rule_vars ninja, ( ninja_add_new_rule rule_output rule_name rule_vars ninja,
test_names ^ " $\n " ^ rule_output ) test_names ^ " $\n " ^ rule_output )
| Cli.Python | Cli.OCaml | Cli.Latex | Cli.Html | Cli.Makefile -> | `Python | `OCaml | `Latex | `Html | `Makefile | `Plugin _ ->
let tmp_file = Filename.temp_file "clerk_" ("_" ^ catala_backend) in let tmp_file = Filename.temp_file "clerk_" ("_" ^ catala_backend) in
let rule_output, rule_name, rule_vars = let rule_output, rule_name, rule_vars =
get_rule_infos ~rule_postfix:"_and_output" expected_output.scope get_rule_infos ~rule_postfix:"_and_output" expected_output.scope

1
compiler/catala_web_interpreter.ml
View File

@ -17,6 +17,7 @@ let _ =
wrap_weaved_output = false; wrap_weaved_output = false;
avoid_exceptions = false; avoid_exceptions = false;
backend = "Interpret"; backend = "Interpret";
plugins_dirs = [];
language = Some (Js.to_string language); language = Some (Js.to_string language);
max_prec_digits = None; max_prec_digits = None;
closure_conversion = false; closure_conversion = false;

401
compiler/driver.ml
View File

@ -31,6 +31,13 @@ let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
error. Usage: [driver source_file options]*) error. Usage: [driver source_file options]*)
let driver source_file (options : Cli.options) : int = let driver source_file (options : Cli.options) : int =
try try
List.iter
(fun d ->
match Sys.is_directory d with
| true -> Plugin.load_dir d
| false -> ()
| exception Sys_error _ -> ())
options.plugins_dirs;
Cli.set_option_globals options; Cli.set_option_globals options;
Cli.debug_print "Reading files..."; Cli.debug_print "Reading files...";
let filename = ref "" in let filename = ref "" in
@ -62,18 +69,20 @@ let driver source_file (options : Cli.options) : int =
Cli.locale_lang := language; Cli.locale_lang := language;
let backend = options.backend in let backend = options.backend in
let backend = let backend =
match Cli.catala_backend_option_of_string backend with match Cli.backend_option_of_string backend with
| Some b -> b | #Cli.backend_option_builtin as backend -> backend
| None -> | `Plugin s -> (
Errors.raise_error try `Plugin (Plugin.find s)
"The selected backend (%s) is not supported by Catala" backend with Not_found ->
Errors.raise_error
"The selected backend (%s) is not supported by Catala" backend)
in in
let prgm = let prgm =
Surface.Parser_driver.parse_top_level_file source_file language Surface.Parser_driver.parse_top_level_file source_file language
in in
let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in
match backend with (match backend with
| Cli.Makefile -> | `Makefile ->
let backend_extensions_list = [".tex"] in let backend_extensions_list = [".tex"] in
let source_file = let source_file =
match source_file with match source_file with
@ -88,7 +97,7 @@ let driver source_file (options : Cli.options) : int =
| None -> Filename.remove_extension source_file ^ ".d" | None -> Filename.remove_extension source_file ^ ".d"
in in
Cli.debug_print "Writing list of dependencies to %s..." output_file; Cli.debug_print "Writing list of dependencies to %s..." output_file;
let oc = open_out output_file in File.with_out_channel output_file @@ fun oc ->
Printf.fprintf oc "%s:\\\n%s\n%s:" Printf.fprintf oc "%s:\\\n%s\n%s:"
(String.concat "\\\n" (String.concat "\\\n"
(output_file (output_file
@ -96,9 +105,8 @@ let driver source_file (options : Cli.options) : int =
(fun ext -> Filename.remove_extension source_file ^ ext) (fun ext -> Filename.remove_extension source_file ^ ext)
backend_extensions_list)) backend_extensions_list))
(String.concat "\\\n" prgm.program_source_files) (String.concat "\\\n" prgm.program_source_files)
(String.concat "\\\n" prgm.program_source_files); (String.concat "\\\n" prgm.program_source_files)
0 | (`Latex | `Html) as backend ->
| Cli.Latex | Cli.Html ->
let source_file = let source_file =
match source_file with match source_file with
| FileName f -> f | FileName f -> f
@ -108,48 +116,37 @@ let driver source_file (options : Cli.options) : int =
a file" a file"
in in
Cli.debug_print "Weaving literate program into %s" Cli.debug_print "Weaving literate program into %s"
(match backend with (match backend with `Latex -> "LaTeX" | `Html -> "HTML");
| Cli.Latex -> "LaTeX"
| Cli.Html -> "HTML"
| _ -> assert false (* should not happen *));
let output_file = let output_file =
match options.output_file with match options.output_file with
| Some f -> f | Some f -> f
| None -> ( | None -> (
Filename.remove_extension source_file Filename.remove_extension source_file
^ ^ match backend with `Latex -> ".tex" | `Html -> ".html")
match backend with
| Cli.Latex -> ".tex"
| Cli.Html -> ".html"
| _ -> assert false
(* should not happen *))
in in
File.with_formatter_of_file output_file (fun fmt -> File.with_formatter_of_file output_file (fun fmt ->
let weave_output = let weave_output =
match backend with match backend with
| Cli.Latex -> Literate.Latex.ast_to_latex language | `Latex -> Literate.Latex.ast_to_latex language
| Cli.Html -> Literate.Html.ast_to_html language | `Html -> Literate.Html.ast_to_html language
| _ -> assert false
(* should not happen *)
in in
Cli.debug_print "Writing to %s" output_file; Cli.debug_print "Writing to %s" output_file;
if options.wrap_weaved_output then if options.wrap_weaved_output then
match backend with match backend with
| Cli.Latex -> | `Latex ->
Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files
language fmt (fun fmt -> weave_output fmt prgm) language fmt (fun fmt -> weave_output fmt prgm)
| Cli.Html -> | `Html ->
Literate.Html.wrap_html prgm.Surface.Ast.program_source_files Literate.Html.wrap_html prgm.Surface.Ast.program_source_files
language fmt (fun fmt -> weave_output fmt prgm) language fmt (fun fmt -> weave_output fmt prgm)
| _ -> assert false (* should not happen *) else weave_output fmt prgm)
else weave_output fmt prgm; | ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc | `Dcalc
0) | `Scopelang | `Proof | `Plugin _ ) as backend -> (
| _ -> (
Cli.debug_print "Name resolution..."; Cli.debug_print "Name resolution...";
let ctxt = Surface.Name_resolution.form_context prgm in let ctxt = Surface.Name_resolution.form_context prgm in
let scope_uid = let scope_uid =
match options.ex_scope, backend with match options.ex_scope, backend with
| None, Cli.Interpret -> | None, `Interpret ->
Errors.raise_error "No scope was provided for execution." Errors.raise_error "No scope was provided for execution."
| None, _ -> | None, _ ->
snd snd
@ -167,125 +164,128 @@ let driver source_file (options : Cli.options) : int =
let prgm = Surface.Desugaring.desugar_program ctxt prgm in let prgm = Surface.Desugaring.desugar_program ctxt prgm in
Cli.debug_print "Collecting rules..."; Cli.debug_print "Collecting rules...";
let prgm = Desugared.Desugared_to_scope.translate_program prgm in let prgm = Desugared.Desugared_to_scope.translate_program prgm in
if backend = Cli.Scopelang then
File.with_formatter_of_opt_file options.output_file (fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scopelang.Print.format_scope ~debug:options.debug)
( scope_uid,
Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes )
else
Format.fprintf fmt "%a\n"
(Scopelang.Print.format_program ~debug:options.debug)
prgm;
exit 0);
Cli.debug_print "Translating to default calculus...";
let prgm, type_ordering =
Scopelang.Scope_to_dcalc.translate_program prgm
in
let prgm =
if options.optimize then begin
Cli.debug_print "Optimizing default calculus...";
Dcalc.Optimizations.optimize_program prgm
end
else prgm
in
let prgrm_dcalc_expr =
Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid)
in
if backend = Cli.Dcalc then
File.with_formatter_of_opt_file options.output_file (fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
( scope_uid,
Option.get
(Dcalc.Ast.fold_left_scope_defs ~init:None
~f:(fun acc scope_def _ ->
if
Dcalc.Ast.ScopeName.compare scope_def.scope_name
scope_uid
= 0
then Some scope_def.scope_body
else acc)
prgm.scopes) )
else
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
prgrm_dcalc_expr;
exit 0);
Cli.debug_print "Typechecking...";
let _typ = Dcalc.Typing.infer_type prgm.decl_ctx prgrm_dcalc_expr in
(* Cli.debug_format "Typechecking results :@\n%a" (Dcalc.Print.format_typ
prgm.decl_ctx) typ; *)
match backend with match backend with
| Cli.Typecheck -> | `Scopelang ->
(* That's it! *) File.with_formatter_of_opt_file options.output_file @@ fun fmt ->
Cli.result_print "Typechecking successful!"; if Option.is_some options.ex_scope then
0 Format.fprintf fmt "%a\n"
| Cli.Proof -> (Scopelang.Print.format_scope ~debug:options.debug)
let vcs = ( scope_uid,
Verification.Conditions.generate_verification_conditions prgm Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes )
(match options.ex_scope with else
| None -> None Format.fprintf fmt "%a\n"
| Some _ -> Some scope_uid) (Scopelang.Print.format_program ~debug:options.debug)
in prgm
Verification.Solver.solve_vc prgm.decl_ctx vcs; | ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc | `Dcalc
0 | `Proof | `Plugin _ ) as backend -> (
| Cli.Interpret -> Cli.debug_print "Translating to default calculus...";
Cli.debug_print "Starting interpretation..."; let prgm, type_ordering =
let results = Scopelang.Scope_to_dcalc.translate_program prgm
Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr
in
let out_regex = Re.Pcre.regexp "\\_out$" in
let results =
List.map
(fun ((v1, v1_pos), e1) ->
let v1 =
Re.Pcre.substitute ~rex:out_regex ~subst:(fun _ -> "") v1
in
(v1, v1_pos), e1)
results
in
let results =
List.sort
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)
results
in
Cli.debug_print "End of interpretation";
Cli.result_print "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
List.iter
(fun ((var, _), result) ->
Cli.result_format "@[<hov 2>%s@ =@ %a@]" var
(Dcalc.Print.format_expr prgm.decl_ctx)
result)
results;
0
| Cli.OCaml | Cli.Python | Cli.Lcalc | Cli.Scalc ->
Cli.debug_print "Compiling program into lambda calculus...";
let prgm =
if options.avoid_exceptions then
Lcalc.Compile_without_exceptions.translate_program prgm
else Lcalc.Compile_with_exceptions.translate_program prgm
in in
let prgm = let prgm =
if options.optimize then begin if options.optimize then begin
Cli.debug_print "Optimizing lambda calculus..."; Cli.debug_print "Optimizing default calculus...";
Lcalc.Optimizations.optimize_program prgm Dcalc.Optimizations.optimize_program prgm
end end
else prgm else prgm
in in
let prgm = let prgrm_dcalc_expr =
if options.closure_conversion then ( Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid)
Cli.debug_print "Performing closure conversion...";
let prgm = Lcalc.Closure_conversion.closure_conversion prgm in
let prgm = Bindlib.unbox prgm in
prgm)
else prgm
in in
if backend = Cli.Lcalc then match backend with
File.with_formatter_of_opt_file options.output_file (fun fmt -> | `Dcalc ->
File.with_formatter_of_opt_file options.output_file @@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
( scope_uid,
Option.get
(Dcalc.Ast.fold_left_scope_defs ~init:None
~f:(fun acc scope_def _ ->
if
Dcalc.Ast.ScopeName.compare scope_def.scope_name
scope_uid
= 0
then Some scope_def.scope_body
else acc)
prgm.scopes) )
else
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
prgrm_dcalc_expr
| ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc
| `Proof | `Plugin _ ) as backend -> (
Cli.debug_print "Typechecking...";
let _typ = Dcalc.Typing.infer_type prgm.decl_ctx prgrm_dcalc_expr in
(* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a"
(Dcalc.Print.format_typ prgm.decl_ctx) typ); *)
match backend with
| `Typecheck ->
(* That's it! *)
Cli.result_print "Typechecking successful!"
| `Proof ->
let vcs =
Verification.Conditions.generate_verification_conditions prgm
(match options.ex_scope with
| None -> None
| Some _ -> Some scope_uid)
in
Verification.Solver.solve_vc prgm.decl_ctx vcs
| `Interpret ->
Cli.debug_print "Starting interpretation...";
let results =
Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr
in
let out_regex = Re.Pcre.regexp "\\_out$" in
let results =
List.map
(fun ((v1, v1_pos), e1) ->
let v1 =
Re.Pcre.substitute ~rex:out_regex ~subst:(fun _ -> "") v1
in
(v1, v1_pos), e1)
results
in
let results =
List.sort
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)
results
in
Cli.debug_print "End of interpretation";
Cli.result_print "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
List.iter
(fun ((var, _), result) ->
Cli.result_format "@[<hov 2>%s@ =@ %a@]" var
(Dcalc.Print.format_expr ~debug:options.debug prgm.decl_ctx)
result)
results
| (`OCaml | `Python | `Lcalc | `Scalc | `Plugin _) as backend -> (
Cli.debug_print "Compiling program into lambda calculus...";
let prgm =
if options.avoid_exceptions then
Lcalc.Compile_without_exceptions.translate_program prgm
else Lcalc.Compile_with_exceptions.translate_program prgm
in
let prgm =
if options.optimize then begin
Cli.debug_print "Optimizing lambda calculus...";
Lcalc.Optimizations.optimize_program prgm
end
else prgm
in
let prgm =
if options.closure_conversion then (
Cli.debug_print "Performing closure conversion...";
let prgm = Lcalc.Closure_conversion.closure_conversion prgm in
let prgm = Bindlib.unbox prgm in
prgm)
else prgm
in
match backend with
| `Lcalc ->
File.with_formatter_of_opt_file options.output_file @@ fun fmt ->
if Option.is_some options.ex_scope then if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n" Format.fprintf fmt "%a\n"
(Lcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) (Lcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
@ -309,58 +309,70 @@ let driver source_file (options : Cli.options) : int =
(Lcalc.Print.format_scope prgm.decl_ctx) (Lcalc.Print.format_scope prgm.decl_ctx)
(scope_uid, scope_def.scope_body); (scope_uid, scope_def.scope_body);
i + 1) i + 1)
prgm.scopes); prgm.scopes)
exit 0); | (`OCaml | `Python | `Scalc | `Plugin _) as backend -> (
let source_file = let source_file =
match source_file with match source_file with
| FileName f -> f | FileName f -> f
| Contents _ -> | Contents _ ->
Errors.raise_error Errors.raise_error
"This backend does not work if the input is not a file" "This backend does not work if the input is not a file"
in in
let new_output_file (extension : string) : string = let new_output_file (extension : string) : string =
match options.output_file with match options.output_file with
| Some f -> f | Some f -> f
| None -> Filename.remove_extension source_file ^ extension | None -> Filename.remove_extension source_file ^ extension
in in
(match backend with match backend with
| Cli.OCaml -> | `OCaml ->
let output_file = new_output_file ".ml" in let output_file = new_output_file ".ml" in
Cli.debug_print "Writing to %s..." output_file; File.with_out_channel output_file @@ fun oc ->
File.with_formatter_of_file output_file (fun fmt -> let fmt = Format.formatter_of_out_channel oc in
Cli.debug_print "Compiling program into OCaml..."; Cli.debug_print "Compiling program into OCaml...";
Lcalc.To_ocaml.format_program fmt prgm type_ordering) Cli.debug_print "Writing to %s..." output_file;
| Cli.Python | Cli.Scalc -> Lcalc.To_ocaml.format_program fmt prgm type_ordering
let prgm = Scalc.Compile_from_lambda.translate_program prgm in | `Plugin (Plugin.Lcalc p) ->
if backend = Cli.Scalc then let output_file = new_output_file p.Plugin.extension in
File.with_formatter_of_opt_file options.output_file (fun fmt -> Cli.debug_print "Compiling program through backend \"%s\"..."
if Option.is_some options.ex_scope then p.Plugin.name;
Format.fprintf fmt "%a\n" Cli.debug_print "Writing to %s..." output_file;
(Scalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) p.Plugin.apply output_file prgm type_ordering
(let body = | (`Python | `Scalc | `Plugin (Plugin.Scalc _)) as backend -> (
List.find let prgm = Scalc.Compile_from_lambda.translate_program prgm in
match backend with
| `Scalc ->
File.with_formatter_of_opt_file options.output_file
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scalc.Print.format_scope ~debug:options.debug
prgm.decl_ctx)
(List.find
(fun body -> (fun body ->
body.Scalc.Ast.scope_body_name = scope_uid) body.Scalc.Ast.scope_body_name = scope_uid)
prgm.scopes prgm.scopes)
in else
body) Format.fprintf fmt "%a\n"
else (Format.pp_print_list
Format.fprintf fmt "%a\n" ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(Format.pp_print_list (fun fmt scope ->
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") (Scalc.Print.format_scope prgm.decl_ctx) fmt scope))
(fun fmt scope -> prgm.scopes
(Scalc.Print.format_scope prgm.decl_ctx) fmt scope)) | `Python ->
prgm.scopes; let output_file = new_output_file ".py" in
exit 0); Cli.debug_print "Compiling program into Python...";
let output_file = new_output_file ".py" in Cli.debug_print "Writing to %s..." output_file;
Cli.debug_print "Compiling program into Python..."; File.with_out_channel output_file @@ fun oc ->
Cli.debug_print "Writing to %s..." output_file; let fmt = Format.formatter_of_out_channel oc in
File.with_formatter_of_file output_file (fun fmt -> Scalc.To_python.format_program fmt prgm type_ordering
Scalc.To_python.format_program fmt prgm type_ordering) | `Plugin (Plugin.Lcalc _) -> assert false
| _ -> assert false (* should not happen *)); | `Plugin (Plugin.Scalc p) ->
0 let output_file = new_output_file p.Plugin.extension in
| _ -> assert false Cli.debug_print "Compiling program through backend \"%s\"..."
(* should not happen *)) p.Plugin.name;
Cli.debug_print "Writing to %s..." output_file;
p.Plugin.apply output_file prgm type_ordering)))))));
0
with with
| Errors.StructuredError (msg, pos) -> | Errors.StructuredError (msg, pos) ->
Cli.error_print "%s" (Errors.print_structured_error msg pos); Cli.error_print "%s" (Errors.print_structured_error msg pos);
@ -375,3 +387,6 @@ let main () =
(Cmdliner.Cmd.v Cli.info (Cli.catala_t (fun f -> driver (FileName f)))) (Cmdliner.Cmd.v Cli.info (Cli.catala_t (fun f -> driver (FileName f))))
in in
exit return_code exit return_code
(* Export module PluginAPI, hide parent module Plugin *)
module Plugin = Plugin.PluginAPI

2
compiler/driver.mli
View File

@ -15,6 +15,8 @@
License for the specific language governing permissions and limitations under License for the specific language governing permissions and limitations under
the License. *) the License. *)
module Plugin = Plugin.PluginAPI
val driver : Utils.Pos.input_file -> Utils.Cli.options -> int val driver : Utils.Pos.input_file -> Utils.Cli.options -> int
(** Entry function for the executable. Returns a negative number in case of (** Entry function for the executable. Returns a negative number in case of
error. *) error. *)

3
compiler/dune
View File

@ -2,6 +2,7 @@
(name driver) (name driver)
(public_name catala.driver) (public_name catala.driver)
(libraries (libraries
dynlink
utils utils
surface surface
desugared desugared
@ -11,7 +12,7 @@
scalc scalc
runtime runtime
verification) verification)
(modules driver)) (modules plugin driver))
(library (library
(name runtime) (name runtime)

2
compiler/literate/html.ml
View File

@ -28,7 +28,7 @@ module C = Cli
(** {1 Helpers} *) (** {1 Helpers} *)
(** Converts double lines into HTML newlines. *) (** Converts double lines into HTML newlines. *)
let pre_html (s : string) = run_pandoc s Cli.Html let pre_html (s : string) = run_pandoc s `Html
(** Raise an error if pygments cannot be found *) (** Raise an error if pygments cannot be found *)
let raise_failed_pygments (command : string) (error_code : int) : 'a = let raise_failed_pygments (command : string) (error_code : int) : 'a =

2
compiler/literate/latex.ml
View File

@ -30,7 +30,7 @@ module C = Cli
let pre_latexify (s : string) : string = let pre_latexify (s : string) : string =
(* Then we send to pandoc, to ensure the markdown features used in the (* Then we send to pandoc, to ensure the markdown features used in the
original document are correctly printed! *) original document are correctly printed! *)
run_pandoc s Cli.Latex run_pandoc s `Latex
(** Usage: [wrap_latex source_files custom_pygments language fmt wrapped] (** Usage: [wrap_latex source_files custom_pygments language fmt wrapped]

7
compiler/literate/literate_common.ml
View File

@ -68,7 +68,7 @@ let raise_failed_pandoc (command : string) (error_code : int) : 'a =
"Weaving failed: pandoc command \"%s\" returned with error code %d" command "Weaving failed: pandoc command \"%s\" returned with error code %d" command
error_code error_code
let run_pandoc (s : string) (backend : Utils.Cli.backend_option) : string = let run_pandoc (s : string) (backend : [ `Html | `Latex ]) : string =
let pandoc = "pandoc" in let pandoc = "pandoc" in
let tmp_file_in = Filename.temp_file "catala_pandoc" "in" in let tmp_file_in = Filename.temp_file "catala_pandoc" "in" in
let tmp_file_out = Filename.temp_file "catala_pandoc" "out" in let tmp_file_out = Filename.temp_file "catala_pandoc" "out" in
@ -80,10 +80,7 @@ let run_pandoc (s : string) (backend : Utils.Cli.backend_option) : string =
"-f"; "-f";
"markdown+multiline_tables"; "markdown+multiline_tables";
"-t"; "-t";
(match backend with (match backend with `Html -> "html" | `Latex -> "latex");
| Cli.Html -> "html"
| Cli.Latex -> "latex"
| _ -> failwith "should not happen");
"-o"; "-o";
tmp_file_out; tmp_file_out;
|] |]

2
compiler/literate/literate_common.mli
View File

@ -41,7 +41,7 @@ val get_language_extension : Cli.backend_lang -> string
(** Return the file extension corresponding to the given (** Return the file extension corresponding to the given
{!type:Utils.Cli.backend_lang}. *) {!type:Utils.Cli.backend_lang}. *)
val run_pandoc : string -> Cli.backend_option -> string val run_pandoc : string -> [ `Html | `Latex ] -> string
(** Runs the [pandoc] on a string to pretty-print markdown features into the (** Runs the [pandoc] on a string to pretty-print markdown features into the
desired format. *) desired format. *)

57
compiler/plugin.ml Normal file
View File

@ -0,0 +1,57 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2022 Inria, OCamlPro;
contributors: Louis Gesbert <louis.gesbert@ocamlpro.com>
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 'ast gen = {
name : string;
extension : string;
apply : string -> 'ast -> Scopelang.Dependency.TVertex.t list -> unit;
}
type t = Lcalc of Lcalc.Ast.program gen | Scalc of Scalc.Ast.program gen
let name = function Lcalc { name; _ } | Scalc { name; _ } -> name
let backend_plugins : (string, t) Hashtbl.t = Hashtbl.create 17
let register t =
Hashtbl.replace backend_plugins (String.lowercase_ascii (name t)) t
module PluginAPI = struct
let register_lcalc ~name ~extension apply =
register (Lcalc { name; extension; apply })
let register_scalc ~name ~extension apply =
register (Scalc { name; extension; apply })
end
let find name = Hashtbl.find backend_plugins (String.lowercase_ascii name)
let load_file f =
try
Dynlink.loadfile f;
Utils.Cli.debug_print "Plugin %S loaded" f
with e ->
Utils.Errors.format_warning "Could not load plugin %S: %s" f
(Printexc.to_string e)
let load_dir d =
let dynlink_exts =
if Dynlink.is_native then [".cmxs"] else [".cmo"; ".cma"]
in
Array.iter
(fun f ->
if List.exists (Filename.check_suffix f) dynlink_exts then
load_file (Filename.concat d f))
(Sys.readdir d)

54
compiler/plugin.mli Normal file
View File

@ -0,0 +1,54 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2022 Inria, OCamlPro;
contributors: Louis Gesbert <louis.gesbert@ocamlpro.com>
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. *)
(** {2 catala-facing API} *)
type 'ast gen = {
name : string;
extension : string;
apply : string -> 'ast -> Scopelang.Dependency.TVertex.t list -> unit;
}
type t = Lcalc of Lcalc.Ast.program gen | Scalc of Scalc.Ast.program gen
val find : string -> t
(** Find a registered plugin *)
val load_file : string -> unit
(** Load the given plugin (cmo/cma or cmxs file) *)
val load_dir : string -> unit
(** Load all plugins found in the given directory *)
(** {2 plugin-facing API} *)
module PluginAPI : sig
val register_lcalc :
name:string ->
extension:string ->
(string -> Lcalc.Ast.program -> Scopelang.Dependency.TVertex.t list -> unit) ->
unit
val register_scalc :
name:string ->
extension:string ->
(string -> Scalc.Ast.program -> Scopelang.Dependency.TVertex.t list -> unit) ->
unit
end
(**/*)
val register : t -> unit

100
compiler/utils/cli.ml
View File

@ -17,49 +17,52 @@
type backend_lang = En | Fr | Pl type backend_lang = En | Fr | Pl
type backend_option = type backend_option_builtin =
| Dcalc [ `Latex
| Html | `Makefile
| Interpret | `Html
| Latex | `Interpret
| Lcalc | `Typecheck
| Makefile | `OCaml
| OCaml | `Python
| Proof | `Scalc
| Python | `Lcalc
| Scalc | `Dcalc
| Scopelang | `Scopelang
| Typecheck | `Proof ]
let catala_backend_option_to_string = function type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ]
| Dcalc -> "Dcalc"
| Html -> "Html"
| Interpret -> "Interpret"
| Latex -> "Latex"
| Lcalc -> "Lcalc"
| Makefile -> "Makefile"
| OCaml -> "OCaml"
| Proof -> "Proof"
| Python -> "Python"
| Scalc -> "Scalc"
| Scopelang -> "Scopelang"
| Typecheck -> "Typecheck"
let catala_backend_option_of_string backend = let backend_option_to_string = function
| `Interpret -> "Interpret"
| `Makefile -> "Makefile"
| `OCaml -> "Ocaml"
| `Scopelang -> "Scopelang"
| `Dcalc -> "Dcalc"
| `Latex -> "Latex"
| `Proof -> "Proof"
| `Html -> "Html"
| `Python -> "Python"
| `Typecheck -> "Typecheck"
| `Scalc -> "Scalc"
| `Lcalc -> "Lcalc"
| `Plugin s -> s
let backend_option_of_string backend =
match String.lowercase_ascii backend with match String.lowercase_ascii backend with
| "dcalc" -> Some Dcalc | "interpret" -> `Interpret
| "html" -> Some Html | "makefile" -> `Makefile
| "interpret" -> Some Interpret | "ocaml" -> `OCaml
| "latex" -> Some Latex | "scopelang" -> `Scopelang
| "lcalc" -> Some Lcalc | "dcalc" -> `Dcalc
| "makefile" -> Some Makefile | "latex" -> `Latex
| "ocaml" -> Some OCaml | "proof" -> `Proof
| "proof" -> Some Proof | "html" -> `Html
| "python" -> Some Python | "python" -> `Python
| "scalc" -> Some Scalc | "typecheck" -> `Typecheck
| "scopelang" -> Some Scopelang | "scalc" -> `Scalc
| "typecheck" -> Some Typecheck | "lcalc" -> `Lcalc
| _ -> None | s -> `Plugin s
(** Source files to be compiled *) (** Source files to be compiled *)
let source_files : string list ref = ref [] let source_files : string list ref = ref []
@ -134,6 +137,15 @@ let backend =
~doc: ~doc:
"Backend selection (see the list of commands for available options).") "Backend selection (see the list of commands for available options).")
let plugins_dirs =
let doc = "Set the given directory to be searched for backend plugins." in
let env = Cmd.Env.info "CATALA_PLUGINS" ~doc in
let default =
let ( / ) = Filename.concat in
[Sys.executable_name / ".." / "lib" / "catala" / "plugins"]
in
Arg.(value & opt_all dir default & info ["plugin-dir"] ~docv:"DIR" ~env ~doc)
let language = let language =
Arg.( Arg.(
value value
@ -184,6 +196,7 @@ type options = {
wrap_weaved_output : bool; wrap_weaved_output : bool;
avoid_exceptions : bool; avoid_exceptions : bool;
backend : string; backend : string;
plugins_dirs : string list;
language : string option; language : string option;
max_prec_digits : int option; max_prec_digits : int option;
trace : bool; trace : bool;
@ -202,6 +215,7 @@ let options =
avoid_exceptions avoid_exceptions
closure_conversion closure_conversion
backend backend
plugins_dirs
language language
max_prec_digits max_prec_digits
trace trace
@ -215,6 +229,7 @@ let options =
wrap_weaved_output; wrap_weaved_output;
avoid_exceptions; avoid_exceptions;
backend; backend;
plugins_dirs;
language; language;
max_prec_digits; max_prec_digits;
trace; trace;
@ -227,8 +242,9 @@ let options =
in in
Term.( Term.(
const make $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions const make $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions
$ closure_conversion $ backend $ language $ max_prec_digits_opt $ trace_opt $ closure_conversion $ backend $ plugins_dirs $ language
$ disable_counterexamples_opt $ optimize $ ex_scope $ output) $ max_prec_digits_opt $ trace_opt $ disable_counterexamples_opt $ optimize
$ ex_scope $ output)
let catala_t f = Term.(const f $ file $ options) let catala_t f = Term.(const f $ file $ options)

38
compiler/utils/cli.mli
View File

@ -17,26 +17,28 @@
type backend_lang = En | Fr | Pl type backend_lang = En | Fr | Pl
type backend_option = type backend_option_builtin =
| Dcalc [ `Latex
| Html | `Makefile
| Interpret | `Html
| Latex | `Interpret
| Lcalc | `Typecheck
| Makefile | `OCaml
| OCaml | `Python
| Proof | `Scalc
| Python | `Lcalc
| Scalc | `Dcalc
| Scopelang | `Scopelang
| Typecheck | `Proof ]
val catala_backend_option_to_string : backend_option -> string type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ]
(** [catala_backend_to_string backend] returns the string representation of the
val backend_option_to_string : string backend_option -> string
(** [backend_option_to_string backend] returns the string representation of the
given [backend].*) given [backend].*)
val catala_backend_option_of_string : string -> backend_option option val backend_option_of_string : string -> string backend_option
(** [catala_backend_option_of_string backend] returns the {!type:backend_option} (** [backend_option_of_string backend] returns the {!type:backend_option}
corresponding to the [backend] string. *) corresponding to the [backend] string. *)
(** {2 Configuration globals} *) (** {2 Configuration globals} *)
@ -72,6 +74,7 @@ val unstyled : bool Cmdliner.Term.t
val trace_opt : bool Cmdliner.Term.t val trace_opt : bool Cmdliner.Term.t
val wrap_weaved_output : bool Cmdliner.Term.t val wrap_weaved_output : bool Cmdliner.Term.t
val backend : string Cmdliner.Term.t val backend : string Cmdliner.Term.t
val plugins_dirs : string list Cmdliner.Term.t
val language : string option Cmdliner.Term.t val language : string option Cmdliner.Term.t
val max_prec_digits_opt : int option Cmdliner.Term.t val max_prec_digits_opt : int option Cmdliner.Term.t
val ex_scope : string option Cmdliner.Term.t val ex_scope : string option Cmdliner.Term.t
@ -83,6 +86,7 @@ type options = {
wrap_weaved_output : bool; wrap_weaved_output : bool;
avoid_exceptions : bool; avoid_exceptions : bool;
backend : string; backend : string;
plugins_dirs : string list;
language : string option; language : string option;
max_prec_digits : int option; max_prec_digits : int option;
trace : bool; trace : bool;

32
compiler/utils/file.ml
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax (* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor: and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Emile Rolley <emile.rolley@tuta.io> Emile Rolley <emile.rolley@tuta.io>, Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not 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 use this file except in compliance with the License. You may obtain a copy of
@ -14,24 +14,30 @@
License for the specific language governing permissions and limitations under License for the specific language governing permissions and limitations under
the License. *) the License. *)
let with_formatter_of_out_channel oc f = (** Run finaliser [f] unconditionally after running [k ()], propagating any
let fmt = Format.formatter_of_out_channel oc in raised exception. *)
match f fmt with let finally f k =
match k () with
| exception e -> | exception e ->
let bt = Printexc.get_raw_backtrace () in let bt = Printexc.get_raw_backtrace () in
Format.pp_print_flush fmt (); f ();
Printexc.raise_with_backtrace e bt Printexc.raise_with_backtrace e bt
| res -> | r ->
Format.pp_print_flush fmt (); f ();
res r
let with_out_channel filename f =
let oc = open_out filename in
finally (fun () -> close_out oc) (fun () -> f oc)
let with_formatter_of_out_channel oc f =
let fmt = Format.formatter_of_out_channel oc in
finally (fun () -> Format.pp_print_flush fmt ()) @@ fun () -> f fmt
let with_formatter_of_file filename f = let with_formatter_of_file filename f =
let oc = open_out filename in with_out_channel filename (fun oc -> with_formatter_of_out_channel oc f)
let res = with_formatter_of_out_channel oc f in
close_out oc;
res
let with_formatter_of_opt_file filename_opt f = let with_formatter_of_opt_file filename_opt f =
match filename_opt with match filename_opt with
| None -> f Format.std_formatter | None -> finally (fun () -> flush stdout) (fun () -> f Format.std_formatter)
| Some filename -> with_formatter_of_file filename f | Some filename -> with_formatter_of_file filename f

4
compiler/utils/file.mli
View File

@ -16,6 +16,10 @@
(** Utility functions used for file manipulation. *) (** Utility functions used for file manipulation. *)
val with_out_channel : string -> (out_channel -> 'a) -> 'a
(** Runs the given function with the provided file opened, ensuring it is
properly closed afterwards. May raise just as [open_out]. *)
(** {2 Formatter wrappers} *) (** {2 Formatter wrappers} *)
val with_formatter_of_out_channel : val with_formatter_of_out_channel :