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

Small code cleanups

Browse Source
This commit is contained in:
Louis Gesbert 2024-05-31 16:24:34 +02:00 committed by vbot
parent 0e88a375a2
commit b4a14bb102
No known key found for this signature in database
GPG Key ID: A102739F983C6C72
2 changed files with 17 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
compiler/driver.ml
View File

@ -1193,6 +1193,12 @@ let main () =
in
let command = catala_t plugins in
let open Cmdliner in
let[@inline] exit_with_error excode fcontent =
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit (fcontent ()) Error;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit excode
in
match Cmd.eval_value ~catch:false ~argv command with
| Ok _ -> exit Cmd.Exit.ok
| Error e ->
@ -1200,34 +1206,22 @@ let main () =
exit Cmd.Exit.cli_error
| exception Cli.Exit_with n -> exit n
| exception Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit content Error;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
exit_with_error Cmd.Exit.some_error @@ fun () -> content
| exception Message.CompilerErrors contents ->
let bt = Printexc.get_raw_backtrace () in
List.iter (fun c -> Message.Content.emit c Error) contents;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
| 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
exit_with_error Cmd.Exit.some_error
@@ fun () -> Message.Content.of_string msg
| exception Sys_error msg ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit
(Message.Content.of_string ("System error: " ^ msg))
Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.internal_error
exit_with_error Cmd.Exit.internal_error
@@ fun () -> Message.Content.of_string ("System error: " ^ msg)
| exception e ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit
(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
exit_with_error Cmd.Exit.internal_error
@@ fun () ->
Message.Content.of_string ("Unexpected error: " ^ Printexc.to_string e)
(* Export module PluginAPI, hide parent module Plugin *)
module Plugin = struct

12
compiler/lcalc/monomorphize.ml
View File

@ -146,15 +146,9 @@ let collect_monomorphized_instances (prg : typed program) :
collect_typ new_acc t
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> acc
| TOption _ | TTuple _ ->
raise
(Message.CompilerError
(Message.Content.add_position
(Message.Content.to_internal_error
(Message.Content.of_message (fun fmt ->
Format.fprintf fmt
"Some types in tuples or option have not been resolved \
by the typechecking before monomorphization.")))
(Mark.get typ)))
Message.error ~internal:true ~pos:(Mark.get typ)
"Some types in tuples or option have not been resolved by the \
typechecking before monomorphization."
in
let rec collect_expr e acc =
Expr.shallow_fold collect_expr e (collect_typ acc (Expr.ty e))