2020-04-16 18:47:35 +03:00
|
|
|
(* This file is part of the Catala compiler, a specification language for tax
|
2021-05-27 19:56:47 +03:00
|
|
|
and social benefits computation rules. Copyright (C) 2020 Inria,
|
|
|
|
contributors: Denis Merigoux <denis.merigoux@inria.fr>, Emile Rolley
|
2023-06-28 16:57:52 +03:00
|
|
|
<emile.rolley@tuta.io>, Louis Gesbert <louis.gesbert@inria.fr>
|
2020-03-08 03:52:31 +03:00
|
|
|
|
|
|
|
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. *)
|
|
|
|
|
2022-11-21 12:46:17 +03:00
|
|
|
open Catala_utils
|
2023-06-28 16:57:52 +03:00
|
|
|
open Shared_ast
|
2020-11-23 11:22:47 +03:00
|
|
|
|
2022-01-02 16:53:51 +03:00
|
|
|
(** Associates a file extension with its corresponding {!type: Cli.backend_lang}
|
2021-05-24 17:24:45 +03:00
|
|
|
string representation. *)
|
2021-05-26 18:44:57 +03:00
|
|
|
let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
|
2021-05-24 17:24:45 +03:00
|
|
|
|
2023-06-28 16:57:52 +03:00
|
|
|
let modname_of_file f =
|
|
|
|
(* Fixme: make this more robust *)
|
|
|
|
String.capitalize_ascii Filename.(basename (remove_extension f))
|
|
|
|
|
2023-09-27 12:01:43 +03:00
|
|
|
let load_module_interfaces options includes program =
|
2023-09-22 16:37:58 +03:00
|
|
|
(* Recurse into program modules, looking up files in [using] and loading
|
|
|
|
them *)
|
2023-11-20 18:01:06 +03:00
|
|
|
if program.Surface.Ast.program_used_modules <> [] then
|
|
|
|
Message.emit_debug "Loading module interfaces...";
|
2023-09-27 12:01:43 +03:00
|
|
|
let includes =
|
|
|
|
includes
|
|
|
|
|> List.map (fun d -> File.Tree.build (options.Cli.path_rewrite d))
|
|
|
|
|> List.fold_left File.Tree.union File.Tree.empty
|
|
|
|
in
|
2023-09-22 16:37:58 +03:00
|
|
|
let err_req_pos chain =
|
2023-11-20 18:01:06 +03:00
|
|
|
List.map (fun mpos -> Some "Module required from", mpos) chain
|
2023-09-22 16:37:58 +03:00
|
|
|
in
|
2023-11-20 18:01:06 +03:00
|
|
|
let find_module req_chain (mname, mpos) =
|
|
|
|
let required_from_file = Pos.get_file mpos in
|
2023-09-24 12:25:34 +03:00
|
|
|
let includes =
|
|
|
|
File.Tree.union includes
|
|
|
|
(File.Tree.build (File.dirname required_from_file))
|
|
|
|
in
|
2023-09-22 16:37:58 +03:00
|
|
|
match
|
|
|
|
List.filter_map
|
2023-11-20 18:01:06 +03:00
|
|
|
(fun (ext, _) -> File.Tree.lookup includes (mname ^ ext))
|
2023-09-22 16:37:58 +03:00
|
|
|
extensions
|
|
|
|
with
|
|
|
|
| [] ->
|
|
|
|
Message.raise_multispanned_error
|
2023-11-20 18:01:06 +03:00
|
|
|
(err_req_pos (mpos :: req_chain))
|
|
|
|
"Required module not found: @{<blue>%s@}" mname
|
2023-09-22 16:37:58 +03:00
|
|
|
| [f] -> f
|
|
|
|
| ms ->
|
|
|
|
Message.raise_multispanned_error
|
2023-11-20 18:01:06 +03:00
|
|
|
(err_req_pos (mpos :: req_chain))
|
|
|
|
"Required module @{<blue>%s@} matches multiple files:@;<1 2>%a" mname
|
2023-09-22 16:37:58 +03:00
|
|
|
(Format.pp_print_list ~pp_sep:Format.pp_print_space File.format)
|
|
|
|
ms
|
2023-09-19 12:44:18 +03:00
|
|
|
in
|
2023-12-05 17:58:53 +03:00
|
|
|
let rec aux req_chain seen uses :
|
|
|
|
(ModuleName.t * Surface.Ast.interface * ModuleName.t Ident.Map.t) option
|
|
|
|
File.Map.t
|
|
|
|
* ModuleName.t Ident.Map.t =
|
2023-12-01 01:53:38 +03:00
|
|
|
List.fold_left
|
|
|
|
(fun (seen, use_map) use ->
|
2023-11-20 18:01:06 +03:00
|
|
|
let f = find_module req_chain use.Surface.Ast.mod_use_name in
|
|
|
|
match File.Map.find_opt f seen with
|
|
|
|
| Some (Some (modname, _, _)) ->
|
2023-12-01 01:53:38 +03:00
|
|
|
( seen,
|
|
|
|
Ident.Map.add
|
|
|
|
(Mark.remove use.Surface.Ast.mod_use_alias)
|
|
|
|
modname use_map )
|
2023-11-20 18:01:06 +03:00
|
|
|
| Some None ->
|
|
|
|
Message.raise_multispanned_error
|
|
|
|
(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
|
2023-12-01 20:07:16 +03:00
|
|
|
let modname = ModuleName.fresh intf.intf_modname in
|
2023-11-20 18:01:06 +03:00
|
|
|
let seen = File.Map.add f None seen in
|
|
|
|
let seen, sub_use_map =
|
|
|
|
aux
|
|
|
|
(Mark.get use.Surface.Ast.mod_use_name :: req_chain)
|
2023-12-01 01:53:38 +03:00
|
|
|
seen intf.Surface.Ast.intf_submodules
|
2023-11-20 18:01:06 +03:00
|
|
|
in
|
2023-12-01 01:53:38 +03:00
|
|
|
( File.Map.add f (Some (modname, intf, sub_use_map)) seen,
|
|
|
|
Ident.Map.add
|
|
|
|
(Mark.remove use.Surface.Ast.mod_use_alias)
|
|
|
|
modname use_map ))
|
2023-11-20 18:01:06 +03:00
|
|
|
(seen, Ident.Map.empty) uses
|
2023-09-19 12:44:18 +03:00
|
|
|
in
|
2023-11-20 18:01:06 +03:00
|
|
|
let seen =
|
|
|
|
match program.Surface.Ast.program_module_name with
|
|
|
|
| Some m ->
|
|
|
|
let file = Pos.get_file (Mark.get m) in
|
|
|
|
File.Map.singleton file None
|
|
|
|
| None -> File.Map.empty
|
2023-09-19 12:44:18 +03:00
|
|
|
in
|
2023-11-20 18:01:06 +03:00
|
|
|
let file_module_map, root_uses =
|
|
|
|
aux [] seen program.Surface.Ast.program_used_modules
|
2023-09-19 12:44:18 +03:00
|
|
|
in
|
2023-11-20 18:01:06 +03:00
|
|
|
let modules =
|
|
|
|
File.Map.fold
|
2023-12-01 01:53:38 +03:00
|
|
|
(fun _ info acc ->
|
|
|
|
match info with
|
|
|
|
| None -> acc
|
|
|
|
| Some (mname, intf, use_map) ->
|
|
|
|
ModuleName.Map.add mname (intf, use_map) acc)
|
2023-11-20 18:01:06 +03:00
|
|
|
file_module_map ModuleName.Map.empty
|
|
|
|
in
|
|
|
|
root_uses, modules
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
module Passes = struct
|
|
|
|
(* Each pass takes only its cli options, then calls upon its dependent passes
|
|
|
|
(forwarding their options as needed) *)
|
|
|
|
|
2023-09-01 11:43:46 +03:00
|
|
|
let debug_pass_name s =
|
|
|
|
Message.emit_debug "@{<bold;magenta>=@} @{<bold>%s@} @{<bold;magenta>=@}"
|
|
|
|
(String.uppercase_ascii s)
|
|
|
|
|
2023-11-20 18:01:06 +03:00
|
|
|
let surface options : Surface.Ast.program =
|
2023-09-01 11:43:46 +03:00
|
|
|
debug_pass_name "surface";
|
2023-06-28 16:57:52 +03:00
|
|
|
let prg =
|
2023-09-26 12:42:46 +03:00
|
|
|
Surface.Parser_driver.parse_top_level_file options.Cli.input_src
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-11-20 18:01:06 +03:00
|
|
|
Surface.Fill_positions.fill_pos_with_legislative_info prg
|
2023-06-28 16:57:52 +03:00
|
|
|
|
2023-09-22 16:37:58 +03:00
|
|
|
let desugared options ~includes :
|
2023-06-28 16:57:52 +03:00
|
|
|
Desugared.Ast.program * Desugared.Name_resolution.context =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = surface options in
|
|
|
|
let mod_uses, modules = load_module_interfaces options includes prg in
|
2023-09-01 11:43:46 +03:00
|
|
|
debug_pass_name "desugared";
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "Name resolution...";
|
2023-11-20 18:01:06 +03:00
|
|
|
let ctx = Desugared.Name_resolution.form_context (prg, mod_uses) modules in
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "Desugaring...";
|
|
|
|
let prg = Desugared.From_surface.translate_program ctx prg in
|
|
|
|
Message.emit_debug "Disambiguating...";
|
|
|
|
let prg = Desugared.Disambiguate.program prg in
|
|
|
|
Message.emit_debug "Linting...";
|
|
|
|
Desugared.Linting.lint_program prg;
|
|
|
|
prg, ctx
|
|
|
|
|
2023-12-01 01:53:38 +03:00
|
|
|
let scopelang options ~includes : untyped Scopelang.Ast.program =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ = desugared options ~includes in
|
2023-09-01 11:43:46 +03:00
|
|
|
debug_pass_name "scopelang";
|
2023-06-28 16:57:52 +03:00
|
|
|
let exceptions_graphs =
|
|
|
|
Scopelang.From_desugared.build_exceptions_graph prg
|
|
|
|
in
|
|
|
|
let prg =
|
|
|
|
Scopelang.From_desugared.translate_program prg exceptions_graphs
|
|
|
|
in
|
2023-11-20 18:01:06 +03:00
|
|
|
prg
|
2023-06-15 18:37:52 +03:00
|
|
|
|
2023-11-07 20:25:57 +03:00
|
|
|
let dcalc :
|
|
|
|
type ty.
|
|
|
|
Cli.options ->
|
|
|
|
includes:Cli.raw_file list ->
|
|
|
|
optimize:bool ->
|
|
|
|
check_invariants:bool ->
|
|
|
|
typed:ty mark ->
|
2023-12-01 01:53:38 +03:00
|
|
|
ty Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
2023-11-07 20:25:57 +03:00
|
|
|
fun options ~includes ~optimize ~check_invariants ~typed ->
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = scopelang options ~includes in
|
2023-09-01 11:43:46 +03:00
|
|
|
debug_pass_name "dcalc";
|
2023-06-28 16:57:52 +03:00
|
|
|
let type_ordering =
|
|
|
|
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
|
|
|
|
prg.program_ctx.ctx_enums
|
|
|
|
in
|
2023-11-07 20:25:57 +03:00
|
|
|
let (prg : ty Scopelang.Ast.program) =
|
2023-11-02 16:36:55 +03:00
|
|
|
match typed with
|
|
|
|
| Typed _ ->
|
|
|
|
Message.emit_debug "Typechecking...";
|
|
|
|
Scopelang.Ast.type_program prg
|
|
|
|
| Untyped _ -> prg
|
|
|
|
| Custom _ -> invalid_arg "Driver.Passes.dcalc"
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "Translating to default calculus...";
|
2023-11-07 20:25:57 +03:00
|
|
|
let prg = Dcalc.From_scopelang.translate_program prg in
|
2023-06-28 16:57:52 +03:00
|
|
|
let prg =
|
|
|
|
if optimize then begin
|
|
|
|
Message.emit_debug "Optimizing default calculus...";
|
|
|
|
Optimizations.optimize_program prg
|
|
|
|
end
|
|
|
|
else prg
|
|
|
|
in
|
2023-11-07 20:25:57 +03:00
|
|
|
let (prg : ty Dcalc.Ast.program) =
|
2023-11-02 16:36:55 +03:00
|
|
|
match typed with
|
2023-11-07 20:25:57 +03:00
|
|
|
| Typed _ -> (
|
2023-11-02 16:36:55 +03:00
|
|
|
Message.emit_debug "Typechecking again...";
|
2024-02-07 19:41:04 +03:00
|
|
|
try Typing.program prg
|
2023-11-07 20:25:57 +03:00
|
|
|
with Message.CompilerError error_content ->
|
|
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
|
|
Printexc.raise_with_backtrace
|
|
|
|
(Message.CompilerError
|
|
|
|
(Message.Content.to_internal_error error_content))
|
|
|
|
bt)
|
2023-11-02 16:36:55 +03:00
|
|
|
| Untyped _ -> prg
|
|
|
|
| Custom _ -> assert false
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
if check_invariants then (
|
|
|
|
Message.emit_debug "Checking invariants...";
|
2023-11-02 16:36:55 +03:00
|
|
|
match typed with
|
|
|
|
| Typed _ ->
|
2024-01-25 19:55:32 +03:00
|
|
|
if Dcalc.Invariants.check_all_invariants prg then
|
|
|
|
Message.emit_result "All invariant checks passed"
|
|
|
|
else
|
2023-11-07 20:25:57 +03:00
|
|
|
raise
|
|
|
|
(Message.raise_internal_error "Some Dcalc invariants are invalid")
|
2023-11-02 16:36:55 +03:00
|
|
|
| _ ->
|
2023-12-05 14:00:15 +03:00
|
|
|
Message.raise_error "--check-invariants cannot be used with --no-typing");
|
2023-11-20 18:01:06 +03:00
|
|
|
prg, type_ordering
|
2023-06-28 16:57:52 +03:00
|
|
|
|
2023-11-07 20:25:57 +03:00
|
|
|
let lcalc
|
|
|
|
(type ty)
|
2023-06-28 16:57:52 +03:00
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
~includes
|
2023-06-28 16:57:52 +03:00
|
|
|
~optimize
|
|
|
|
~check_invariants
|
2023-11-07 20:25:57 +03:00
|
|
|
~(typed : ty mark)
|
2023-06-28 16:57:52 +03:00
|
|
|
~avoid_exceptions
|
2023-12-19 17:01:06 +03:00
|
|
|
~closure_conversion
|
|
|
|
~monomorphize_types :
|
2024-01-22 18:49:58 +03:00
|
|
|
typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, type_ordering =
|
2023-11-02 16:36:55 +03:00
|
|
|
dcalc options ~includes ~optimize ~check_invariants ~typed
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-09-01 11:43:46 +03:00
|
|
|
debug_pass_name "lcalc";
|
2023-06-28 16:57:52 +03:00
|
|
|
let avoid_exceptions = avoid_exceptions || closure_conversion in
|
2023-12-05 14:00:15 +03:00
|
|
|
(* --closure-conversion implies --avoid-exceptions *)
|
2023-06-28 16:57:52 +03:00
|
|
|
let prg =
|
2023-11-02 16:36:55 +03:00
|
|
|
match avoid_exceptions, options.trace, typed with
|
|
|
|
| true, true, _ ->
|
|
|
|
Message.raise_error
|
2023-12-05 14:00:15 +03:00
|
|
|
"Option --avoid-exceptions is not compatible with option --trace"
|
2023-11-02 16:36:55 +03:00
|
|
|
| true, _, Untyped _ ->
|
2024-02-06 19:51:42 +03:00
|
|
|
Lcalc.From_dcalc.translate_program_without_exceptions prg
|
2023-11-02 16:36:55 +03:00
|
|
|
| true, _, Typed _ ->
|
2023-12-18 16:21:46 +03:00
|
|
|
Lcalc.From_dcalc.translate_program_without_exceptions prg
|
2023-11-02 16:36:55 +03:00
|
|
|
| false, _, Typed _ ->
|
2024-01-30 18:58:41 +03:00
|
|
|
Lcalc.From_dcalc.translate_program_with_exceptions prg
|
2023-11-02 16:36:55 +03:00
|
|
|
| false, _, Untyped _ ->
|
2024-02-06 19:51:42 +03:00
|
|
|
Lcalc.From_dcalc.translate_program_with_exceptions prg
|
2023-11-02 16:36:55 +03:00
|
|
|
| _, _, Custom _ -> invalid_arg "Driver.Passes.lcalc"
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
let prg =
|
|
|
|
if optimize then begin
|
|
|
|
Message.emit_debug "Optimizing lambda calculus...";
|
|
|
|
Optimizations.optimize_program prg
|
|
|
|
end
|
|
|
|
else prg
|
|
|
|
in
|
|
|
|
let prg =
|
2024-01-30 18:58:41 +03:00
|
|
|
if not closure_conversion then (
|
|
|
|
Message.emit_debug "Retyping lambda calculus...";
|
2024-02-07 19:41:04 +03:00
|
|
|
Typing.program ~fail_on_any:false prg)
|
2023-06-28 16:57:52 +03:00
|
|
|
else (
|
|
|
|
Message.emit_debug "Performing closure conversion...";
|
|
|
|
let prg = Lcalc.Closure_conversion.closure_conversion prg in
|
|
|
|
let prg =
|
|
|
|
if optimize then (
|
|
|
|
Message.emit_debug "Optimizing lambda calculus...";
|
|
|
|
Optimizations.optimize_program prg)
|
|
|
|
else prg
|
|
|
|
in
|
2024-01-30 18:58:41 +03:00
|
|
|
Message.emit_debug "Retyping lambda calculus...";
|
2024-02-07 19:41:04 +03:00
|
|
|
Typing.program ~fail_on_any:false prg)
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-12-20 19:43:31 +03:00
|
|
|
let prg, type_ordering =
|
|
|
|
if monomorphize_types then (
|
|
|
|
Message.emit_debug "Monomorphizing types...";
|
2024-02-07 19:41:04 +03:00
|
|
|
let prg, type_ordering = Lcalc.Monomorphize.program prg in
|
|
|
|
Message.emit_debug "Retyping lambda calculus...";
|
|
|
|
let prg = Typing.program ~fail_on_any:false ~assume_op_types:true prg in
|
|
|
|
prg, type_ordering)
|
2023-12-20 19:43:31 +03:00
|
|
|
else prg, type_ordering
|
2023-12-19 17:01:06 +03:00
|
|
|
in
|
2024-01-22 18:49:58 +03:00
|
|
|
prg, type_ordering
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let scalc
|
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
~includes
|
2023-06-28 16:57:52 +03:00
|
|
|
~optimize
|
|
|
|
~check_invariants
|
|
|
|
~avoid_exceptions
|
2023-12-07 18:58:22 +03:00
|
|
|
~closure_conversion
|
2023-12-11 19:08:32 +03:00
|
|
|
~keep_special_ops
|
|
|
|
~dead_value_assignment
|
2023-12-19 17:01:06 +03:00
|
|
|
~no_struct_literals
|
|
|
|
~monomorphize_types :
|
2023-12-01 01:53:38 +03:00
|
|
|
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, type_ordering =
|
2024-01-17 15:08:20 +03:00
|
|
|
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
|
2023-12-19 17:01:06 +03:00
|
|
|
~avoid_exceptions ~closure_conversion ~monomorphize_types
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-09-01 11:43:46 +03:00
|
|
|
debug_pass_name "scalc";
|
2023-12-11 19:08:32 +03:00
|
|
|
( Scalc.From_lcalc.translate_program
|
|
|
|
~config:{ keep_special_ops; dead_value_assignment; no_struct_literals }
|
|
|
|
prg,
|
|
|
|
type_ordering )
|
2023-06-28 16:57:52 +03:00
|
|
|
end
|
|
|
|
|
|
|
|
module Commands = struct
|
|
|
|
open Cmdliner
|
|
|
|
|
2023-12-01 01:53:38 +03:00
|
|
|
let get_scope_uid (ctx : decl_ctx) (scope : string) : ScopeName.t =
|
2023-11-20 18:01:06 +03:00
|
|
|
if String.contains scope '.' then
|
2023-12-05 17:58:53 +03:00
|
|
|
Message.raise_error
|
|
|
|
"Bad scope argument @{<yellow>%s@}: only references to the top-level \
|
|
|
|
module are allowed"
|
|
|
|
scope;
|
2023-12-01 01:53:38 +03:00
|
|
|
try Ident.Map.find scope ctx.ctx_scope_index
|
|
|
|
with Ident.Map.Not_found _ ->
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.raise_error
|
2023-12-05 17:58:53 +03:00
|
|
|
"There is no scope \"@{<yellow>%s@}\" inside the program." scope
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
(* TODO: this is very weird but I'm trying to maintain the current behaviour
|
|
|
|
for now *)
|
2023-12-01 01:53:38 +03:00
|
|
|
let get_random_scope_uid (ctx : decl_ctx) : ScopeName.t =
|
2023-11-20 18:01:06 +03:00
|
|
|
match Ident.Map.choose_opt ctx.ctx_scope_index with
|
|
|
|
| Some (_, name) -> name
|
2023-12-01 01:53:38 +03:00
|
|
|
| None -> Message.raise_error "There isn't any scope inside the program."
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let get_variable_uid
|
|
|
|
(ctxt : Desugared.Name_resolution.context)
|
|
|
|
(scope_uid : ScopeName.t)
|
|
|
|
(variable : string) =
|
|
|
|
(* Sometimes the variable selected is of the form [a.b] *)
|
2023-04-18 11:31:44 +03:00
|
|
|
let first_part, second_part =
|
2023-06-28 16:57:52 +03:00
|
|
|
match String.index_opt variable '.' with
|
|
|
|
| Some i ->
|
|
|
|
( String.sub variable 0 i,
|
|
|
|
Some (String.sub variable i (String.length variable - i)) )
|
|
|
|
| None -> variable, None
|
2023-04-18 11:31:44 +03:00
|
|
|
in
|
|
|
|
match
|
2023-06-28 16:57:52 +03:00
|
|
|
Ident.Map.find_opt first_part
|
|
|
|
(ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
|
2023-04-18 11:31:44 +03:00
|
|
|
with
|
|
|
|
| None ->
|
2023-06-13 12:27:45 +03:00
|
|
|
Message.raise_error
|
2023-06-07 19:10:50 +03:00
|
|
|
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
|
2023-07-12 12:48:46 +03:00
|
|
|
variable ScopeName.format scope_uid
|
2023-12-01 01:53:38 +03:00
|
|
|
| Some (SubScope (subscope_var_name, subscope_name)) -> (
|
2023-04-18 11:31:44 +03:00
|
|
|
match second_part with
|
|
|
|
| None ->
|
2023-06-13 12:27:45 +03:00
|
|
|
Message.raise_error
|
2023-06-07 19:10:50 +03:00
|
|
|
"Subscope @{<yellow>\"%a\"@} of scope @{<yellow>\"%a\"@} cannot be \
|
2023-04-18 11:31:44 +03:00
|
|
|
selected by itself, please add \".<var>\" where <var> is a subscope \
|
|
|
|
variable."
|
2023-07-12 12:48:46 +03:00
|
|
|
SubScopeName.format subscope_var_name ScopeName.format scope_uid
|
2023-04-18 11:31:44 +03:00
|
|
|
| Some second_part -> (
|
|
|
|
match
|
2023-08-30 18:49:29 +03:00
|
|
|
let ctxt =
|
|
|
|
Desugared.Name_resolution.module_ctx ctxt
|
|
|
|
(List.map
|
|
|
|
(fun m -> ModuleName.to_string m, Pos.no_pos)
|
|
|
|
(ScopeName.path subscope_name))
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
Ident.Map.find_opt second_part
|
|
|
|
(ScopeName.Map.find subscope_name ctxt.scopes).var_idmap
|
2023-04-18 11:31:44 +03:00
|
|
|
with
|
2023-11-20 18:01:06 +03:00
|
|
|
| Some (ScopeVar v) ->
|
2023-06-28 16:57:52 +03:00
|
|
|
Desugared.Ast.ScopeDef.SubScopeVar (subscope_var_name, v, Pos.no_pos)
|
2023-04-18 11:31:44 +03:00
|
|
|
| _ ->
|
2023-06-13 12:27:45 +03:00
|
|
|
Message.raise_error
|
2023-06-07 19:10:50 +03:00
|
|
|
"Var @{<yellow>\"%s\"@} of subscope @{<yellow>\"%a\"@} in scope \
|
|
|
|
@{<yellow>\"%a\"@} does not exist, please check your command line \
|
2023-04-18 11:31:44 +03:00
|
|
|
arguments."
|
2023-07-12 12:48:46 +03:00
|
|
|
second_part SubScopeName.format subscope_var_name ScopeName.format
|
|
|
|
scope_uid))
|
2023-11-20 18:01:06 +03:00
|
|
|
| Some (ScopeVar v) ->
|
2023-06-28 16:57:52 +03:00
|
|
|
Desugared.Ast.ScopeDef.Var
|
|
|
|
( v,
|
|
|
|
Option.map
|
|
|
|
(fun second_part ->
|
|
|
|
let var_sig = ScopeVar.Map.find v ctxt.var_typs in
|
|
|
|
match
|
|
|
|
Ident.Map.find_opt second_part var_sig.var_sig_states_idmap
|
|
|
|
with
|
|
|
|
| Some state -> state
|
|
|
|
| None ->
|
|
|
|
Message.raise_error
|
|
|
|
"State @{<yellow>\"%s\"@} is not found for variable \
|
|
|
|
@{<yellow>\"%s\"@} of scope @{<yellow>\"%a\"@}"
|
2023-07-12 12:48:46 +03:00
|
|
|
second_part first_part ScopeName.format scope_uid)
|
2023-06-28 16:57:52 +03:00
|
|
|
second_part )
|
2023-04-18 11:31:44 +03:00
|
|
|
|
2023-06-28 16:57:52 +03:00
|
|
|
let get_output ?ext options output_file =
|
2023-09-27 12:01:43 +03:00
|
|
|
let output_file = Option.map options.Cli.path_rewrite output_file in
|
2023-09-26 12:42:46 +03:00
|
|
|
File.get_out_channel ~source_file:options.Cli.input_src ~output_file ?ext ()
|
2023-04-19 19:26:50 +03:00
|
|
|
|
2023-06-28 16:57:52 +03:00
|
|
|
let get_output_format ?ext options output_file =
|
2023-09-27 12:01:43 +03:00
|
|
|
let output_file = Option.map options.Cli.path_rewrite output_file in
|
2023-09-26 12:42:46 +03:00
|
|
|
File.get_formatter_of_out_channel ~source_file:options.Cli.input_src
|
2023-06-28 16:57:52 +03:00
|
|
|
~output_file ?ext ()
|
|
|
|
|
|
|
|
let makefile options output =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = Passes.surface options in
|
2023-06-28 16:57:52 +03:00
|
|
|
let backend_extensions_list = [".tex"] in
|
2023-09-26 12:42:46 +03:00
|
|
|
let source_file = Cli.input_src_file options.Cli.input_src in
|
2023-06-28 16:57:52 +03:00
|
|
|
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);
|
|
|
|
with_output
|
|
|
|
@@ fun oc ->
|
|
|
|
Printf.fprintf oc "%s:\\\n%s\n%s:"
|
|
|
|
(String.concat "\\\n"
|
|
|
|
(Option.value ~default:"stdout" output_file
|
|
|
|
:: List.map
|
|
|
|
(fun ext -> Filename.remove_extension source_file ^ ext)
|
|
|
|
backend_extensions_list))
|
|
|
|
(String.concat "\\\n" prg.Surface.Ast.program_source_files)
|
|
|
|
(String.concat "\\\n" prg.Surface.Ast.program_source_files)
|
|
|
|
|
|
|
|
let makefile_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "makefile"
|
|
|
|
~doc:
|
|
|
|
"Generates a Makefile-compatible list of the file dependencies of a \
|
|
|
|
Catala program.")
|
|
|
|
Term.(const makefile $ Cli.Flags.Global.options $ Cli.Flags.output)
|
|
|
|
|
|
|
|
let html options output print_only_law wrap_weaved_output =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = Passes.surface options in
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "Weaving literate program into HTML";
|
|
|
|
let output_file, with_output =
|
|
|
|
get_output_format options ~ext:".html" output
|
|
|
|
in
|
|
|
|
with_output
|
|
|
|
@@ fun fmt ->
|
2023-09-26 12:42:46 +03:00
|
|
|
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
|
2023-06-28 16:57:52 +03:00
|
|
|
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);
|
|
|
|
if wrap_weaved_output then
|
|
|
|
Literate.Html.wrap_html prg.Surface.Ast.program_source_files language fmt
|
|
|
|
(fun fmt -> weave_output fmt prg)
|
|
|
|
else weave_output fmt prg
|
|
|
|
|
|
|
|
let html_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "html"
|
|
|
|
~doc:
|
|
|
|
"Weaves an HTML literate programming output of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const html
|
|
|
|
$ Cli.Flags.Global.options
|
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.print_only_law
|
|
|
|
$ Cli.Flags.wrap_weaved_output)
|
|
|
|
|
2024-02-15 20:19:04 +03:00
|
|
|
let latex options output print_only_law wrap_weaved_output extra_files =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = Passes.surface options in
|
2024-02-15 20:19:04 +03:00
|
|
|
let prg_annex =
|
|
|
|
List.map
|
|
|
|
(fun f ->
|
|
|
|
Surface.Parser_driver.parse_top_level_file (FileName f)
|
|
|
|
|> Surface.Fill_positions.fill_pos_with_legislative_info)
|
|
|
|
extra_files
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "Weaving literate program into LaTeX";
|
|
|
|
let output_file, with_output =
|
|
|
|
get_output_format options ~ext:".tex" output
|
|
|
|
in
|
|
|
|
with_output
|
|
|
|
@@ fun fmt ->
|
2023-09-26 12:42:46 +03:00
|
|
|
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
|
2023-06-28 16:57:52 +03:00
|
|
|
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);
|
2024-02-15 20:19:04 +03:00
|
|
|
let weave fmt =
|
|
|
|
weave_output fmt prg;
|
|
|
|
List.iter
|
|
|
|
(fun p ->
|
|
|
|
Format.fprintf fmt "@,\\newpage@,";
|
|
|
|
weave_output fmt p)
|
|
|
|
prg_annex
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
if wrap_weaved_output then
|
2024-02-15 20:19:04 +03:00
|
|
|
Literate.Latex.wrap_latex
|
|
|
|
(List.flatten
|
|
|
|
(List.map
|
|
|
|
(fun p -> p.Surface.Ast.program_source_files)
|
|
|
|
(prg :: prg_annex)))
|
|
|
|
language fmt weave
|
|
|
|
else weave fmt
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let latex_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "latex"
|
|
|
|
~doc:
|
|
|
|
"Weaves a LaTeX literate programming output of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const latex
|
|
|
|
$ Cli.Flags.Global.options
|
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.print_only_law
|
2024-02-15 20:19:04 +03:00
|
|
|
$ Cli.Flags.wrap_weaved_output
|
|
|
|
$ Cli.Flags.extra_files)
|
2023-06-28 16:57:52 +03:00
|
|
|
|
2023-09-22 16:37:58 +03:00
|
|
|
let exceptions options includes ex_scope ex_variable =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, ctxt = Passes.desugared options ~includes in
|
|
|
|
Passes.debug_pass_name "scopelang";
|
|
|
|
let exceptions_graphs =
|
|
|
|
Scopelang.From_desugared.build_exceptions_graph prg
|
|
|
|
in
|
|
|
|
let scope_uid = get_scope_uid prg.program_ctx ex_scope in
|
2023-06-28 16:57:52 +03:00
|
|
|
let variable_uid = get_variable_uid ctxt scope_uid ex_variable in
|
|
|
|
Desugared.Print.print_exceptions_graph scope_uid variable_uid
|
|
|
|
(Desugared.Ast.ScopeDef.Map.find variable_uid exceptions_graphs)
|
|
|
|
|
|
|
|
let exceptions_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "exceptions"
|
|
|
|
~doc:
|
|
|
|
"Prints the exception tree for the definitions of a particular \
|
|
|
|
variable, for debugging purposes. Use the $(b,-s) option to select \
|
|
|
|
the scope and the $(b,-v) option to select the variable. Use \
|
|
|
|
foo.bar to access state bar of variable foo or variable bar of \
|
|
|
|
subscope foo.")
|
|
|
|
Term.(
|
|
|
|
const exceptions
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.ex_scope
|
|
|
|
$ Cli.Flags.ex_variable)
|
|
|
|
|
2023-09-22 16:37:58 +03:00
|
|
|
let scopelang options includes output ex_scope_opt =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = Passes.scopelang options ~includes in
|
2023-06-28 16:57:52 +03:00
|
|
|
let _output_file, with_output = get_output_format options output in
|
|
|
|
with_output
|
|
|
|
@@ fun fmt ->
|
|
|
|
match ex_scope_opt with
|
|
|
|
| Some scope ->
|
2023-11-20 18:01:06 +03:00
|
|
|
let scope_uid = get_scope_uid prg.program_ctx scope in
|
2023-06-28 16:57:52 +03:00
|
|
|
Scopelang.Print.scope ~debug:options.Cli.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;
|
|
|
|
Format.pp_print_newline fmt ()
|
|
|
|
|
|
|
|
let scopelang_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "scopelang"
|
|
|
|
~doc:
|
|
|
|
"Prints a debugging verbatim of the scope language intermediate \
|
|
|
|
representation of the Catala program. Use the $(b,-s) option to \
|
|
|
|
restrict the output to a particular scope.")
|
|
|
|
Term.(
|
|
|
|
const scopelang
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.ex_scope_opt)
|
|
|
|
|
2023-12-05 18:50:58 +03:00
|
|
|
let typecheck options check_invariants includes =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg = Passes.scopelang options ~includes in
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "Typechecking...";
|
|
|
|
let _type_ordering =
|
|
|
|
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
|
|
|
|
prg.program_ctx.ctx_enums
|
|
|
|
in
|
|
|
|
let prg = Scopelang.Ast.type_program prg in
|
|
|
|
Message.emit_debug "Translating to default calculus...";
|
|
|
|
(* Strictly type-checking could stop here, but we also want this pass to
|
|
|
|
check full name-resolution and cycle detection. These are checked during
|
|
|
|
translation to dcalc so we run it here and drop the result. *)
|
2023-12-05 18:50:58 +03:00
|
|
|
let prg = Dcalc.From_scopelang.translate_program prg in
|
2023-12-07 15:44:50 +03:00
|
|
|
|
2023-12-05 18:50:58 +03:00
|
|
|
(* Additionally, we might want to check the invariants. *)
|
|
|
|
if check_invariants then (
|
2024-02-07 19:41:04 +03:00
|
|
|
let prg = Shared_ast.Typing.program prg in
|
2023-12-05 18:50:58 +03:00
|
|
|
Message.emit_debug "Checking invariants...";
|
2024-01-26 22:15:32 +03:00
|
|
|
if Dcalc.Invariants.check_all_invariants prg then
|
|
|
|
Message.emit_result "All invariant checks passed"
|
|
|
|
else
|
|
|
|
raise (Message.raise_internal_error "Some Dcalc invariants are invalid"));
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_result "Typechecking successful!"
|
|
|
|
|
|
|
|
let typecheck_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "typecheck"
|
|
|
|
~doc:"Parses and typechecks a Catala program, without interpreting it.")
|
2023-12-05 18:50:58 +03:00
|
|
|
Term.(
|
|
|
|
const typecheck
|
|
|
|
$ Cli.Flags.Global.options
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.include_dirs)
|
2023-06-28 16:57:52 +03:00
|
|
|
|
2023-11-02 16:36:55 +03:00
|
|
|
let dcalc typed options includes output optimize ex_scope_opt check_invariants
|
2023-11-07 20:25:57 +03:00
|
|
|
=
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ =
|
2023-11-02 16:36:55 +03:00
|
|
|
Passes.dcalc options ~includes ~optimize ~check_invariants ~typed
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
let _output_file, with_output = get_output_format options output in
|
|
|
|
with_output
|
|
|
|
@@ fun fmt ->
|
|
|
|
match ex_scope_opt with
|
|
|
|
| Some scope ->
|
2023-11-20 18:01:06 +03:00
|
|
|
let scope_uid = get_scope_uid prg.decl_ctx scope in
|
2023-06-28 16:57:52 +03:00
|
|
|
Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt
|
|
|
|
( scope_uid,
|
2024-02-09 18:48:02 +03:00
|
|
|
BoundList.find
|
|
|
|
~f:(function
|
|
|
|
| ScopeDef (name, body) when ScopeName.equal name scope_uid ->
|
|
|
|
Some body
|
|
|
|
| _ -> None)
|
|
|
|
prg.code_items );
|
2023-06-28 16:57:52 +03:00
|
|
|
Format.pp_print_newline fmt ()
|
|
|
|
| None ->
|
2023-11-20 18:01:06 +03:00
|
|
|
let scope_uid = get_random_scope_uid prg.decl_ctx in
|
2023-06-28 16:57:52 +03:00
|
|
|
(* 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 ())
|
|
|
|
prg_dcalc_expr
|
|
|
|
|
|
|
|
let dcalc_cmd =
|
2023-11-02 16:36:55 +03:00
|
|
|
let f no_typing =
|
|
|
|
if no_typing then dcalc Expr.untyped else dcalc Expr.typed
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "dcalc"
|
|
|
|
~doc:
|
|
|
|
"Prints a debugging verbatim of the default calculus intermediate \
|
|
|
|
representation of the Catala program. Use the $(b,-s) option to \
|
|
|
|
restrict the output to a particular scope.")
|
|
|
|
Term.(
|
2023-11-02 16:36:55 +03:00
|
|
|
const f
|
|
|
|
$ Cli.Flags.no_typing
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.ex_scope_opt
|
|
|
|
$ Cli.Flags.check_invariants)
|
|
|
|
|
|
|
|
let proof
|
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
includes
|
2023-06-28 16:57:52 +03:00
|
|
|
optimize
|
|
|
|
ex_scope_opt
|
|
|
|
check_invariants
|
|
|
|
disable_counterexamples =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ =
|
2023-11-07 20:25:57 +03:00
|
|
|
Passes.dcalc options ~includes ~optimize ~check_invariants
|
|
|
|
~typed:Expr.typed
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
Verification.Globals.setup ~optimize ~disable_counterexamples;
|
|
|
|
let vcs =
|
|
|
|
Verification.Conditions.generate_verification_conditions prg
|
2023-11-20 18:01:06 +03:00
|
|
|
(Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt)
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
Verification.Solver.solve_vc prg.decl_ctx vcs
|
|
|
|
|
|
|
|
let proof_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "proof"
|
|
|
|
~doc:
|
|
|
|
"Generates and proves verification conditions about the \
|
|
|
|
well-behaved execution of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const proof
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.ex_scope_opt
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.disable_counterexamples)
|
|
|
|
|
|
|
|
let print_interpretation_results options interpreter prg scope_uid =
|
|
|
|
Message.emit_debug "Starting interpretation...";
|
2024-02-26 13:23:32 +03:00
|
|
|
let results = interpreter prg scope_uid in
|
2023-06-28 16:57:52 +03:00
|
|
|
Message.emit_debug "End of interpretation";
|
|
|
|
let results =
|
|
|
|
List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results
|
|
|
|
in
|
|
|
|
Message.emit_result "Computation successful!%s"
|
|
|
|
(if List.length results > 0 then " Results:" else "");
|
2023-09-26 12:42:46 +03:00
|
|
|
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
|
2023-06-28 16:57:52 +03:00
|
|
|
List.iter
|
|
|
|
(fun ((var, _), result) ->
|
|
|
|
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
|
2023-07-03 17:38:54 +03:00
|
|
|
(if options.Cli.debug then Print.expr ~debug:false ()
|
2023-09-26 12:42:46 +03:00
|
|
|
else Print.UserFacing.value language)
|
2023-06-28 16:57:52 +03:00
|
|
|
result)
|
|
|
|
results
|
|
|
|
|
2023-11-07 20:25:57 +03:00
|
|
|
let interpret_dcalc typed options includes optimize check_invariants ex_scope
|
|
|
|
=
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ =
|
2023-11-02 16:36:55 +03:00
|
|
|
Passes.dcalc options ~includes ~optimize ~check_invariants ~typed
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-09-27 12:17:26 +03:00
|
|
|
Interpreter.load_runtime_modules prg;
|
2023-06-28 16:57:52 +03:00
|
|
|
print_interpretation_results options Interpreter.interpret_program_dcalc prg
|
2023-11-20 18:01:06 +03:00
|
|
|
(get_scope_uid prg.decl_ctx ex_scope)
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let lcalc
|
2023-11-02 16:36:55 +03:00
|
|
|
typed
|
2023-06-28 16:57:52 +03:00
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
includes
|
2023-06-28 16:57:52 +03:00
|
|
|
output
|
|
|
|
optimize
|
|
|
|
check_invariants
|
|
|
|
avoid_exceptions
|
|
|
|
closure_conversion
|
2023-12-19 17:01:06 +03:00
|
|
|
monomorphize_types
|
2023-06-28 16:57:52 +03:00
|
|
|
ex_scope_opt =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ =
|
2023-09-22 16:37:58 +03:00
|
|
|
Passes.lcalc options ~includes ~optimize ~check_invariants
|
2023-12-19 17:01:06 +03:00
|
|
|
~avoid_exceptions ~closure_conversion ~typed ~monomorphize_types
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
let _output_file, with_output = get_output_format options output in
|
|
|
|
with_output
|
|
|
|
@@ fun fmt ->
|
|
|
|
match ex_scope_opt with
|
|
|
|
| Some scope ->
|
2023-11-20 18:01:06 +03:00
|
|
|
let scope_uid = get_scope_uid prg.decl_ctx scope in
|
2023-06-28 16:57:52 +03:00
|
|
|
Print.scope ~debug:options.Cli.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;
|
|
|
|
Format.pp_print_newline fmt ()
|
|
|
|
|
|
|
|
let lcalc_cmd =
|
2023-11-02 16:36:55 +03:00
|
|
|
let f no_typing =
|
|
|
|
if no_typing then lcalc Expr.untyped else lcalc Expr.typed
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "lcalc"
|
|
|
|
~doc:
|
|
|
|
"Prints a debugging verbatim of the lambda calculus intermediate \
|
|
|
|
representation of the Catala program. Use the $(b,-s) option to \
|
|
|
|
restrict the output to a particular scope.")
|
|
|
|
Term.(
|
2023-11-02 16:36:55 +03:00
|
|
|
const f
|
|
|
|
$ Cli.Flags.no_typing
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.avoid_exceptions
|
|
|
|
$ Cli.Flags.closure_conversion
|
2023-12-19 17:01:06 +03:00
|
|
|
$ Cli.Flags.monomorphize_types
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.ex_scope_opt)
|
|
|
|
|
|
|
|
let interpret_lcalc
|
2023-11-02 16:36:55 +03:00
|
|
|
typed
|
2024-02-22 19:02:00 +03:00
|
|
|
avoid_exceptions
|
|
|
|
closure_conversion
|
|
|
|
monomorphize_types
|
2023-06-28 16:57:52 +03:00
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
includes
|
2023-06-28 16:57:52 +03:00
|
|
|
optimize
|
|
|
|
check_invariants
|
|
|
|
ex_scope =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ =
|
2023-09-22 16:37:58 +03:00
|
|
|
Passes.lcalc options ~includes ~optimize ~check_invariants
|
2023-12-19 17:01:06 +03:00
|
|
|
~avoid_exceptions ~closure_conversion ~monomorphize_types ~typed
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-09-27 12:17:26 +03:00
|
|
|
Interpreter.load_runtime_modules prg;
|
2023-06-28 16:57:52 +03:00
|
|
|
print_interpretation_results options Interpreter.interpret_program_lcalc prg
|
2023-11-20 18:01:06 +03:00
|
|
|
(get_scope_uid prg.decl_ctx ex_scope)
|
2023-06-28 16:57:52 +03:00
|
|
|
|
2024-02-22 19:02:00 +03:00
|
|
|
let interpret_cmd =
|
|
|
|
let f lcalc avoid_exceptions closure_conversion monomorphize_types no_typing
|
|
|
|
=
|
|
|
|
if not lcalc then
|
|
|
|
if avoid_exceptions || closure_conversion || monomorphize_types then
|
|
|
|
Message.raise_error
|
|
|
|
"The flags @{<bold>--avoid-exceptions@}, \
|
|
|
|
@{<bold>--closure-conversion@} and @{<bold>--monomorphize-types@} \
|
|
|
|
only make sense with the @{<bold>--lcalc@} option"
|
|
|
|
else if no_typing then interpret_dcalc Expr.untyped
|
|
|
|
else interpret_dcalc Expr.typed
|
|
|
|
else if no_typing then
|
|
|
|
interpret_lcalc Expr.untyped avoid_exceptions closure_conversion
|
|
|
|
monomorphize_types
|
|
|
|
else
|
|
|
|
interpret_lcalc Expr.typed avoid_exceptions closure_conversion
|
|
|
|
monomorphize_types
|
2023-11-02 16:36:55 +03:00
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
Cmd.v
|
2024-02-22 19:02:00 +03:00
|
|
|
(Cmd.info "interpret"
|
2023-06-28 16:57:52 +03:00
|
|
|
~doc:
|
2024-02-22 19:02:00 +03:00
|
|
|
"Runs the interpreter on the Catala program, executing the scope \
|
|
|
|
specified by the $(b,-s) option assuming no additional external \
|
|
|
|
inputs.")
|
2023-06-28 16:57:52 +03:00
|
|
|
Term.(
|
2023-11-02 16:36:55 +03:00
|
|
|
const f
|
2024-02-22 19:02:00 +03:00
|
|
|
$ Cli.Flags.lcalc
|
|
|
|
$ Cli.Flags.avoid_exceptions
|
|
|
|
$ Cli.Flags.closure_conversion
|
|
|
|
$ Cli.Flags.monomorphize_types
|
2023-11-02 16:36:55 +03:00
|
|
|
$ Cli.Flags.no_typing
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.ex_scope)
|
|
|
|
|
|
|
|
let ocaml
|
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
includes
|
2023-06-28 16:57:52 +03:00
|
|
|
output
|
|
|
|
optimize
|
|
|
|
check_invariants
|
|
|
|
avoid_exceptions
|
2023-12-04 18:41:03 +03:00
|
|
|
ex_scope_opt =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, type_ordering =
|
2023-09-22 16:37:58 +03:00
|
|
|
Passes.lcalc options ~includes ~optimize ~check_invariants
|
2023-12-19 17:01:06 +03:00
|
|
|
~avoid_exceptions ~typed:Expr.typed ~closure_conversion:false
|
|
|
|
~monomorphize_types:false
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
let output_file, with_output =
|
|
|
|
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);
|
2023-12-04 18:41:03 +03:00
|
|
|
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
|
|
|
|
Lcalc.To_ocaml.format_program fmt prg ?exec_scope type_ordering
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let ocaml_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "ocaml"
|
|
|
|
~doc:"Generates an OCaml translation of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const ocaml
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.avoid_exceptions
|
2023-12-04 18:41:03 +03:00
|
|
|
$ Cli.Flags.ex_scope_opt)
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let scalc
|
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
includes
|
2023-06-28 16:57:52 +03:00
|
|
|
output
|
|
|
|
optimize
|
|
|
|
check_invariants
|
|
|
|
avoid_exceptions
|
|
|
|
closure_conversion
|
2023-12-07 18:58:22 +03:00
|
|
|
keep_special_ops
|
2023-12-11 19:08:32 +03:00
|
|
|
dead_value_assignment
|
|
|
|
no_struct_literals
|
2023-12-19 17:01:06 +03:00
|
|
|
monomorphize_types
|
2023-08-05 15:28:18 +03:00
|
|
|
ex_scope_opt =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, _ =
|
2023-09-22 16:37:58 +03:00
|
|
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
2023-12-07 18:58:22 +03:00
|
|
|
~avoid_exceptions ~closure_conversion ~keep_special_ops
|
2023-12-19 17:01:06 +03:00
|
|
|
~dead_value_assignment ~no_struct_literals ~monomorphize_types
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
|
|
|
let _output_file, with_output = get_output_format options output in
|
|
|
|
with_output
|
|
|
|
@@ fun fmt ->
|
|
|
|
match ex_scope_opt with
|
|
|
|
| Some scope ->
|
2024-02-22 14:14:25 +03:00
|
|
|
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
|
2023-06-28 16:57:52 +03:00
|
|
|
(List.find
|
|
|
|
(function
|
|
|
|
| Scalc.Ast.SScope { scope_body_name; _ } ->
|
|
|
|
scope_body_name = scope_uid
|
|
|
|
| _ -> false)
|
|
|
|
prg.code_items);
|
|
|
|
Format.pp_print_newline fmt ()
|
2024-02-22 14:14:25 +03:00
|
|
|
| None -> Scalc.Print.format_program fmt prg
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let scalc_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "scalc"
|
|
|
|
~doc:
|
|
|
|
"Prints a debugging verbatim of the statement calculus intermediate \
|
|
|
|
representation of the Catala program. Use the $(b,-s) option to \
|
|
|
|
restrict the output to a particular scope.")
|
|
|
|
Term.(
|
|
|
|
const scalc
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.avoid_exceptions
|
|
|
|
$ Cli.Flags.closure_conversion
|
2023-12-07 18:58:22 +03:00
|
|
|
$ Cli.Flags.keep_special_ops
|
2023-12-11 19:08:32 +03:00
|
|
|
$ Cli.Flags.dead_value_assignment
|
|
|
|
$ Cli.Flags.no_struct_literals
|
2023-12-19 17:01:06 +03:00
|
|
|
$ Cli.Flags.monomorphize_types
|
2023-08-05 15:28:18 +03:00
|
|
|
$ Cli.Flags.ex_scope_opt)
|
2023-06-28 16:57:52 +03:00
|
|
|
|
|
|
|
let python
|
|
|
|
options
|
2023-09-22 16:37:58 +03:00
|
|
|
includes
|
2023-06-28 16:57:52 +03:00
|
|
|
output
|
|
|
|
optimize
|
|
|
|
check_invariants
|
|
|
|
avoid_exceptions
|
|
|
|
closure_conversion =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, type_ordering =
|
2023-09-22 16:37:58 +03:00
|
|
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
2023-12-07 18:58:22 +03:00
|
|
|
~avoid_exceptions ~closure_conversion ~keep_special_ops:false
|
2023-12-11 19:08:32 +03:00
|
|
|
~dead_value_assignment:true ~no_struct_literals:false
|
2023-12-19 17:01:06 +03:00
|
|
|
~monomorphize_types:false
|
2023-06-28 16:57:52 +03:00
|
|
|
in
|
2023-08-05 15:28:18 +03:00
|
|
|
|
2023-06-28 16:57:52 +03:00
|
|
|
let output_file, with_output =
|
|
|
|
get_output_format options ~ext:".py" output
|
|
|
|
in
|
|
|
|
Message.emit_debug "Compiling program into Python...";
|
|
|
|
Message.emit_debug "Writing to %s..."
|
|
|
|
(Option.value ~default:"stdout" output_file);
|
|
|
|
with_output
|
|
|
|
@@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
|
|
|
|
|
|
|
|
let python_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "python"
|
|
|
|
~doc:"Generates a Python translation of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const python
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-06-28 16:57:52 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.avoid_exceptions
|
|
|
|
$ Cli.Flags.closure_conversion)
|
|
|
|
|
2023-09-22 16:37:58 +03:00
|
|
|
let r options includes output optimize check_invariants closure_conversion =
|
2023-11-20 18:01:06 +03:00
|
|
|
let prg, type_ordering =
|
2023-09-22 16:37:58 +03:00
|
|
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
2023-12-07 18:58:22 +03:00
|
|
|
~avoid_exceptions:false ~closure_conversion ~keep_special_ops:false
|
2023-12-11 19:08:32 +03:00
|
|
|
~dead_value_assignment:false ~no_struct_literals:false
|
2023-12-19 17:01:06 +03:00
|
|
|
~monomorphize_types:false
|
2023-08-04 18:25:12 +03:00
|
|
|
in
|
2023-08-05 15:28:18 +03:00
|
|
|
|
2023-08-04 18:25:12 +03:00
|
|
|
let output_file, with_output = get_output_format options ~ext:".r" output in
|
|
|
|
Message.emit_debug "Compiling program into R...";
|
|
|
|
Message.emit_debug "Writing to %s..."
|
|
|
|
(Option.value ~default:"stdout" output_file);
|
|
|
|
with_output @@ fun fmt -> Scalc.To_r.format_program fmt prg type_ordering
|
|
|
|
|
|
|
|
let r_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "r" ~doc:"Generates an R translation of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const r
|
|
|
|
$ Cli.Flags.Global.options
|
2023-09-27 12:01:43 +03:00
|
|
|
$ Cli.Flags.include_dirs
|
2023-08-04 18:25:12 +03:00
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants
|
|
|
|
$ Cli.Flags.closure_conversion)
|
|
|
|
|
2023-11-28 14:07:23 +03:00
|
|
|
let c options includes output optimize check_invariants =
|
2023-12-07 16:08:43 +03:00
|
|
|
let prg, type_ordering =
|
2023-11-28 14:07:23 +03:00
|
|
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
2023-12-07 18:58:22 +03:00
|
|
|
~avoid_exceptions:true ~closure_conversion:true ~keep_special_ops:true
|
2023-12-11 19:08:32 +03:00
|
|
|
~dead_value_assignment:false ~no_struct_literals:true
|
2023-12-19 17:01:06 +03:00
|
|
|
~monomorphize_types:true
|
2023-11-28 14:07:23 +03:00
|
|
|
in
|
|
|
|
let output_file, with_output = get_output_format options ~ext:".c" output in
|
|
|
|
Message.emit_debug "Compiling program into C...";
|
|
|
|
Message.emit_debug "Writing to %s..."
|
|
|
|
(Option.value ~default:"stdout" output_file);
|
|
|
|
with_output @@ fun fmt -> Scalc.To_c.format_program fmt prg type_ordering
|
|
|
|
|
|
|
|
let c_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "c" ~doc:"Generates an C translation of the Catala program.")
|
|
|
|
Term.(
|
|
|
|
const c
|
|
|
|
$ Cli.Flags.Global.options
|
|
|
|
$ Cli.Flags.include_dirs
|
|
|
|
$ Cli.Flags.output
|
|
|
|
$ Cli.Flags.optimize
|
|
|
|
$ Cli.Flags.check_invariants)
|
|
|
|
|
2024-03-12 16:32:59 +03:00
|
|
|
let depends options includes prefix extension extra_files =
|
|
|
|
let prg =
|
|
|
|
let file = Cli.input_src_file options.Cli.input_src in
|
|
|
|
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
|
2024-03-05 19:54:53 +03:00
|
|
|
let mod_uses, modules = load_module_interfaces options includes prg in
|
|
|
|
let d_ctx =
|
|
|
|
Desugared.Name_resolution.form_context (prg, mod_uses) modules
|
|
|
|
in
|
|
|
|
let prg = Desugared.From_surface.translate_program d_ctx prg in
|
|
|
|
let modules_list_topo =
|
|
|
|
Program.modules_to_list prg.program_ctx.ctx_modules
|
|
|
|
in
|
|
|
|
Format.open_hbox ();
|
|
|
|
Format.pp_print_list ~pp_sep:Format.pp_print_space
|
|
|
|
(fun ppf m ->
|
|
|
|
let f = Pos.get_file (Mark.get (ModuleName.get_info m)) in
|
|
|
|
let f =
|
|
|
|
match prefix with
|
|
|
|
| None -> f
|
|
|
|
| Some pfx ->
|
|
|
|
if not (Filename.is_relative f) then (
|
|
|
|
Message.emit_warning
|
|
|
|
"Not adding prefix to %s, which is an absolute path" f;
|
|
|
|
f)
|
|
|
|
else File.(pfx / f)
|
|
|
|
in
|
|
|
|
let f =
|
|
|
|
match extension with None -> f | Some ext -> File.(f -.- ext)
|
|
|
|
in
|
|
|
|
Format.pp_print_string ppf f)
|
|
|
|
Format.std_formatter modules_list_topo;
|
|
|
|
Format.close_box ();
|
|
|
|
Format.print_newline ()
|
|
|
|
|
|
|
|
let depends_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "depends"
|
|
|
|
~doc:
|
2024-03-12 16:32:59 +03:00
|
|
|
"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.")
|
2024-03-05 19:54:53 +03:00
|
|
|
Term.(
|
|
|
|
const depends
|
|
|
|
$ Cli.Flags.Global.options
|
|
|
|
$ Cli.Flags.include_dirs
|
|
|
|
$ Cli.Flags.prefix
|
2024-03-12 16:32:59 +03:00
|
|
|
$ Cli.Flags.extension
|
|
|
|
$ Cli.Flags.extra_files)
|
2024-03-05 19:54:53 +03:00
|
|
|
|
2023-06-28 16:57:52 +03:00
|
|
|
let pygmentize_cmd =
|
|
|
|
Cmd.v
|
|
|
|
(Cmd.info "pygmentize"
|
|
|
|
~doc:
|
|
|
|
"This special command is a wrapper around the $(b,pygmentize) \
|
|
|
|
command that enables support for colorising Catala code.")
|
|
|
|
Term.(
|
|
|
|
const (fun _ ->
|
|
|
|
assert false
|
|
|
|
(* Not really a catala command, this is handled preemptively at
|
|
|
|
startup *))
|
|
|
|
$ Cli.Flags.Global.options)
|
|
|
|
|
|
|
|
let commands =
|
|
|
|
[
|
|
|
|
interpret_cmd;
|
|
|
|
typecheck_cmd;
|
|
|
|
proof_cmd;
|
|
|
|
ocaml_cmd;
|
|
|
|
python_cmd;
|
2023-08-04 18:25:12 +03:00
|
|
|
r_cmd;
|
2023-11-28 14:07:23 +03:00
|
|
|
c_cmd;
|
2023-06-28 16:57:52 +03:00
|
|
|
latex_cmd;
|
|
|
|
html_cmd;
|
|
|
|
makefile_cmd;
|
|
|
|
scopelang_cmd;
|
|
|
|
dcalc_cmd;
|
|
|
|
lcalc_cmd;
|
|
|
|
scalc_cmd;
|
|
|
|
exceptions_cmd;
|
2024-03-05 19:54:53 +03:00
|
|
|
depends_cmd;
|
2023-06-28 16:57:52 +03:00
|
|
|
pygmentize_cmd;
|
|
|
|
]
|
|
|
|
end
|
|
|
|
|
|
|
|
let raise_help cmdname cmds =
|
|
|
|
let plugins = Plugin.names () in
|
|
|
|
let cmds = List.filter (fun name -> not (List.mem name plugins)) cmds in
|
|
|
|
Message.raise_error
|
|
|
|
"One of the following commands was expected:@;\
|
|
|
|
<1 4>@[<v>@{<bold;blue>%a@}@]%a@\n\
|
|
|
|
Run `@{<bold>%s --help@}' or `@{<bold>%s COMMAND --help@}' for details."
|
|
|
|
(Format.pp_print_list Format.pp_print_string)
|
|
|
|
(List.sort String.compare cmds)
|
|
|
|
(fun ppf -> function
|
|
|
|
| [] -> ()
|
|
|
|
| plugins ->
|
|
|
|
Format.fprintf ppf
|
|
|
|
"@\n\
|
|
|
|
Or one of the following installed plugins:@;\
|
|
|
|
<1 4>@[<v>@{<blue>%a@}@]"
|
|
|
|
(Format.pp_print_list Format.pp_print_string)
|
|
|
|
plugins)
|
|
|
|
plugins cmdname cmdname
|
|
|
|
|
|
|
|
let catala_t extra_commands =
|
|
|
|
let open Cmdliner in
|
|
|
|
let default =
|
|
|
|
Term.(const raise_help $ main_name $ choice_names $ Cli.Flags.Global.flags)
|
|
|
|
in
|
|
|
|
Cmd.group ~default Cli.info (Commands.commands @ extra_commands)
|
2020-03-08 03:52:31 +03:00
|
|
|
|
2020-12-26 19:37:41 +03:00
|
|
|
let main () =
|
2023-06-15 18:37:52 +03:00
|
|
|
let argv = Array.copy Sys.argv in
|
|
|
|
(* Our command names (first argument) are case-insensitive *)
|
|
|
|
if Array.length argv >= 2 then argv.(1) <- String.lowercase_ascii argv.(1);
|
|
|
|
(* Pygmentize is a specific exec subcommand that doesn't go through
|
|
|
|
cmdliner *)
|
|
|
|
if Array.length Sys.argv >= 2 && argv.(1) = "pygmentize" then
|
|
|
|
Literate.Pygmentize.exec ();
|
2023-06-28 16:57:52 +03:00
|
|
|
(* Peek to load plugins before the command-line is parsed proper (plugins add
|
|
|
|
their own commands) *)
|
2023-06-15 18:37:52 +03:00
|
|
|
let plugins =
|
|
|
|
let plugins_dirs =
|
|
|
|
match
|
2023-06-28 16:57:52 +03:00
|
|
|
Cmdliner.Cmd.eval_peek_opts ~argv Cli.Flags.Global.flags
|
|
|
|
~version_opt:true
|
2023-06-15 18:37:52 +03:00
|
|
|
with
|
2023-06-28 16:57:52 +03:00
|
|
|
| Some opts, _ -> opts.Cli.plugins_dirs
|
2023-06-15 18:37:52 +03:00
|
|
|
| None, _ -> []
|
|
|
|
in
|
2023-09-01 11:43:46 +03:00
|
|
|
Passes.debug_pass_name "init";
|
2023-06-15 18:37:52 +03:00
|
|
|
List.iter
|
|
|
|
(fun d ->
|
2023-07-03 17:38:54 +03:00
|
|
|
if d = "" then ()
|
|
|
|
else
|
|
|
|
match Sys.is_directory d with
|
|
|
|
| true -> Plugin.load_dir d
|
|
|
|
| false -> Message.emit_debug "Could not read plugin directory %s" d
|
|
|
|
| exception Sys_error _ ->
|
|
|
|
Message.emit_debug "Could not read plugin directory %s" d)
|
2023-06-15 18:37:52 +03:00
|
|
|
plugins_dirs;
|
2023-06-28 16:57:52 +03:00
|
|
|
Dynlink.allow_only ["Runtime_ocaml__Runtime"];
|
|
|
|
(* We may use dynlink again, but only for runtime modules: no plugin
|
|
|
|
registration after this point *)
|
2023-06-15 18:37:52 +03:00
|
|
|
Plugin.list ()
|
|
|
|
in
|
2023-06-28 16:57:52 +03:00
|
|
|
let command = catala_t plugins in
|
|
|
|
let open Cmdliner in
|
|
|
|
match Cmd.eval_value ~catch:false ~argv command with
|
|
|
|
| Ok _ -> exit Cmd.Exit.ok
|
2024-02-21 14:06:38 +03:00
|
|
|
| Error e ->
|
|
|
|
if e = `Term then Plugin.print_failures ();
|
|
|
|
exit Cmd.Exit.cli_error
|
2023-06-28 16:57:52 +03:00
|
|
|
| exception Cli.Exit_with n -> exit n
|
|
|
|
| exception Message.CompilerError content ->
|
|
|
|
let bt = Printexc.get_raw_backtrace () in
|
2023-06-19 18:08:16 +03:00
|
|
|
Message.Content.emit content Error;
|
2023-06-28 16:57:52 +03:00
|
|
|
if Cli.globals.debug then Printexc.print_raw_backtrace stderr bt;
|
|
|
|
exit Cmd.Exit.some_error
|
2023-12-20 19:43:31 +03:00
|
|
|
| exception Failure msg ->
|
|
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
|
|
Message.Content.emit (Message.Content.of_string msg) Error;
|
|
|
|
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
|
|
|
|
exit Cmd.Exit.some_error
|
2023-06-28 16:57:52 +03:00
|
|
|
| exception Sys_error msg ->
|
|
|
|
let bt = Printexc.get_raw_backtrace () in
|
2023-06-19 18:08:16 +03:00
|
|
|
Message.Content.emit
|
2023-06-28 16:57:52 +03:00
|
|
|
(Message.Content.of_string ("System error: " ^ msg))
|
|
|
|
Error;
|
|
|
|
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
|
|
|
|
exit Cmd.Exit.internal_error
|
|
|
|
| exception e ->
|
|
|
|
let bt = Printexc.get_raw_backtrace () in
|
2023-06-19 18:08:16 +03:00
|
|
|
Message.Content.emit
|
2023-06-28 16:57:52 +03:00
|
|
|
(Message.Content.of_string ("Unexpected error: " ^ Printexc.to_string e))
|
|
|
|
Error;
|
|
|
|
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
|
|
|
|
exit Cmd.Exit.internal_error
|
2022-03-04 20:32:03 +03:00
|
|
|
|
|
|
|
(* Export module PluginAPI, hide parent module Plugin *)
|
2023-06-15 18:37:52 +03:00
|
|
|
module Plugin = struct
|
2023-06-28 16:57:52 +03:00
|
|
|
let register name ?man ?doc term =
|
|
|
|
let name = String.lowercase_ascii name in
|
|
|
|
let info = Cmdliner.Cmd.info name ?man ?doc ~docs:Cli.s_plugins in
|
|
|
|
Plugin.register info term
|
2023-06-15 18:37:52 +03:00
|
|
|
end
|