CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Added web-compatible version of the Catala interpreter

Browse Source
This commit is contained in:
Denis Merigoux 2020-12-26 17:37:41 +01:00
parent c51c8760cb
commit f966fc87d0
16 changed files with 177 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Makefile
View File

@ -16,7 +16,7 @@ dependencies-ocaml:
sedlex \
menhir \
menhirLib \
dune dune-build-info \
dune \
cmdliner obelisk \
re \
obelisk \
@ -24,7 +24,7 @@ dependencies-ocaml:
bindlib \
zarith zarith_stubs_js \
ocamlgraph \
js_of_ocaml-compiler \
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx \
odate
init-submodules:
@ -50,7 +50,7 @@ doc:
ln -sf $(PWD)/_build/default/_doc/_html/index.html doc/odoc.html
install:
dune build @install
dune build --profile release @install
##########################################
# Syntax highlighting rules
@ -161,7 +161,7 @@ catala.html: src/catala/utils/cli.ml
dune exec src/catala.exe -- --help=groff | man2html | sed -e '1,8d' \
| tac | sed "1,20d" | tac > $@
website-assets: doc literate_examples grammar.html catala.html
website-assets: doc literate_examples grammar.html catala.html install
##########################################
# Misceallenous

1
catala.opam
View File

@ -19,7 +19,6 @@ depends: [
"menhirLib" {>= "20200211"}
"unionFind" {>= "20200320"}
"bindlib" {>= "5.0.1"}
"dune-build-info" {>= "2.0.1"}
"cmdliner" {>= "1.0.4"}
"re" {>= "1.9.0"}
"zarith" {>= "1.10"}

3
dune-project
View File

@ -27,7 +27,6 @@
(menhirLib (>= 20200211))
(unionFind (>= 20200320))
(bindlib (>= 5.0.1))
(dune-build-info (>= 2.0.1))
(cmdliner (>= 1.0.4))
(re (>= 1.9.0))
(zarith (>= 1.10))
@ -38,4 +37,4 @@
)
)
(using menhir 2.1)
(using menhir 2.1)

5
generate_website_assets.sh
View File

@ -7,8 +7,6 @@ if [[ $1 == "" ]]; then
exit 1
fi
make website-assets
rsync -a _build/default/_doc/_html/ $1/ocaml_docs/
scp examples/allocations_familiales/allocations_familiales.html $1/
scp examples/us_tax_code/us_tax_code.html $1/
@ -16,7 +14,8 @@ scp examples/tutorial_en/tutorial_en.html $1/
scp examples/tutoriel_fr/tutoriel_fr.html $1/
scp grammar.html $1/
scp catala.html $1/
scp _build/default/src/catala.bc.js $1/playground/
scp _build/default/src/catala_web/catala_web.bc.js $1/playground/
scp bundle.js $1/playground/
scp examples/tutorial_en/tutorial_en.catala_en $1/playground/
scp examples/tutoriel_fr/tutoriel_fr.catala_fr $1/playground/
scp syntax_highlighting/en/ace/mode-catala_en.js $1/playground/

39
src/catala/catala_surface/parser_driver.ml
View File

@ -179,12 +179,22 @@ let sedlex_with_menhir (lexer' : lexbuf -> Parser.token) (token_list : (string *
(** {1 API} *)
(** Parses a single source file *)
let rec parse_source_file (source_file : string) (language : Cli.frontend_lang) : Ast.program =
Cli.debug_print (Printf.sprintf "Parsing %s" source_file);
let input = try open_in source_file with Sys_error msg -> Errors.raise_error msg in
let lexbuf = Sedlexing.Utf8.from_channel input in
Sedlexing.set_filename lexbuf source_file;
Parse_utils.current_file := source_file;
let rec parse_source_file (source_file : Pos.input_file) (language : Cli.frontend_lang) :
Ast.program =
Cli.debug_print
(Printf.sprintf "Parsing %s" (match source_file with FileName s | Contents s -> s));
let lexbuf, input =
match source_file with
| FileName source_file -> (
try
let input = open_in source_file in
(Sedlexing.Utf8.from_channel input, Some input)
with Sys_error msg -> Errors.raise_error msg )
| Contents contents -> (Sedlexing.Utf8.from_gen (Gen.of_string contents), None)
in
let source_file_name = match source_file with FileName s -> s | Contents _ -> "stdin" in
Sedlexing.set_filename lexbuf source_file_name;
Parse_utils.current_file := source_file_name;
let lexer_lang =
match language with
| `Fr -> Lexer_fr.lexer_fr
@ -200,16 +210,16 @@ let rec parse_source_file (source_file : string) (language : Cli.frontend_lang)
let commands_or_includes =
sedlex_with_menhir lexer_lang token_list_lang Parser.Incremental.source_file_or_master lexbuf
in
close_in input;
(match input with Some input -> close_in input | None -> ());
match commands_or_includes with
| Ast.SourceFile commands ->
let program = expand_includes source_file commands language in
let program = expand_includes source_file_name commands language in
{
program_items = program.Ast.program_items;
program_source_files = source_file :: program.Ast.program_source_files;
program_source_files = source_file_name :: program.Ast.program_source_files;
}
| Ast.MasterFile includes ->
let current_source_file_dirname = Filename.dirname source_file in
let current_source_file_dirname = Filename.dirname source_file_name in
let includes =
List.map
(fun includ ->
@ -220,7 +230,7 @@ let rec parse_source_file (source_file : string) (language : Cli.frontend_lang)
let new_program =
List.fold_left
(fun acc includ_file ->
let includ_program = parse_source_file includ_file language in
let includ_program = parse_source_file (FileName includ_file) language in
{
Ast.program_source_files =
acc.Ast.program_source_files @ includ_program.program_source_files;
@ -229,7 +239,10 @@ let rec parse_source_file (source_file : string) (language : Cli.frontend_lang)
{ Ast.program_source_files = []; Ast.program_items = [] }
includes
in
{ new_program with program_source_files = source_file :: new_program.program_source_files }
{
new_program with
program_source_files = source_file_name :: new_program.program_source_files;
}
(** Expands the include directives in a parsing result, thus parsing new source files *)
and expand_includes (source_file : string) (commands : Ast.program_item list)
@ -240,7 +253,7 @@ and expand_includes (source_file : string) (commands : Ast.program_item list)
| Ast.LawStructure (LawInclude (Ast.CatalaFile sub_source)) ->
let source_dir = Filename.dirname source_file in
let sub_source = Filename.concat source_dir (Pos.unmark sub_source) in
let includ_program = parse_source_file sub_source language in
let includ_program = parse_source_file (FileName sub_source) language in
{
Ast.program_source_files =
acc.Ast.program_source_files @ includ_program.program_source_files;

4
src/catala/default_calculus/interpreter.ml
View File

@ -152,14 +152,14 @@ let evaluate_operator (op : A.operator Pos.marked) (args : A.expr Pos.marked lis
match entry with
| VarDef ->
Cli.log_print
(Format.asprintf "%a %a = %a" Print.format_log_entry entry
(Format.asprintf "@[<hov 2>%a@ %a@ =@ %a@]" Print.format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
infos Print.format_expr (e', Pos.no_pos))
| _ ->
Cli.log_print
(Format.asprintf "%a %a" Print.format_log_entry entry
(Format.asprintf "@[<hov 2>%a@ %a@]" Print.format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))

28
src/catala/driver.ml
View File

@ -14,17 +14,19 @@
module Cli = Utils.Cli
module Errors = Utils.Errors
module Pos = Utils.Pos
(** Entry function for the executable. Returns a negative number in case of error. *)
let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_output : bool)
(pygmentize_loc : string option) (backend : string) (language : string option)
(max_prec_digits : int option) (trace : bool) (ex_scope : string option)
(output_file : string option) : int =
let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
(wrap_weaved_output : bool) (pygmentize_loc : string option) (backend : string)
(language : string option) (max_prec_digits : int option) (trace : bool)
(ex_scope : string option) (output_file : string option) : int =
try
Cli.debug_flag := debug;
Cli.style_flag := not unstyled;
Cli.trace_flag := trace;
Cli.debug_print "Reading files...";
(match source_file with FileName _ -> () | Contents c -> Cli.contents := c);
(match max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i);
let language =
match language with
@ -50,6 +52,12 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
match backend with
| Cli.Makefile ->
let backend_extensions_list = [ ".tex" ] in
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error "The Makefile backend does not work if the input is not a file"
in
let output_file =
match output_file with
| Some f -> f
@ -67,6 +75,13 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
0
| Cli.Latex | Cli.Html ->
let language : Cli.backend_lang = Cli.to_backend_lang language in
let source_file =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error
"The literate programming backends do not work if the input is not a file"
in
Cli.debug_print
(Printf.sprintf "Weaving literate program into %s"
( match backend with
@ -144,6 +159,7 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
0
with Errors.StructuredError (msg, pos) ->
Cli.error_print (Errors.print_structured_error msg pos);
exit (-1)
-1
let main () = Cmdliner.Term.exit @@ Cmdliner.Term.eval (Cli.catala_t driver, Cli.info)
let main () =
Cmdliner.Term.exit @@ Cmdliner.Term.eval (Cli.catala_t (fun f -> driver (FileName f)), Cli.info)

4
src/catala/literate_programming/html.ml
View File

@ -76,9 +76,7 @@ let wrap_html (source_files : string list) (custom_pygments : string option)
| `Fr -> "Implémentation de texte législatif"
| `En -> "Legislative text implementation" )
(match language with `Fr -> "Document généré par" | `En -> "Document generated by")
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
Utils.Cli.version
( match language with
| `Fr -> "Fichiers sources tissés dans ce document"
| `En -> "Source files weaved in this document" )

4
src/catala/literate_programming/latex.ml
View File

@ -89,9 +89,7 @@ let wrap_latex (source_files : string list) (custom_pygments : string option)
| `Fr -> "Implémentation de texte législatif"
| `En -> "Legislative text implementation" )
(match language with `Fr -> "Document généré par" | `En -> "Document generated by")
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
Utils.Cli.version
( match language with
| `Fr -> "Fichiers sources tissés dans ce document"
| `En -> "Source files weaved in this document" )

11
src/catala/utils/cli.ml
View File

@ -15,6 +15,8 @@
(** Ssource files to be compiled *)
let source_files : string list ref = ref []
let contents : string ref = ref ""
(** Prints debug information *)
let debug_flag = ref false
@ -99,6 +101,8 @@ let catala_t f =
const f $ file $ debug $ unstyled $ wrap_weaved_output $ pygmentize_loc $ backend $ language
$ max_prec_digits_opt $ trace_opt $ ex_scope $ output)
let version = "0.2.0"
let info =
let doc =
"Compiler for Catala, a specification language for tax and social benefits computation rules."
@ -120,12 +124,7 @@ let info =
]
in
let exits = Term.default_exits @ [ Term.exit_info ~doc:"on error." 1 ] in
Term.info "catala"
~version:
( match Build_info.V1.version () with
| None -> "n/a"
| Some v -> Build_info.V1.Version.to_string v )
~doc ~exits ~man
Term.info "catala" ~version ~doc ~exits ~man
(**{1 Terminal formatting}*)

2
src/catala/utils/dune
View File

@ -1,7 +1,7 @@
(library
(name utils)
(public_name catala.utils)
(libraries cmdliner dune-build-info ANSITerminal))
(libraries cmdliner ANSITerminal))
(documentation
(package catala)

152
src/catala/utils/pos.ml
View File

@ -41,6 +41,8 @@ let get_end_column (pos : t) : int =
let get_file (pos : t) : string = (fst pos).Lexing.pos_fname
type input_file = FileName of string | Contents of string
let to_string (pos : t) : string =
let s, e = pos in
Printf.sprintf "in file %s, from %d:%d to %d:%d" s.Lexing.pos_fname s.Lexing.pos_lnum
@ -62,75 +64,89 @@ let indent_number (s : string) : int =
with Invalid_argument _ -> String.length s
let retrieve_loc_text (pos : t) : string =
let filename = get_file pos in
let blue_style = [ ANSITerminal.Bold; ANSITerminal.blue ] in
if filename = "" then "No position information"
else
let sline = get_start_line pos in
let eline = get_end_line pos in
let oc =
try open_in filename
with Sys_error _ ->
Cli.error_print (Printf.sprintf "File not found : \"%s\"" filename);
exit (-1)
in
let input_line_opt () : string option = try Some (input_line oc) with End_of_file -> None in
let print_matched_line (line : string) (line_no : int) : string =
let line_indent = indent_number line in
let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in
line
^
if line_no >= sline && line_no <= eline then
"\n"
try
let filename = get_file pos in
let blue_style = [ ANSITerminal.Bold; ANSITerminal.blue ] in
if filename = "" then "No position information"
else
let sline = get_start_line pos in
let eline = get_end_line pos in
let oc, input_line_opt =
if filename = "stdin" then
let line_index = ref 0 in
let lines = String.split_on_char '\n' !Cli.contents in
let input_line_opt () : string option =
match List.nth_opt lines !line_index with
| Some l ->
line_index := !line_index + 1;
Some l
| None -> None
in
(None, input_line_opt)
else
let oc = open_in filename in
let input_line_opt () : string option =
try Some (input_line oc) with End_of_file -> None
in
(Some oc, input_line_opt)
in
let print_matched_line (line : string) (line_no : int) : string =
let line_indent = indent_number line in
let error_indicator_style = [ ANSITerminal.red; ANSITerminal.Bold ] in
line
^
if line_no = sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s"
(get_end_column pos - 1)
(String.make (max (get_end_column pos - get_start_column pos) 0) '^')
else if line_no = sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s"
(String.length line - 1)
(String.make (max (String.length line - get_start_column pos) 0) '^')
else if line_no <> sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s%s" line_indent ""
(String.make (max (String.length line - line_indent) 0) '^')
else if line_no <> sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s%*s" line_indent ""
(get_end_column pos - 1 - line_indent)
(String.make (max (get_end_column pos - line_indent) 0) '^')
else assert false (* should not happen *)
else ""
in
let include_extra_count = 0 in
let rec get_lines (n : int) : string list =
match input_line_opt () with
| Some line ->
if n < sline - include_extra_count then get_lines (n + 1)
else if n >= sline - include_extra_count && n <= eline + include_extra_count then
print_matched_line line n :: get_lines (n + 1)
else []
| None -> []
in
let pos_lines = get_lines 1 in
let spaces = int_of_float (log10 (float_of_int eline)) + 1 in
close_in oc;
Cli.print_with_style blue_style "%*s--> %s\n%s" spaces "" filename
(Cli.add_prefix_to_each_line
(Printf.sprintf "\n%s" (String.concat "\n" pos_lines))
(fun i ->
let cur_line = sline - include_extra_count + i - 1 in
if
cur_line >= sline
&& cur_line <= sline + (2 * (eline - sline))
&& cur_line mod 2 = sline mod 2
then Cli.print_with_style blue_style "%*d | " spaces (sline + ((cur_line - sline) / 2))
else if cur_line >= sline - include_extra_count && cur_line < sline then
Cli.print_with_style blue_style "%*d | " spaces cur_line
else if
cur_line <= sline + (2 * (eline - sline)) + 1 + include_extra_count
&& cur_line > sline + (2 * (eline - sline)) + 1
then Cli.print_with_style blue_style "%*d | " spaces (cur_line - (eline - sline + 1))
else Cli.print_with_style blue_style "%*s | " spaces ""))
if line_no >= sline && line_no <= eline then
"\n"
^
if line_no = sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s"
(get_end_column pos - 1)
(String.make (max (get_end_column pos - get_start_column pos) 0) '^')
else if line_no = sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s"
(String.length line - 1)
(String.make (max (String.length line - get_start_column pos) 0) '^')
else if line_no <> sline && line_no <> eline then
Cli.print_with_style error_indicator_style "%*s%s" line_indent ""
(String.make (max (String.length line - line_indent) 0) '^')
else if line_no <> sline && line_no = eline then
Cli.print_with_style error_indicator_style "%*s%*s" line_indent ""
(get_end_column pos - 1 - line_indent)
(String.make (max (get_end_column pos - line_indent) 0) '^')
else assert false (* should not happen *)
else ""
in
let include_extra_count = 0 in
let rec get_lines (n : int) : string list =
match input_line_opt () with
| Some line ->
if n < sline - include_extra_count then get_lines (n + 1)
else if n >= sline - include_extra_count && n <= eline + include_extra_count then
print_matched_line line n :: get_lines (n + 1)
else []
| None -> []
in
let pos_lines = get_lines 1 in
let spaces = int_of_float (log10 (float_of_int eline)) + 1 in
(match oc with None -> () | Some oc -> close_in oc);
Cli.print_with_style blue_style "%*s--> %s\n%s" spaces "" filename
(Cli.add_prefix_to_each_line
(Printf.sprintf "\n%s" (String.concat "\n" pos_lines))
(fun i ->
let cur_line = sline - include_extra_count + i - 1 in
if
cur_line >= sline
&& cur_line <= sline + (2 * (eline - sline))
&& cur_line mod 2 = sline mod 2
then Cli.print_with_style blue_style "%*d | " spaces (sline + ((cur_line - sline) / 2))
else if cur_line >= sline - include_extra_count && cur_line < sline then
Cli.print_with_style blue_style "%*d | " spaces cur_line
else if
cur_line <= sline + (2 * (eline - sline)) + 1 + include_extra_count
&& cur_line > sline + (2 * (eline - sline)) + 1
then Cli.print_with_style blue_style "%*d | " spaces (cur_line - (eline - sline + 1))
else Cli.print_with_style blue_style "%*s | " spaces ""))
with Sys_error _ -> "Location:" ^ to_string pos
type 'a marked = 'a * t

2
src/catala/utils/pos.mli
View File

@ -31,6 +31,8 @@ val get_end_column : t -> int
val get_file : t -> string
type input_file = FileName of string | Contents of string
(**{2 Formatters}*)
val to_string : t -> string

16
src/catala_web/catala_web.ml Normal file
View File

@ -0,0 +1,16 @@
open Catala.Driver
open Js_of_ocaml
let _ =
Js.export_all
(object%js
method interpret (contents : Js.js_string Js.t) (scope : Js.js_string Js.t)
(language : Js.js_string Js.t) (trace : bool) =
driver
(Contents (Js.to_string contents))
false false false None "Interpret"
(Some (Js.to_string language))
None trace
(Some (Js.to_string scope))
None
end)

9
src/catala_web/dune Normal file
View File

@ -0,0 +1,9 @@
(executable
(name catala_web)
(modes byte js)
(package catala)
(public_name catala_web)
(modules catala_web)
(preprocess
(pps js_of_ocaml-ppx))
(libraries catala js_of_ocaml))

2
src/dune
View File

@ -1,6 +1,6 @@
(executable
(name catala)
(modes native js)
(modes native)
(package catala)
(modules catala)
(public_name catala)