CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

fix printing boxes & merge issues

Browse Source
This commit is contained in:
adelaett 2023-04-07 10:51:21 +02:00
parent 9b63743c2f
commit 12d85570e8
6 changed files with 35 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.nix/catala.nix
View File

@ -26,7 +26,6 @@
, zarith_stubs_js
, cohttp-lwt-unix
, ppx_expect
, ocaml-crunch
}:
buildDunePackage {

3
compiler/catala_utils/cli.ml
View File

@ -523,9 +523,6 @@ let warning_print (format : ('a, out_channel, unit) format) =
let warning_format (format : ('a, Format.formatter, unit) format) =
Format.printf ("%s" ^^ format ^^ "\n%!") (warning_marker ())
let warning_format (format : ('a, Format.formatter, unit) format) =
Format.printf ("%s" ^^ format ^^ "\n%!") (warning_marker ())
let result_print (format : ('a, out_channel, unit) format) =
Printf.printf ("%s" ^^ format ^^ "\n%!") (result_marker ())

2
compiler/catala_utils/cli.mli
View File

@ -158,4 +158,4 @@ val warning_format : ('a, Format.formatter, unit) format -> 'a
val result_print : ('a, out_channel, unit) format -> 'a
val result_format : ('a, Format.formatter, unit) format -> 'a
val log_print : ('a, out_channel, unit) format -> 'a
val log_format : ('a, Format.formatter, unit) format -> 'a

5
compiler/dcalc/optimizations.ml
View File

@ -138,10 +138,9 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm expr) :
args = [(ELit (LBool false), _)];
} ),
_ ) ) ->
ELit LEmptyError
EEmptyError
| [], just ->
EIfThenElse
{ cond = just; etrue = cons; efalse = ELit LEmptyError, mark }
EIfThenElse { cond = just; etrue = cons; efalse = EEmptyError, mark }
| excepts, just -> EDefault { excepts; just; cons })
| EIfThenElse
{

11
compiler/lcalc/compile_without_exceptions.ml
View File

@ -229,7 +229,6 @@ let rec trans ctx (e : 'm D.expr) : (lcalc, 'm mark) boxed_gexpr =
(* this is to be used with monad_bind. *)
let _, body = Bindlib.unmbind binder in
trans ctx body
| EAbs { binder; tys } ->
(* Every functions of type [a -> b] are translated to a function of type [a
-> option b] *)
@ -256,14 +255,8 @@ let rec trans ctx (e : 'm D.expr) : (lcalc, 'm mark) boxed_gexpr =
(Expr.eop Op.HandleDefaultOpt [TAny, pos; TAny, pos; TAny, pos] m')
[Expr.earray excepts' m; just'; cons']
pos
| ELit l -> begin
match l with
| LEmptyError -> monad_empty ~mark
(* gadts cannot infer l is in fact lcalc glit. Hence, we explicit it. *)
| (LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
l ->
monad_return ~mark (Expr.elit l m)
end
| ELit l -> monad_return ~mark (Expr.elit l m)
| EEmptyError -> monad_empty ~mark
| EErrorOnEmpty arg ->
let arg' = trans ctx arg in
monad_eoe arg' ~mark ~toplevel:false

52
compiler/shared_ast/scope.ml
View File

@ -214,28 +214,36 @@ let format_scope_body ?(debug = false) ctx fmt (n, l) : unit =
let var, body = Bindlib.unbind scope_body_expr in
Format.pp_open_hbox fmt ();
Print.keyword fmt "let scope";
Format.pp_print_space fmt ();
ScopeName.format_t fmt n;
Format.pp_print_space fmt ();
Print.punctuation fmt "(";
(if debug then Print.var_debug else Print.var) fmt var;
Print.punctuation fmt ":";
Format.pp_print_space fmt ();
(if debug then Print.typ_debug else Print.typ ctx) fmt input_typ;
Print.punctuation fmt ")";
Print.punctuation fmt ":";
Format.pp_print_space fmt ();
(if debug then Print.typ_debug else Print.typ ctx) fmt output_typ;
Format.pp_print_space fmt ();
Print.punctuation fmt "=";
Format.pp_print_cut fmt ();
Format.pp_force_newline fmt ();
Format.pp_open_vbox fmt 2;
(format_scope_body_expr ~debug ctx) fmt body;
Format.pp_close_box fmt ();
Format.pp_close_box fmt ();
let _ =
Format.pp_open_hbox fmt ();
Print.keyword fmt "let scope";
Format.pp_print_space fmt ();
ScopeName.format_t fmt n;
Format.pp_print_space fmt ();
Print.punctuation fmt "(";
(if debug then Print.var_debug else Print.var) fmt var;
Print.punctuation fmt ":";
Format.pp_print_space fmt ();
(if debug then Print.typ_debug else Print.typ ctx) fmt input_typ;
Print.punctuation fmt ")";
Print.punctuation fmt ":";
Format.pp_print_space fmt ();
(if debug then Print.typ_debug else Print.typ ctx) fmt output_typ;
Format.pp_print_space fmt ();
Print.punctuation fmt "=";
let _ =
Format.pp_open_vbox fmt 2;
Format.pp_print_cut fmt ();
Format.pp_print_cut fmt ();
let _ =
Format.pp_open_vbox fmt 2;
(format_scope_body_expr ~debug ctx) fmt body;
Format.pp_close_box fmt ()
in
Format.pp_close_box fmt ()
in
Format.pp_close_box fmt ()
in
Format.pp_force_newline fmt ()
let format_by_expr