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
< emile . rolley @ tuta . io >
2020-03-08 02:21:55 +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 . * )
2023-06-28 16:57:52 +03:00
(* Types used by flags & options *)
2021-01-09 23:03:32 +03:00
2023-09-26 12:42:46 +03:00
type file = string
2023-09-27 12:01:43 +03:00
type raw_file = file
2023-06-28 16:57:52 +03:00
type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU
2023-09-26 12:42:46 +03:00
type input_src =
| FileName of file
| Contents of string * file
| Stdin of file
2022-03-04 20:32:03 +03:00
2023-03-13 15:40:10 +03:00
(* * Associates a {!type: Cli.backend_lang} with its string represtation. *)
let languages = [ " en " , En ; " fr " , Fr ; " pl " , Pl ]
let language_code =
let rl = List . map ( fun ( a , b ) -> b , a ) languages in
fun l -> List . assoc l rl
2023-09-26 12:42:46 +03:00
let input_src_file = function
| FileName f | Contents ( _ , f ) | Stdin f -> f
2023-06-28 16:57:52 +03:00
let message_format_opt = [ " human " , Human ; " gnu " , GNU ]
type options = {
2023-09-26 12:42:46 +03:00
mutable input_src : input_src ;
2023-06-28 16:57:52 +03:00
mutable language : backend_lang option ;
mutable debug : bool ;
mutable color : when_enum ;
mutable message_format : message_format_enum ;
mutable trace : bool ;
2023-09-26 12:42:46 +03:00
mutable plugins_dirs : file list ;
2023-06-28 16:57:52 +03:00
mutable disable_warnings : bool ;
mutable max_prec_digits : int ;
2023-09-27 12:01:43 +03:00
mutable path_rewrite : raw_file -> file ;
2023-06-28 16:57:52 +03:00
}
2023-04-17 19:00:30 +03:00
2023-06-28 16:57:52 +03:00
(* Note: we force that the global options ( ie options common to all commands )
and the options available through global refs are the same . While this is a
bit arbitrary , it makes some sense code - wise and provides some safeguard
against explosion of the number of global references . Reducing the number of
globals further would be nice though . * )
let globals =
{
2023-09-26 12:42:46 +03:00
input_src = Stdin " -stdin- " ;
2023-06-28 16:57:52 +03:00
language = None ;
debug = false ;
color = Auto ;
message_format = Human ;
trace = false ;
plugins_dirs = [] ;
disable_warnings = false ;
max_prec_digits = 20 ;
2023-09-27 12:01:43 +03:00
path_rewrite = ( fun _ -> assert false ) ;
2023-06-28 16:57:52 +03:00
}
let enforce_globals
2023-09-26 12:42:46 +03:00
? input_src
2023-06-28 16:57:52 +03:00
? language
? debug
? color
? message_format
? trace
? plugins_dirs
? disable_warnings
? max_prec_digits
2023-09-27 12:01:43 +03:00
? path_rewrite
2023-06-28 16:57:52 +03:00
() =
2023-09-26 12:42:46 +03:00
Option . iter ( fun x -> globals . input_src <- x ) input_src ;
2023-06-28 16:57:52 +03:00
Option . iter ( fun x -> globals . language <- x ) language ;
Option . iter ( fun x -> globals . debug <- x ) debug ;
Option . iter ( fun x -> globals . color <- x ) color ;
Option . iter ( fun x -> globals . message_format <- x ) message_format ;
Option . iter ( fun x -> globals . trace <- x ) trace ;
Option . iter ( fun x -> globals . plugins_dirs <- x ) plugins_dirs ;
Option . iter ( fun x -> globals . disable_warnings <- x ) disable_warnings ;
Option . iter ( fun x -> globals . max_prec_digits <- x ) max_prec_digits ;
2023-09-27 12:01:43 +03:00
Option . iter ( fun x -> globals . path_rewrite <- x ) path_rewrite ;
2023-06-28 16:57:52 +03:00
globals
2023-04-17 19:00:30 +03:00
2020-03-08 03:52:31 +03:00
open Cmdliner
2023-06-28 16:57:52 +03:00
(* Arg converters for our custom types *)
2020-03-08 03:52:31 +03:00
2022-07-26 15:52:02 +03:00
let when_opt = Arg . enum [ " auto " , Auto ; " always " , Always ; " never " , Never ]
2023-09-26 12:42:46 +03:00
(* Some helpers for catala sources *)
let extensions = [ " .catala_fr " , Fr ; " .catala_en " , En ; " .catala_pl " , Pl ]
let file_lang filename =
List . assoc_opt ( Filename . extension filename ) extensions
| > function
| Some lang -> lang
| None -> (
match globals . language with
| Some lang -> lang
| None ->
Format . kasprintf failwith
" Could not infer language variant from the extension of \
@ {< yellow > % s @ } , and @ {< bold > - - language @ } was not specified "
filename )
2023-09-27 12:01:43 +03:00
(* * If [to_dir] is a path to a given directory and [f] a path to a file as seen from absolute path [from_dir], [reverse_path ~from_dir ~to_dir f] is a path leading to [f] from [to_dir]. The results attempts to be relative to [to_dir]. *)
let reverse_path ? ( from_dir = Sys . getcwd () ) ~ to_dir f =
if Filename . is_relative from_dir then invalid_arg " File.with_reverse_path " else
if not ( Filename . is_relative f ) then f else
if not ( Filename . is_relative to_dir ) then Filename . concat from_dir f else
let rec aux acc rbase = function
| [] -> acc
| dir :: p ->
if dir = Filename . parent_dir_name then match rbase with
| base1 :: rbase -> aux ( base1 :: acc ) rbase p
| [] -> aux acc [] p
else
match acc with
| dir1 :: acc when dir1 = dir -> aux acc rbase p
| _ -> aux ( Filename . parent_dir_name :: acc ) rbase p
in
let path_to_list path =
String . split_on_char Filename . dir_sep . [ 0 ] path
| > List . filter ( function " " | " . " -> false | _ -> true )
in
let rbase = List . rev ( path_to_list ( from_dir ) ) in
String . concat Filename . dir_sep ( aux ( path_to_list f ) rbase ( path_to_list to_dir ) )
2023-06-28 16:57:52 +03:00
(* * CLI flags and options *)
module Flags = struct
open Cmdliner
open Arg
module Global = struct
let info = info ~ docs : Manpage . s_common_options
2023-09-26 12:42:46 +03:00
let input_src =
2023-06-28 16:57:52 +03:00
let converter =
conv ~ docv : " FILE "
( ( fun s ->
2023-09-26 12:42:46 +03:00
if s = " - " then Ok ( Stdin " -stdin- " ) else
Result . map ( fun f -> FileName f ) ( conv_parser non_dir_file s ) ) ,
2023-06-28 16:57:52 +03:00
fun ppf -> function
2023-09-26 12:42:46 +03:00
| Stdin _ -> Format . pp_print_string ppf " - "
2023-06-28 16:57:52 +03:00
| FileName f -> conv_printer non_dir_file ppf f
| _ -> assert false )
in
required
2023-09-22 16:37:58 +03:00
& pos ~ rev : true 0 ( some converter ) None
2023-06-28 16:57:52 +03:00
& Arg . info [] ~ docv : " FILE " ~ docs : Manpage . s_arguments
2023-09-26 12:42:46 +03:00
~ doc : " Catala master file to be compiled ($(b,-) for stdin). "
2023-06-28 16:57:52 +03:00
let language =
value
& opt ( some ( enum languages ) ) None
& info [ " l " ; " language " ] ~ docv : " LANG "
~ doc :
" Locale variant of the input language to use when it can not be \
inferred from the file extension . "
let debug =
value
& flag
& info [ " debug " ; " d " ]
~ env : ( Cmd . Env . info " CATALA_DEBUG " )
~ doc : " Prints debug information. "
let color =
let unstyled =
value
& flag
& info [ " unstyled " ]
~ doc : " Removes styling (colors, etc.) from terminal output. "
~ deprecated : " Use $(b,--color=)$(i,never) instead "
in
let color =
value
& opt ~ vopt : Always when_opt Auto
& info [ " color " ]
~ env : ( Cmd . Env . info " CATALA_COLOR " )
~ doc :
" Allow output of colored and styled text. Use $(i,auto), to \
enable when the standard output is to a terminal , $ ( i , never ) to \
disable . "
in
Term . (
const ( fun color unstyled -> if unstyled then Never else color )
$ color
$ unstyled )
let message_format =
value
& opt ( enum message_format_opt ) Human
& info [ " message_format " ]
~ doc :
" Selects the format of error and warning messages emitted by the \
compiler . If set to $ ( i , human ) , the messages will be nicely \
displayed and meant to be read by a human . If set to $ ( i , gnu ) , \
the messages will be rendered according to the GNU coding \
standards . "
let trace =
value
& flag
& info [ " trace " ; " t " ]
~ doc :
" Displays a trace of the interpreter's computation or generates \
logging instructions in translate programs . "
let plugins_dirs =
let doc = " Set the given directory to be searched for backend plugins. " in
let env = Cmd . Env . info " CATALA_PLUGINS " in
let default =
let ( / ) = Filename . concat in
2023-09-01 18:09:31 +03:00
let exec_dir = Filename . ( dirname Sys . argv . ( 0 ) ) in
let dev_plugin_dir = exec_dir / " plugins " in
if Sys . file_exists dev_plugin_dir then
(* When running tests in place, may need to lookup in _build/default
besides the exec * )
[ dev_plugin_dir ]
else
(* Otherwise, assume a standard layout: "<prefix>/bin/catala" besides
" <prefix>/lib/catala " * )
[ Filename . ( dirname exec_dir ) / " lib " / " catala " / " plugins " ]
2023-06-28 16:57:52 +03:00
in
2023-07-03 17:38:54 +03:00
value & opt_all string default & info [ " plugin-dir " ] ~ docv : " DIR " ~ env ~ doc
2023-06-28 16:57:52 +03:00
let disable_warnings =
value
& flag
& info [ " disable_warnings " ]
~ doc : " Disable all the warnings emitted by the compiler. "
let max_prec_digits =
value
& opt int 20
& info
[ " p " ; " max_digits_printed " ]
~ docv : " NUM "
~ doc :
" Maximum number of significant digits printed for decimal results. "
2023-09-26 12:42:46 +03:00
let name_flag =
value
& opt ( some string ) None
& info [ " name " ] ~ docv : " FILE "
~ doc : " Treat the input as coming from a file with the given name. Useful e.g. when reading from stdin "
2023-09-27 12:01:43 +03:00
let directory =
value
& opt ( some dir ) None
& info [ " C " ; " directory " ] ~ docv : " DIR "
~ doc : " Behave as if run from the given directory for file and error reporting. Does not affect resolution of files in arguments. "
2023-06-28 16:57:52 +03:00
let flags =
let make
language
debug
color
message_format
trace
plugins_dirs
disable_warnings
2023-09-27 12:01:43 +03:00
max_prec_digits
directory : options =
2023-06-28 16:57:52 +03:00
if debug then Printexc . record_backtrace true ;
2023-09-27 12:01:43 +03:00
let path_rewrite =
match directory with
| None -> fun f -> f
| Some to_dir -> function
| " - " -> " - "
| f -> reverse_path ~ to_dir f
in
2023-06-28 16:57:52 +03:00
(* This sets some global refs for convenience, but most importantly
returns the options record . * )
enforce_globals ~ language ~ debug ~ color ~ message_format ~ trace
2023-09-27 12:01:43 +03:00
~ plugins_dirs ~ disable_warnings ~ max_prec_digits ~ path_rewrite ()
2023-06-28 16:57:52 +03:00
in
Term . (
const make
$ language
$ debug
$ color
$ message_format
$ trace
$ plugins_dirs
$ disable_warnings
2023-09-27 12:01:43 +03:00
$ max_prec_digits
$ directory )
2023-06-28 16:57:52 +03:00
let options =
2023-09-27 12:01:43 +03:00
let make input_src name directory options : options =
2023-06-28 16:57:52 +03:00
(* Set some global refs for convenience *)
2023-09-26 12:42:46 +03:00
let input_src =
match name with
| None -> input_src
| Some name ->
match input_src with
| FileName f -> FileName f
| Contents ( str , _ ) -> Contents ( str , name )
| Stdin _ -> Stdin name
in
2023-09-27 12:01:43 +03:00
let input_src =
match input_src with
| FileName f -> FileName ( options . path_rewrite f )
| Contents ( str , f ) -> Contents ( str , ( options . path_rewrite f ) )
| Stdin f -> Stdin ( options . path_rewrite f )
in
let plugins_dirs = List . map options . path_rewrite options . plugins_dirs in
Option . iter Sys . chdir directory ;
2023-09-26 12:42:46 +03:00
globals . input_src <- input_src ;
2023-09-27 12:01:43 +03:00
globals . plugins_dirs <- plugins_dirs ;
{ options with input_src ; plugins_dirs }
2023-06-28 16:57:52 +03:00
in
2023-09-27 12:01:43 +03:00
Term . ( const make $ input_src $ name_flag $ directory $ flags )
2023-06-28 16:57:52 +03:00
end
2023-09-22 16:37:58 +03:00
let include_dirs =
value
& opt_all string []
& info [ " I " ; " include " ] ~ docv : " DIR "
~ doc :
" Include directory to lookup for compiled module files. "
2023-06-28 16:57:52 +03:00
let check_invariants =
2022-04-04 18:43:30 +03:00
value
& flag
2023-06-28 16:57:52 +03:00
& info [ " check_invariants " ] ~ doc : " Check structural invariants on the AST. "
2022-04-04 18:43:30 +03:00
2023-06-28 16:57:52 +03:00
let wrap_weaved_output =
2020-04-29 10:55:49 +03:00
value
& flag
2022-01-19 13:20:25 +03:00
& info [ " wrap " ; " w " ]
2023-06-28 16:57:52 +03:00
~ doc : " Wraps literate programming output with a minimal preamble. "
2020-04-17 13:29:30 +03:00
2023-06-28 16:57:52 +03:00
let print_only_law =
2022-05-26 20:05:06 +03:00
value
& flag
& info [ " print_only_law " ]
~ doc :
" In literate programming output, skip all code and metadata sections \
2023-06-28 16:57:52 +03:00
and print only the text of the law . "
2022-03-04 20:32:03 +03:00
2023-06-28 16:57:52 +03:00
let ex_scope =
required
2020-04-19 20:25:46 +03:00
& opt ( some string ) None
2023-06-28 16:57:52 +03:00
& info [ " s " ; " scope " ] ~ docv : " SCOPE " ~ doc : " Scope to be focused on. "
2022-01-26 18:24:09 +03:00
2023-06-28 16:57:52 +03:00
let ex_scope_opt =
2022-01-19 13:20:25 +03:00
value
& opt ( some string ) None
2023-06-28 16:57:52 +03:00
& info [ " s " ; " scope " ] ~ docv : " SCOPE " ~ doc : " Scope to be focused on. "
2020-08-06 16:44:51 +03:00
2023-06-28 16:57:52 +03:00
let ex_variable =
required
2023-04-07 13:39:26 +03:00
& opt ( some string ) None
2023-06-28 16:57:52 +03:00
& info [ " v " ; " variable " ] ~ docv : " VARIABLE " ~ doc : " Variable to be focused on. "
2023-04-07 13:39:26 +03:00
2023-06-28 16:57:52 +03:00
let output =
2020-04-19 19:39:16 +03:00
value
2020-03-08 03:52:31 +03:00
& opt ( some string ) None
& info [ " output " ; " o " ] ~ docv : " OUTPUT "
2023-09-27 12:01:43 +03:00
~ env : ( Cmd . Env . info " CATALA_OUT " )
~ doc :
" $(i, OUTPUT) is the file that will contain the output of the \
compiler . Defaults to $ ( i , FILE ) . $ ( i , EXT ) where $ ( i , EXT ) depends on \
the chosen backend . Use $ ( b , - o - ) for stdout . "
2023-06-28 16:57:52 +03:00
let optimize =
value & flag & info [ " optimize " ; " O " ] ~ doc : " Run compiler optimizations. "
let avoid_exceptions =
value
& flag
& info [ " avoid_exceptions " ]
~ doc : " Compiles the default calculus without exceptions. "
2020-03-08 03:52:31 +03:00
2023-06-28 16:57:52 +03:00
let closure_conversion =
value
& flag
& info [ " closure_conversion " ]
~ doc :
" Performs closure conversion on the lambda calculus. Implies \
$ ( b , - - avoid - exceptions ) and $ ( b , - - optimize ) . "
let disable_counterexamples =
value
& flag
& info
[ " disable_counterexamples " ]
~ doc :
" Disables the search for counterexamples. Useful when you want a \
deterministic output from the Catala compiler , since provers can \
have some randomness in them . "
2023-09-22 16:37:58 +03:00
2023-06-28 16:57:52 +03:00
end
2023-06-15 18:37:52 +03:00
2023-09-12 11:32:35 +03:00
(* Retrieve current version from dune *)
let version =
Option . value ~ default : " dev "
Build_info . V1 . ( Option . map Version . to_string ( version () ) )
2023-06-28 16:57:52 +03:00
let s_plugins = " INSTALLED PLUGINS "
2020-12-26 19:37:41 +03:00
2020-03-08 03:52:31 +03:00
let info =
let doc =
2020-04-16 18:47:35 +03:00
" Compiler for Catala, a specification language for tax and social benefits \
computation rules . "
2020-03-08 03:52:31 +03:00
in
let man =
[
2023-06-28 16:57:52 +03:00
` S Manpage . s_synopsis ;
` P " $(mname) [$(i,COMMAND)] $(i,FILE) [$(i,OPTION)]… " ;
` P
" Use $(mname) [$(i,COMMAND)] $(b,--hel)p for documentation on a \
specific command " ;
2020-03-08 03:52:31 +03:00
` S Manpage . s_description ;
` P
2020-04-19 20:04:11 +03:00
" Catala is a domain-specific language for deriving \
faithful - by - construction algorithms from legislative texts . " ;
2023-06-28 16:57:52 +03:00
` S Manpage . s_commands ;
` S s_plugins ;
2020-03-08 03:52:31 +03:00
` S Manpage . s_authors ;
2023-06-28 16:57:52 +03:00
` P " The authors are listed by alphabetical order: " ;
` P " Nicolas Chataing <$(i,nicolas.chataing@ens.fr)> " ;
` Noblank ;
` P " Alain Delaët-Tixeuil <$(i,alain.delaet--tixeuil@inria.fr)> " ;
` Noblank ;
` P " Aymeric Fromherz <$(i,aymeric.fromherz@inria.fr)> " ;
` Noblank ;
` P " Louis Gesbert <$(i,louis.gesbert@ocamlpro.com)> " ;
` Noblank ;
` P " Denis Merigoux <$(i,denis.merigoux@inria.fr)> " ;
` Noblank ;
` P " Emile Rolley <$(i,erolley@tutamail.com)> " ;
2020-03-08 03:52:31 +03:00
` S Manpage . s_examples ;
2022-01-19 13:20:25 +03:00
` Pre " catala Interpret -s Foo file.catala_en " ;
` Pre " catala Ocaml -o target/file.ml file.catala_en " ;
2020-03-08 03:52:31 +03:00
` S Manpage . s_bugs ;
2020-12-11 12:51:46 +03:00
` P
" Please file bug reports at https://github.com/CatalaLang/catala/issues " ;
2020-03-08 02:21:55 +03:00
]
in
2022-05-04 18:37:03 +03:00
let exits = Cmd . Exit . defaults @ [ Cmd . Exit . info ~ doc : " on error. " 1 ] in
Cmd . info " catala " ~ version ~ doc ~ exits ~ man
2023-06-15 18:37:52 +03:00
2023-06-28 16:57:52 +03:00
exception Exit_with of int