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

Added scopelang prettyprinter

Browse Source 
And clarifier intermediate languages debug printing
This commit is contained in:
Denis Merigoux 2021-05-29 14:15:23 +02:00
parent b1b8129852
commit 434f1863c9
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
7 changed files with 116 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/catala/catala_web.ml
View File

@ -8,7 +8,7 @@ let _ =
(language : Js.js_string Js.t) (trace : bool) =
driver
(Contents (Js.to_string contents))
false false false false "Interpret"
false false false "Interpret"
(Some (Js.to_string language))
None trace false
(Some (Js.to_string scope))

70
src/catala/driver.ml
View File

@ -25,7 +25,7 @@ let extensions = [ (".catala_fr", "fr"); (".catala_en", "en"); (".catala_pl", "p
(** Entry function for the executable. Returns a negative number in case of error. Usage:
[driver source_file debug dcalc unstyled wrap_weaved_output backend language max_prec_digits trace optimize scope_to_execute output_file]*)
let driver (source_file : Pos.input_file) (debug : bool) (dcalc : bool) (unstyled : bool)
let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
(wrap_weaved_output : bool) (backend : string) (language : string option)
(max_prec_digits : int option) (trace : bool) (optimize : bool) (ex_scope : string option)
(output_file : string option) : int =
@ -66,12 +66,14 @@ let driver (source_file : Pos.input_file) (debug : bool) (dcalc : bool) (unstyle
else if backend = "html" then Cli.Html
else if backend = "interpret" then Cli.Run
else if backend = "ocaml" then Cli.OCaml
else if backend = "dcalc" then Cli.Dcalc
else if backend = "scopelang" then Cli.Scopelang
else
Errors.raise_error
(Printf.sprintf "The selected backend (%s) is not supported by Catala" backend)
in
let program = Surface.Parser_driver.parse_top_level_file source_file language in
let program = Surface.Fill_positions.fill_pos_with_legislative_info program in
let prgm = Surface.Parser_driver.parse_top_level_file source_file language in
let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in
match backend with
| Cli.Makefile ->
let backend_extensions_list = [ ".tex" ] in
@ -90,11 +92,12 @@ let driver (source_file : Pos.input_file) (debug : bool) (dcalc : bool) (unstyle
Printf.fprintf oc "%s:\\\n%s\n%s:"
(String.concat "\\\n"
(output_file
:: List.map
(fun ext -> Filename.remove_extension source_file ^ ext)
backend_extensions_list))
(String.concat "\\\n" program.program_source_files)
(String.concat "\\\n" program.program_source_files);
::
List.map
(fun ext -> Filename.remove_extension source_file ^ ext)
backend_extensions_list))
(String.concat "\\\n" prgm.program_source_files)
(String.concat "\\\n" prgm.program_source_files);
0
| Cli.Latex | Cli.Html ->
let source_file =
@ -132,18 +135,18 @@ let driver (source_file : Pos.input_file) (debug : bool) (dcalc : bool) (unstyle
if wrap_weaved_output then
match backend with
| Cli.Latex ->
Literate.Latex.wrap_latex program.Surface.Ast.program_source_files language fmt
(fun fmt -> weave_output fmt program)
Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files language fmt
(fun fmt -> weave_output fmt prgm)
| Cli.Html ->
Literate.Html.wrap_html program.Surface.Ast.program_source_files language fmt
(fun fmt -> weave_output fmt program)
Literate.Html.wrap_html prgm.Surface.Ast.program_source_files language fmt (fun fmt ->
weave_output fmt prgm)
| _ -> assert false (* should not happen *)
else weave_output fmt program;
else weave_output fmt prgm;
close_out oc;
0
| Cli.Run | Cli.OCaml -> (
| _ -> (
Cli.debug_print "Name resolution...";
let ctxt = Surface.Name_resolution.form_context program in
let ctxt = Surface.Name_resolution.form_context prgm in
let scope_uid =
match (ex_scope, backend) with
| None, Cli.Run -> Errors.raise_error "No scope was provided for execution."
@ -160,9 +163,24 @@ let driver (source_file : Pos.input_file) (debug : bool) (dcalc : bool) (unstyle
| Some uid -> uid)
in
Cli.debug_print "Desugaring...";
let prgm = Surface.Desugaring.desugar_program ctxt program in
let prgm = Surface.Desugaring.desugar_program ctxt prgm in
Cli.debug_print "Collecting rules...";
let prgm = Desugared.Desugared_to_scope.translate_program prgm in
if backend = Cli.Scopelang then begin
let fmt, at_end =
match output_file with
| Some f ->
let oc = open_out f in
(Format.formatter_of_out_channel oc, fun _ -> close_out oc)
| None -> (Format.std_formatter, fun _ -> ())
in
if Option.is_some ex_scope then
Format.fprintf fmt "%a\n" Scopelang.Print.format_scope
(scope_uid, Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes)
else Format.fprintf fmt "%a\n" Scopelang.Print.format_program prgm;
at_end ();
exit 0
end;
Cli.debug_print "Translating to default calculus...";
let prgm, prgm_expr, type_ordering =
Scopelang.Scope_to_dcalc.translate_program prgm scope_uid
@ -174,11 +192,21 @@ let driver (source_file : Pos.input_file) (debug : bool) (dcalc : bool) (unstyle
end
else prgm
in
if dcalc then begin
Format.printf "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
(let _, _, e = List.find (fun (name, _, _) -> name = scope_uid) prgm.scopes in
e);
if backend = Cli.Dcalc then begin
let fmt, at_end =
match output_file with
| Some f ->
let oc = open_out f in
(Format.formatter_of_out_channel oc, fun _ -> close_out oc)
| None -> (Format.std_formatter, fun _ -> ())
in
if Option.is_some ex_scope then
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
(let _, _, e = List.find (fun (name, _, _) -> name = scope_uid) prgm.scopes in
e)
else Format.fprintf fmt "%a\n" (Dcalc.Print.format_expr prgm.decl_ctx) prgm_expr;
at_end ();
exit 0
end;
Cli.debug_print "Typechecking...";

53
src/catala/scopelang/print.ml
View File

@ -123,3 +123,56 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
~pp_sep:(fun fmt () -> Format.fprintf fmt ";")
(fun fmt e -> Format.fprintf fmt "@[%a@]" format_expr e))
es
let format_struct (fmt : Format.formatter)
((name, fields) : StructName.t * (StructFieldName.t * typ Pos.marked) list) : unit =
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}" StructName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a: %a" StructFieldName.format_t field_name format_typ typ))
fields
let format_enum (fmt : Format.formatter)
((name, cases) : EnumName.t * (EnumConstructor.t * typ Pos.marked) list) : unit =
Format.fprintf fmt "type %a = @\n@[<hov 2> %a@]" EnumName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "| %a: %a" EnumConstructor.format_t field_name format_typ typ))
cases
let format_scope (fmt : Format.formatter) ((name, decl) : ScopeName.t * scope_decl) : unit =
Format.fprintf fmt "@[<hov 2>let scope %a@ %a@ =@]@\n@[<hov 2> %a@\nend scope@]"
ScopeName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt (scope_var, typ) ->
Format.fprintf fmt "(%a: %a)" ScopeVar.format_t scope_var format_typ typ))
(ScopeVarMap.bindings decl.scope_sig)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun fmt rule ->
match rule with
| Definition (loc, typ, e) ->
Format.fprintf fmt "@[<hov 2>let %a : %a =@ @[<hov 2>%a@]@ in@]" format_location
(Pos.unmark loc) format_typ typ
(fun fmt e ->
match Pos.unmark loc with
| SubScopeVar _ -> format_expr fmt e
| ScopeVar _ -> Format.fprintf fmt "reentrant or by default@ %a" format_expr e)
e
| Assertion e -> Format.fprintf fmt "assert (%a)" format_expr e
| Call (scope_name, subscope_name) ->
Format.fprintf fmt "call %a[%a]" ScopeName.format_t scope_name SubScopeName.format_t
subscope_name))
decl.scope_decl_rules
let format_program (fmt : Format.formatter) (p : program) : unit =
Format.fprintf fmt "%a@\n@\n%a@\n@\n%a"
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") format_struct)
(StructMap.bindings p.program_structs)
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") format_enum)
(EnumMap.bindings p.program_enums)
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") format_scope)
(ScopeMap.bindings p.program_scopes)

4
src/catala/scopelang/print.mli
View File

@ -21,3 +21,7 @@ val format_location : Format.formatter -> Ast.location -> unit
val format_typ : Format.formatter -> Ast.typ Pos.marked -> unit
val format_expr : Format.formatter -> Ast.expr Pos.marked -> unit
val format_scope : Format.formatter -> Ast.ScopeName.t * Ast.scope_decl -> unit
val format_program : Format.formatter -> Ast.program -> unit

8
src/catala/surface/parser_driver.ml
View File

@ -101,10 +101,10 @@ let raise_parser_error (error_loc : Pos.t) (last_good_loc : Pos.t option) (token
(Cli.print_with_style syntax_hints_style "\"%s\"" token)
msg)
((Some "Error token:", error_loc)
::
(match last_good_loc with
| None -> []
| Some last_good_loc -> [ (Some "Last good token:", last_good_loc) ]))
::
(match last_good_loc with
| None -> []
| Some last_good_loc -> [ (Some "Last good token:", last_good_loc) ]))
module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct
include Parser.Make (LocalisedLexer)

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

@ -44,9 +44,6 @@ let file =
let debug = Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information")
let debug_dcalc =
Arg.(value & flag & info [ "dcalc" ] ~doc:"Emit default calculus version of the program")
let unstyled = Arg.(value & flag & info [ "unstyled" ] ~doc:"Removes styling from terminal output")
let optimize = Arg.(value & flag & info [ "optimize"; "O" ] ~doc:"Run compiler optimizations")
@ -65,9 +62,9 @@ let backend =
required
& pos 0 (some string) None
& info [] ~docv:"BACKEND"
~doc:"Backend selection among: LaTeX, Makefile, Html, Interpret, OCaml")
~doc:"Backend selection among: LaTeX, Makefile, Html, Interpret, OCaml, Dcalc, Scopelang")
type backend_option = Latex | Makefile | Html | Run | OCaml
type backend_option = Latex | Makefile | Html | Run | OCaml | Dcalc | Scopelang
let language =
Arg.(
@ -91,12 +88,11 @@ let output =
value
& opt (some string) None
& info [ "output"; "o" ] ~docv:"OUTPUT"
~doc:
"$(i, OUTPUT) is the file that will contain the extracted output (for compiler backends)")
~doc:"$(i, OUTPUT) is the file that will contain the output of the compiler")
let catala_t f =
Term.(
const f $ file $ debug $ debug_dcalc $ unstyled $ wrap_weaved_output $ backend $ language
const f $ file $ debug $ unstyled $ wrap_weaved_output $ backend $ language
$ max_prec_digits_opt $ trace_opt $ optimize $ ex_scope $ output)
let version = "0.4.0"

3
src/catala/utils/cli.mli
View File

@ -49,7 +49,7 @@ val wrap_weaved_output : bool Cmdliner.Term.t
val backend : string Cmdliner.Term.t
type backend_option = Latex | Makefile | Html | Run | OCaml
type backend_option = Latex | Makefile | Html | Run | OCaml | Dcalc | Scopelang
val language : string option Cmdliner.Term.t
@ -64,7 +64,6 @@ val catala_t :
bool ->
bool ->
bool ->
bool ->
string ->
string option ->
int option ->