mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 00:15:39 +03:00
Rewriting message calls to use the new intf
This commit is contained in:
parent
454667a47b
commit
98fc97a241
@ -318,7 +318,7 @@ module Poll = struct
|
|||||||
match File.(check_directory (exec_dir /../ "lib")) with
|
match File.(check_directory (exec_dir /../ "lib")) with
|
||||||
| Some d -> d
|
| Some d -> d
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Could not locate the OCaml library directory, make sure OCaml \
|
"Could not locate the OCaml library directory, make sure OCaml \
|
||||||
or opam is installed")))
|
or opam is installed")))
|
||||||
|
|
||||||
@ -348,11 +348,10 @@ module Poll = struct
|
|||||||
in
|
in
|
||||||
match File.check_directory d with
|
match File.check_directory d with
|
||||||
| Some dir ->
|
| Some dir ->
|
||||||
Message.emit_debug "Catala runtime libraries found at @{<bold>%s@}."
|
Message.debug "Catala runtime libraries found at @{<bold>%s@}." dir;
|
||||||
dir;
|
|
||||||
dir
|
dir
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"@[<hov>Could not locate the Catala runtime library at %s.@ Make \
|
"@[<hov>Could not locate the Catala runtime library at %s.@ Make \
|
||||||
sure that either catala is correctly installed,@ or you are \
|
sure that either catala is correctly installed,@ or you are \
|
||||||
running from the root of a compiled source tree.@]"
|
running from the root of a compiled source tree.@]"
|
||||||
@ -366,7 +365,7 @@ module Poll = struct
|
|||||||
(fun lib ->
|
(fun lib ->
|
||||||
match File.(check_directory (Lazy.force ocaml_libdir / lib)) with
|
match File.(check_directory (Lazy.force ocaml_libdir / lib)) with
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Required OCaml library not found at %a.@ Try `opam install \
|
"Required OCaml library not found at %a.@ Try `opam install \
|
||||||
%s'"
|
%s'"
|
||||||
File.format
|
File.format
|
||||||
@ -903,7 +902,7 @@ let ninja_init
|
|||||||
| None -> File.with_temp_file "clerk_build_" ".ninja" k
|
| None -> File.with_temp_file "clerk_build_" ".ninja" k
|
||||||
in
|
in
|
||||||
fun ~extra ~test_flags k ->
|
fun ~extra ~test_flags k ->
|
||||||
Message.emit_debug "building ninja rules...";
|
Message.debug "building ninja rules...";
|
||||||
with_ninja_output
|
with_ninja_output
|
||||||
@@ fun nin_file ->
|
@@ fun nin_file ->
|
||||||
File.with_formatter_of_file nin_file (fun nin_ppf ->
|
File.with_formatter_of_file nin_file (fun nin_ppf ->
|
||||||
@ -946,7 +945,7 @@ let build_cmd =
|
|||||||
targets
|
targets
|
||||||
in
|
in
|
||||||
let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in
|
let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in
|
||||||
Message.emit_debug "executing '%s'..." ninja_cmd;
|
Message.debug "executing '%s'..." ninja_cmd;
|
||||||
Sys.command ninja_cmd
|
Sys.command ninja_cmd
|
||||||
in
|
in
|
||||||
let doc =
|
let doc =
|
||||||
@ -986,7 +985,7 @@ let test_cmd =
|
|||||||
ninja_init ~extra ~test_flags
|
ninja_init ~extra ~test_flags
|
||||||
@@ fun nin_file ->
|
@@ fun nin_file ->
|
||||||
let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in
|
let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in
|
||||||
Message.emit_debug "executing '%s'..." ninja_cmd;
|
Message.debug "executing '%s'..." ninja_cmd;
|
||||||
Sys.command ninja_cmd
|
Sys.command ninja_cmd
|
||||||
in
|
in
|
||||||
let doc =
|
let doc =
|
||||||
@ -1020,7 +1019,7 @@ let run_cmd =
|
|||||||
ninja_init ~extra ~test_flags:[]
|
ninja_init ~extra ~test_flags:[]
|
||||||
@@ fun nin_file ->
|
@@ fun nin_file ->
|
||||||
let ninja_cmd = ninja_cmdline ninja_flags nin_file [] in
|
let ninja_cmd = ninja_cmdline ninja_flags nin_file [] in
|
||||||
Message.emit_debug "executing '%s'..." ninja_cmd;
|
Message.debug "executing '%s'..." ninja_cmd;
|
||||||
Sys.command ninja_cmd
|
Sys.command ninja_cmd
|
||||||
in
|
in
|
||||||
let doc =
|
let doc =
|
||||||
|
@ -77,7 +77,7 @@ let run_inline_tests catala_exe catala_opts test_flags filename =
|
|||||||
match Clerk_scan.get_lang filename with
|
match Clerk_scan.get_lang filename with
|
||||||
| Some l -> l
|
| Some l -> l
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_error "Can't infer catala dialect from file extension of %a"
|
Message.error "Can't infer catala dialect from file extension of %a"
|
||||||
File.format filename
|
File.format filename
|
||||||
in
|
in
|
||||||
let lines = Surface.Parser_driver.lines filename lang in
|
let lines = Surface.Parser_driver.lines filename lang in
|
||||||
|
@ -70,7 +70,7 @@ let rec ensure_dir dir =
|
|||||||
match Sys.is_directory dir with
|
match Sys.is_directory dir with
|
||||||
| true -> ()
|
| true -> ()
|
||||||
| false ->
|
| false ->
|
||||||
Message.raise_error "Directory %a exists but is not a directory" format dir
|
Message.error "Directory %a exists but is not a directory" format dir
|
||||||
| exception Sys_error _ ->
|
| exception Sys_error _ ->
|
||||||
let pdir = parent dir in
|
let pdir = parent dir in
|
||||||
if pdir <> dir then ensure_dir pdir;
|
if pdir <> dir then ensure_dir pdir;
|
||||||
@ -200,7 +200,7 @@ let get_command t =
|
|||||||
let check_exec t =
|
let check_exec t =
|
||||||
try if String.contains t dir_sep_char then Unix.realpath t else get_command t
|
try if String.contains t dir_sep_char then Unix.realpath t else get_command t
|
||||||
with Unix.Unix_error _ | Sys_error _ ->
|
with Unix.Unix_error _ | Sys_error _ ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Could not find the @{<yellow>%s@} program, please fix your installation"
|
"Could not find the @{<yellow>%s@} program, please fix your installation"
|
||||||
(Filename.quote t)
|
(Filename.quote t)
|
||||||
|
|
||||||
@ -238,7 +238,7 @@ let scan_tree f t =
|
|||||||
let is_dir t =
|
let is_dir t =
|
||||||
try Sys.is_directory t
|
try Sys.is_directory t
|
||||||
with Sys_error _ ->
|
with Sys_error _ ->
|
||||||
Message.emit_debug "Cannot read %s, skipping" t;
|
Message.debug "Cannot read %s, skipping" t;
|
||||||
false
|
false
|
||||||
in
|
in
|
||||||
let not_hidden t = match t.[0] with '.' | '_' -> false | _ -> true in
|
let not_hidden t = match t.[0] with '.' | '_' -> false | _ -> true in
|
||||||
|
@ -140,10 +140,8 @@ module Content = struct
|
|||||||
let add_suggestion (content : t) (suggestion : string list) =
|
let add_suggestion (content : t) (suggestion : string list) =
|
||||||
content @ [Suggestion suggestion]
|
content @ [Suggestion suggestion]
|
||||||
|
|
||||||
let add_position
|
let add_position (content : t) ?(message : message option) (position : Pos.t)
|
||||||
(content : t)
|
=
|
||||||
?(message : message option)
|
|
||||||
(position : Pos.t) =
|
|
||||||
content @ [Position { pos = position; pos_message = message }]
|
content @ [Position { pos = position; pos_message = message }]
|
||||||
|
|
||||||
let of_string (s : string) : t =
|
let of_string (s : string) : t =
|
||||||
@ -319,7 +317,6 @@ let emit_result format =
|
|||||||
(fun message -> Content.emit [MainMessage message] Result)
|
(fun message -> Content.emit [MainMessage message] Result)
|
||||||
format
|
format
|
||||||
|
|
||||||
|
|
||||||
(** New concise interface *)
|
(** New concise interface *)
|
||||||
|
|
||||||
type ('a, 'b) emitter =
|
type ('a, 'b) emitter =
|
||||||
@ -333,22 +330,40 @@ type ('a, 'b) emitter =
|
|||||||
('a, Format.formatter, unit, 'b) format4 ->
|
('a, Format.formatter, unit, 'b) format4 ->
|
||||||
'a
|
'a
|
||||||
|
|
||||||
let make ?header ?(internal=false) ?pos ?pos_msg ?extra_pos ?fmt_pos ?suggestion ~cont ~level =
|
let make
|
||||||
Format.kdprintf @@ fun message ->
|
?header
|
||||||
let t = match level with Result -> of_result message | _ -> of_message message in
|
?(internal = false)
|
||||||
|
?pos
|
||||||
|
?pos_msg
|
||||||
|
?extra_pos
|
||||||
|
?fmt_pos
|
||||||
|
?suggestion
|
||||||
|
~cont
|
||||||
|
~level =
|
||||||
|
Format.kdprintf
|
||||||
|
@@ fun message ->
|
||||||
|
let t =
|
||||||
|
match level with Result -> of_result message | _ -> of_message message
|
||||||
|
in
|
||||||
let t = match header with Some h -> prepend_message t h | None -> t in
|
let t = match header with Some h -> prepend_message t h | None -> t in
|
||||||
let t = if internal then to_internal_error t else t in
|
let t = if internal then to_internal_error t else t in
|
||||||
let t = match pos with Some p -> add_position t ?message:pos_msg p | None -> t in
|
let t =
|
||||||
let t = match extra_pos with
|
match pos with Some p -> add_position t ?message:pos_msg p | None -> t
|
||||||
|
in
|
||||||
|
let t =
|
||||||
|
match extra_pos with
|
||||||
| Some pl ->
|
| Some pl ->
|
||||||
List.fold_left (fun t (message, p) ->
|
List.fold_left
|
||||||
let message = Option.map (fun m ppf -> Format.pp_print_text ppf m) message in
|
(fun t (message, p) ->
|
||||||
|
let message =
|
||||||
|
Option.map (fun m ppf -> Format.pp_print_text ppf m) message
|
||||||
|
in
|
||||||
add_position t ?message p)
|
add_position t ?message p)
|
||||||
t
|
t pl
|
||||||
pl
|
|
||||||
| None -> t
|
| None -> t
|
||||||
in
|
in
|
||||||
let t = match fmt_pos with
|
let t =
|
||||||
|
match fmt_pos with
|
||||||
| Some pl ->
|
| Some pl ->
|
||||||
List.fold_left (fun t (message, p) -> add_position t ?message p) t pl
|
List.fold_left (fun t (message, p) -> add_position t ?message p) t pl
|
||||||
| None -> t
|
| None -> t
|
||||||
@ -361,4 +376,3 @@ let log = make ~level:Log ~cont:emit
|
|||||||
let result = make ~level:Result ~cont:emit
|
let result = make ~level:Result ~cont:emit
|
||||||
let warning = make ~level:Warning ~cont:emit
|
let warning = make ~level:Warning ~cont:emit
|
||||||
let error = make ~level:Error ~cont:(fun m _ -> raise (CompilerError m))
|
let error = make ~level:Error ~cont:(fun m _ -> raise (CompilerError m))
|
||||||
|
|
||||||
|
@ -16,7 +16,7 @@ let () =
|
|||||||
let language =
|
let language =
|
||||||
try List.assoc (String.lowercase_ascii language) Cli.languages
|
try List.assoc (String.lowercase_ascii language) Cli.languages
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
Message.raise_error "Unrecognised input locale %S" language
|
Message.error "Unrecognised input locale %S" language
|
||||||
in
|
in
|
||||||
let options =
|
let options =
|
||||||
Global.enforce_options
|
Global.enforce_options
|
||||||
|
@ -224,7 +224,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
|||||||
let case_e =
|
let case_e =
|
||||||
try EnumConstructor.Map.find constructor e_cases
|
try EnumConstructor.Map.find constructor e_cases
|
||||||
with EnumConstructor.Map.Not_found _ ->
|
with EnumConstructor.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The constructor %a of enum %a is missing from this pattern \
|
"The constructor %a of enum %a is missing from this pattern \
|
||||||
matching"
|
matching"
|
||||||
EnumConstructor.format constructor EnumName.format name
|
EnumConstructor.format constructor EnumName.format name
|
||||||
@ -236,7 +236,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
|||||||
(EnumConstructor.Map.empty, e_cases)
|
(EnumConstructor.Map.empty, e_cases)
|
||||||
in
|
in
|
||||||
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
|
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Pattern matching is incomplete for enum %a: missing cases %a"
|
"Pattern matching is incomplete for enum %a: missing cases %a"
|
||||||
EnumName.format name
|
EnumName.format name
|
||||||
(EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () ->
|
(EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () ->
|
||||||
@ -272,7 +272,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
|||||||
( var_ctx.scope_input_name,
|
( var_ctx.scope_input_name,
|
||||||
thunk_scope_arg var_ctx (translate_expr ctx e) )
|
thunk_scope_arg var_ctx (translate_expr ctx e) )
|
||||||
| Some var_ctx, None ->
|
| Some var_ctx, None ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, pos;
|
None, pos;
|
||||||
( Some "Declaration of the missing input variable",
|
( Some "Declaration of the missing input variable",
|
||||||
@ -281,11 +282,12 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
|||||||
"Definition of input variable '%a' missing in this scope call"
|
"Definition of input variable '%a' missing in this scope call"
|
||||||
ScopeVar.format var_name
|
ScopeVar.format var_name
|
||||||
| None, Some e ->
|
| None, Some e ->
|
||||||
Message.raise_multispanned_error_full
|
Message.error
|
||||||
~suggestion:
|
~suggestion:
|
||||||
(List.map
|
(List.map
|
||||||
(fun v -> Mark.remove (ScopeVar.get_info v))
|
(fun v -> Mark.remove (ScopeVar.get_info v))
|
||||||
(ScopeVar.Map.keys sc_sig.scope_sig_in_fields))
|
(ScopeVar.Map.keys sc_sig.scope_sig_in_fields))
|
||||||
|
~fmt_pos:
|
||||||
[
|
[
|
||||||
None, Expr.pos e;
|
None, Expr.pos e;
|
||||||
( Some
|
( Some
|
||||||
@ -511,13 +513,13 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
|||||||
match Mark.remove typ with
|
match Mark.remove typ with
|
||||||
| TArrow (_, (tout, _)) -> tout
|
| TArrow (_, (tout, _)) -> tout
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Application of non-function toplevel variable")
|
"Application of non-function toplevel variable")
|
||||||
| _ -> TAny
|
| _ -> TAny
|
||||||
in
|
in
|
||||||
(* Message.emit_debug "new_args %d, input_typs: %d, input_typs %a"
|
(* Message.debug "new_args %d, input_typs: %d, input_typs %a" (List.length
|
||||||
(List.length new_args) (List.length input_typs) (Format.pp_print_list
|
new_args) (List.length input_typs) (Format.pp_print_list Print.typ_debug)
|
||||||
Print.typ_debug) (List.map (Mark.add Pos.no_pos) input_typs); *)
|
(List.map (Mark.add Pos.no_pos) input_typs); *)
|
||||||
let new_args =
|
let new_args =
|
||||||
ListLabels.mapi (List.combine new_args input_typs)
|
ListLabels.mapi (List.combine new_args input_typs)
|
||||||
~f:(fun i (new_arg, input_typ) ->
|
~f:(fun i (new_arg, input_typ) ->
|
||||||
@ -760,8 +762,8 @@ let translate_scope_decl
|
|||||||
(* Todo: are we sure this can't happen in normal code ? E.g. is calling a
|
(* Todo: are we sure this can't happen in normal code ? E.g. is calling a
|
||||||
scope which only defines input variables already an error at this stage
|
scope which only defines input variables already an error at this stage
|
||||||
or not ? *)
|
or not ? *)
|
||||||
Message.raise_spanned_error pos_sigma "Scope %a has no content"
|
Message.error ~pos:pos_sigma "Scope %a has no content" ScopeName.format
|
||||||
ScopeName.format scope_name
|
scope_name
|
||||||
| ( S.ScopeVarDefinition { e; _ }
|
| ( S.ScopeVarDefinition { e; _ }
|
||||||
| S.SubScopeVarDefinition { e; _ }
|
| S.SubScopeVarDefinition { e; _ }
|
||||||
| S.Assertion e )
|
| S.Assertion e )
|
||||||
|
@ -31,14 +31,14 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool =
|
|||||||
match inv p.decl_ctx e with
|
match inv p.decl_ctx e with
|
||||||
| Ignore -> result, total, ok
|
| Ignore -> result, total, ok
|
||||||
| Fail ->
|
| Fail ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"@[<v 2>Invariant @{<magenta>%s@} failed.@,%a@]" name
|
"@[<v 2>Invariant @{<magenta>%s@} failed.@,%a@]" name
|
||||||
(Print.expr ()) e
|
(Print.expr ()) e
|
||||||
| Pass -> result, total + 1, ok + 1
|
| Pass -> result, total + 1, ok + 1
|
||||||
in
|
in
|
||||||
f e acc)
|
f e acc)
|
||||||
in
|
in
|
||||||
Message.emit_debug "Invariant %s checked.@ result: [%d/%d]" name ok total;
|
Message.debug "Invariant %s checked.@ result: [%d/%d]" name ok total;
|
||||||
result
|
result
|
||||||
|
|
||||||
(* Structural invariant: no default can have as type A -> B *)
|
(* Structural invariant: no default can have as type A -> B *)
|
||||||
@ -143,11 +143,11 @@ let rec check_typ_no_default ctx ty =
|
|||||||
| TArray ty -> check_typ_no_default ctx ty
|
| TArray ty -> check_typ_no_default ctx ty
|
||||||
| TDefault _t -> false
|
| TDefault _t -> false
|
||||||
| TAny ->
|
| TAny ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"Some Dcalc invariants are invalid: TAny was found whereas it should be \
|
"Some Dcalc invariants are invalid: TAny was found whereas it should be \
|
||||||
fully resolved."
|
fully resolved."
|
||||||
| TClosureEnv ->
|
| TClosureEnv ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"Some Dcalc invariants are invalid: TClosureEnv was found whereas it \
|
"Some Dcalc invariants are invalid: TClosureEnv was found whereas it \
|
||||||
should only appear later in the compilation process."
|
should only appear later in the compilation process."
|
||||||
|
|
||||||
@ -192,7 +192,7 @@ let invariant_typing_defaults () : string * invariant_expr =
|
|||||||
fun ctx e ->
|
fun ctx e ->
|
||||||
if check_type_root ctx (Expr.ty e) then Pass
|
if check_type_root ctx (Expr.ty e) then Pass
|
||||||
else (
|
else (
|
||||||
Message.emit_warning "typing error %a@." (Print.typ ctx) (Expr.ty e);
|
Message.warning "typing error %a@." (Print.typ ctx) (Expr.ty e);
|
||||||
Fail) )
|
Fail) )
|
||||||
|
|
||||||
let check_all_invariants prgm =
|
let check_all_invariants prgm =
|
||||||
|
@ -141,7 +141,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
|
|||||||
cycle
|
cycle
|
||||||
(List.tl cycle @ [List.hd cycle])
|
(List.tl cycle @ [List.hd cycle])
|
||||||
in
|
in
|
||||||
Message.raise_multispanned_error spans
|
Message.error ~extra_pos:spans
|
||||||
"@[<hov 2>Cyclic dependency detected between the following variables of \
|
"@[<hov 2>Cyclic dependency detected between the following variables of \
|
||||||
scope %a:@ @[<hv>%a@]@]"
|
scope %a:@ @[<hv>%a@]@]"
|
||||||
ScopeName.format scope.scope_uid
|
ScopeName.format scope.scope_uid
|
||||||
@ -196,12 +196,12 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
|
|||||||
if Vertex.equal v_used v_defined then
|
if Vertex.equal v_used v_defined then
|
||||||
match def_key with
|
match def_key with
|
||||||
| _, Ast.ScopeDef.Var _ ->
|
| _, Ast.ScopeDef.Var _ ->
|
||||||
Message.raise_spanned_error fv_def_pos
|
Message.error ~pos:fv_def_pos
|
||||||
"The variable %a is used in one of its definitions, but \
|
"The variable %a is used in one of its definitions, but \
|
||||||
recursion is forbidden in Catala"
|
recursion is forbidden in Catala"
|
||||||
Ast.ScopeDef.format def_key
|
Ast.ScopeDef.format def_key
|
||||||
| v, Ast.ScopeDef.SubScopeInput _ ->
|
| v, Ast.ScopeDef.SubScopeInput _ ->
|
||||||
Message.raise_spanned_error fv_def_pos
|
Message.error ~pos:fv_def_pos
|
||||||
"The subscope %a is used in the definition of its own \
|
"The subscope %a is used in the definition of its own \
|
||||||
input %a, but recursion is forbidden in Catala"
|
input %a, but recursion is forbidden in Catala"
|
||||||
ScopeVar.format (Mark.remove v) Ast.ScopeDef.format def_key
|
ScopeVar.format (Mark.remove v) Ast.ScopeDef.format def_key
|
||||||
@ -407,12 +407,13 @@ let build_exceptions_graph
|
|||||||
in
|
in
|
||||||
(* We check the consistency*)
|
(* We check the consistency*)
|
||||||
if LabelName.compare label_from label_to = 0 then
|
if LabelName.compare label_from label_to = 0 then
|
||||||
Message.raise_spanned_error edge_pos
|
Message.error ~pos:edge_pos
|
||||||
"Cannot define rule as an exception to itself";
|
"Cannot define rule as an exception to itself";
|
||||||
List.iter
|
List.iter
|
||||||
(fun edge ->
|
(fun edge ->
|
||||||
if LabelName.compare edge.label_to label_to <> 0 then
|
if LabelName.compare edge.label_to label_to <> 0 then
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
(( Some
|
(( Some
|
||||||
"This definition contradicts other exception \
|
"This definition contradicts other exception \
|
||||||
definitions:",
|
definitions:",
|
||||||
@ -498,7 +499,7 @@ let check_for_exception_cycle
|
|||||||
scc
|
scc
|
||||||
in
|
in
|
||||||
let v, _ = RuleName.Map.choose (List.hd scc).rules in
|
let v, _ = RuleName.Map.choose (List.hd scc).rules in
|
||||||
Message.raise_multispanned_error spans
|
Message.error ~extra_pos:spans
|
||||||
"Exception cycle detected when defining %a: each of these %d exceptions \
|
"Exception cycle detected when defining %a: each of these %d exceptions \
|
||||||
applies over the previous one, and the first applies over the last"
|
applies over the previous one, and the first applies over the last"
|
||||||
RuleName.format v (List.length scc)
|
RuleName.format v (List.length scc)
|
||||||
|
@ -77,7 +77,7 @@ let translate_binop :
|
|||||||
| S.KDec -> [TLit TRat; TLit TRat]
|
| S.KDec -> [TLit TRat; TLit TRat]
|
||||||
| S.KMoney -> [TLit TMoney; TLit TRat]
|
| S.KMoney -> [TLit TMoney; TLit TRat]
|
||||||
| S.KDate ->
|
| S.KDate ->
|
||||||
Message.raise_spanned_error op_pos
|
Message.error ~pos:op_pos
|
||||||
"This operator doesn't exist, dates can't be multiplied"
|
"This operator doesn't exist, dates can't be multiplied"
|
||||||
| S.KDuration -> [TLit TDuration; TLit TInt])
|
| S.KDuration -> [TLit TDuration; TLit TInt])
|
||||||
| S.Div k ->
|
| S.Div k ->
|
||||||
@ -88,7 +88,7 @@ let translate_binop :
|
|||||||
| S.KDec -> [TLit TRat; TLit TRat]
|
| S.KDec -> [TLit TRat; TLit TRat]
|
||||||
| S.KMoney -> [TLit TMoney; TLit TMoney]
|
| S.KMoney -> [TLit TMoney; TLit TMoney]
|
||||||
| S.KDate ->
|
| S.KDate ->
|
||||||
Message.raise_spanned_error op_pos
|
Message.error ~pos:op_pos
|
||||||
"This operator doesn't exist, dates can't be divided"
|
"This operator doesn't exist, dates can't be divided"
|
||||||
| S.KDuration -> [TLit TDuration; TLit TDuration])
|
| S.KDuration -> [TLit TDuration; TLit TDuration])
|
||||||
| S.Lt k | S.Lte k | S.Gt k | S.Gte k ->
|
| S.Lt k | S.Lte k | S.Gt k | S.Gte k ->
|
||||||
@ -126,7 +126,7 @@ let translate_unop ((op, op_pos) : S.unop Mark.pos) pos arg : Ast.expr boxed =
|
|||||||
| S.KDec -> TLit TRat
|
| S.KDec -> TLit TRat
|
||||||
| S.KMoney -> TLit TMoney
|
| S.KMoney -> TLit TMoney
|
||||||
| S.KDate ->
|
| S.KDate ->
|
||||||
Message.raise_spanned_error op_pos
|
Message.error ~pos:op_pos
|
||||||
"This operator doesn't exist, dates can't be negative"
|
"This operator doesn't exist, dates can't be negative"
|
||||||
| S.KDuration -> TLit TDuration)
|
| S.KDuration -> TLit TDuration)
|
||||||
|
|
||||||
@ -138,9 +138,9 @@ let raise_error_cons_not_found
|
|||||||
Suggestions.suggestion_minimum_levenshtein_distance_association constructors
|
Suggestions.suggestion_minimum_levenshtein_distance_association constructors
|
||||||
(Mark.remove constructor)
|
(Mark.remove constructor)
|
||||||
in
|
in
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
~span_msg:(fun ppf -> Format.fprintf ppf "Here is your code :")
|
~pos_msg:(fun ppf -> Format.fprintf ppf "Here is your code :")
|
||||||
~suggestion:closest_constructors (Mark.get constructor)
|
~pos:(Mark.get constructor) ~suggestion:closest_constructors
|
||||||
"The name of this constructor has not been defined before@ (it's probably \
|
"The name of this constructor has not been defined before@ (it's probably \
|
||||||
a typographical error)."
|
a typographical error)."
|
||||||
|
|
||||||
@ -152,7 +152,7 @@ let rec disambiguate_constructor
|
|||||||
match constructor0 with
|
match constructor0 with
|
||||||
| [c] -> Mark.remove c
|
| [c] -> Mark.remove c
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"The deep pattern matching syntactic sugar is not yet supported"
|
"The deep pattern matching syntactic sugar is not yet supported"
|
||||||
in
|
in
|
||||||
let possible_c_uids =
|
let possible_c_uids =
|
||||||
@ -173,7 +173,7 @@ let rec disambiguate_constructor
|
|||||||
match path with
|
match path with
|
||||||
| [] ->
|
| [] ->
|
||||||
if EnumName.Map.cardinal possible_c_uids > 1 then
|
if EnumName.Map.cardinal possible_c_uids > 1 then
|
||||||
Message.raise_spanned_error (Mark.get constructor)
|
Message.error ~pos:(Mark.get constructor)
|
||||||
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
|
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
|
||||||
it by prefixing it with the enum name."
|
it by prefixing it with the enum name."
|
||||||
(EnumName.Map.format_keys ~pp_sep:(fun fmt () ->
|
(EnumName.Map.format_keys ~pp_sep:(fun fmt () ->
|
||||||
@ -187,8 +187,8 @@ let rec disambiguate_constructor
|
|||||||
let c_uid = EnumName.Map.find e_uid possible_c_uids in
|
let c_uid = EnumName.Map.find e_uid possible_c_uids in
|
||||||
e_uid, c_uid
|
e_uid, c_uid
|
||||||
with EnumName.Map.Not_found _ ->
|
with EnumName.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error pos "Enum %s does not contain case %s"
|
Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum)
|
||||||
(Mark.remove enum) (Mark.remove constructor))
|
(Mark.remove constructor))
|
||||||
| mod_id :: path ->
|
| mod_id :: path ->
|
||||||
let constructor =
|
let constructor =
|
||||||
List.map (Mark.map (fun (_, c) -> path, c)) constructor0
|
List.map (Mark.map (fun (_, c) -> path, c)) constructor0
|
||||||
@ -210,8 +210,8 @@ let rec check_formula (op, pos_op) e =
|
|||||||
(* Xor is mathematically associative, but without a useful semantics ([a
|
(* Xor is mathematically associative, but without a useful semantics ([a
|
||||||
xor b xor c] is most likely an error since it's true for [a = b = c =
|
xor b xor c] is most likely an error since it's true for [a = b = c =
|
||||||
true]) *)
|
true]) *)
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[None, pos_op; None, pos_op1]
|
~extra_pos:[None, pos_op; None, pos_op1]
|
||||||
"Please add parentheses to explicit which of these operators should be \
|
"Please add parentheses to explicit which of these operators should be \
|
||||||
applied first";
|
applied first";
|
||||||
check_formula (op1, pos_op1) e1;
|
check_formula (op1, pos_op1) e1;
|
||||||
@ -352,21 +352,21 @@ let rec translate_expr
|
|||||||
| LNumber ((Int i, _), Some (Day, _)) ->
|
| LNumber ((Int i, _), Some (Day, _)) ->
|
||||||
LDuration (Runtime.duration_of_numbers 0 0 (int_of_string i))
|
LDuration (Runtime.duration_of_numbers 0 0 (int_of_string i))
|
||||||
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
|
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Impossible to specify decimal amounts of days, months or years"
|
"Impossible to specify decimal amounts of days, months or years"
|
||||||
| LDate date ->
|
| LDate date ->
|
||||||
if date.literal_date_month > 12 then
|
if date.literal_date_month > 12 then
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"There is an error in this date: the month number is bigger than 12";
|
"There is an error in this date: the month number is bigger than 12";
|
||||||
if date.literal_date_day > 31 then
|
if date.literal_date_day > 31 then
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"There is an error in this date: the day number is bigger than 31";
|
"There is an error in this date: the day number is bigger than 31";
|
||||||
LDate
|
LDate
|
||||||
(try
|
(try
|
||||||
Runtime.date_of_numbers date.literal_date_year
|
Runtime.date_of_numbers date.literal_date_year
|
||||||
date.literal_date_month date.literal_date_day
|
date.literal_date_month date.literal_date_day
|
||||||
with Runtime.ImpossibleDate ->
|
with Runtime.ImpossibleDate ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"There is an error in this date, it does not correspond to a \
|
"There is an error in this date, it does not correspond to a \
|
||||||
correct calendar day")
|
correct calendar day")
|
||||||
in
|
in
|
||||||
@ -379,7 +379,7 @@ let rec translate_expr
|
|||||||
Expr.make_var uid emark
|
Expr.make_var uid emark
|
||||||
(* the whole box thing is to accomodate for this case *)
|
(* the whole box thing is to accomodate for this case *)
|
||||||
| Some uid, Some state ->
|
| Some uid, Some state ->
|
||||||
Message.raise_spanned_error (Mark.get state)
|
Message.error ~pos:(Mark.get state)
|
||||||
"%a is a local variable, it has no states" Print.var uid
|
"%a is a local variable, it has no states" Print.var uid
|
||||||
| None, state -> (
|
| None, state -> (
|
||||||
match Ident.Map.find_opt x scope_vars with
|
match Ident.Map.find_opt x scope_vars with
|
||||||
@ -393,14 +393,14 @@ let rec translate_expr
|
|||||||
match state, x_sig.var_sig_states_list, inside_definition_of with
|
match state, x_sig.var_sig_states_list, inside_definition_of with
|
||||||
| None, [], _ -> None
|
| None, [], _ -> None
|
||||||
| Some st, [], _ ->
|
| Some st, [], _ ->
|
||||||
Message.raise_spanned_error (Mark.get st)
|
Message.error ~pos:(Mark.get st)
|
||||||
"Variable %a does not define states" ScopeVar.format uid
|
"Variable %a does not define states" ScopeVar.format uid
|
||||||
| st, states, Some (((x'_uid, _), Ast.ScopeDef.Var sx'), _)
|
| st, states, Some (((x'_uid, _), Ast.ScopeDef.Var sx'), _)
|
||||||
when ScopeVar.equal uid x'_uid -> (
|
when ScopeVar.equal uid x'_uid -> (
|
||||||
if st <> None then
|
if st <> None then
|
||||||
(* TODO *)
|
(* TODO *)
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get (Option.get st))
|
~pos:(Mark.get (Option.get st))
|
||||||
"Referring to a previous state of the variable being defined \
|
"Referring to a previous state of the variable being defined \
|
||||||
is not supported at the moment.";
|
is not supported at the moment.";
|
||||||
match sx' with
|
match sx' with
|
||||||
@ -410,7 +410,7 @@ let rec translate_expr
|
|||||||
state but variable has states"
|
state but variable has states"
|
||||||
| Some inside_def_state ->
|
| Some inside_def_state ->
|
||||||
if StateName.compare inside_def_state (List.hd states) = 0 then
|
if StateName.compare inside_def_state (List.hd states) = 0 then
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"It is impossible to refer to the variable you are defining \
|
"It is impossible to refer to the variable you are defining \
|
||||||
when defining its first state."
|
when defining its first state."
|
||||||
else
|
else
|
||||||
@ -428,11 +428,13 @@ let rec translate_expr
|
|||||||
Ident.Map.find_opt (Mark.remove st) x_sig.var_sig_states_idmap
|
Ident.Map.find_opt (Mark.remove st) x_sig.var_sig_states_idmap
|
||||||
with
|
with
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
~suggestion:(List.map StateName.to_string states)
|
~suggestion:(List.map StateName.to_string states)
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get st;
|
None, Mark.get st;
|
||||||
Some "Variable defined here", Mark.get (ScopeVar.get_info uid);
|
( Some "Variable defined here",
|
||||||
|
Mark.get (ScopeVar.get_info uid) );
|
||||||
]
|
]
|
||||||
"Reference to unknown variable state"
|
"Reference to unknown variable state"
|
||||||
| some -> some)
|
| some -> some)
|
||||||
@ -451,7 +453,7 @@ let rec translate_expr
|
|||||||
match Ident.Map.find_opt x ctxt.local.topdefs with
|
match Ident.Map.find_opt x ctxt.local.topdefs with
|
||||||
| Some v ->
|
| Some v ->
|
||||||
if state <> None then
|
if state <> None then
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Access to intermediate states is only allowed for variables of \
|
"Access to intermediate states is only allowed for variables of \
|
||||||
the current scope";
|
the current scope";
|
||||||
Expr.elocation
|
Expr.elocation
|
||||||
@ -461,7 +463,7 @@ let rec translate_expr
|
|||||||
Name_resolution.raise_unknown_identifier
|
Name_resolution.raise_unknown_identifier
|
||||||
"for a local, scope-wide or global variable" (x, pos))))
|
"for a local, scope-wide or global variable" (x, pos))))
|
||||||
| Ident (_ :: _, (_, pos), Some _) ->
|
| Ident (_ :: _, (_, pos), Some _) ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Access to intermediate states is only allowed for variables of the \
|
"Access to intermediate states is only allowed for variables of the \
|
||||||
current scope"
|
current scope"
|
||||||
| Ident (path, name, None) -> (
|
| Ident (path, name, None) -> (
|
||||||
@ -499,14 +501,13 @@ let rec translate_expr
|
|||||||
in
|
in
|
||||||
Expr.eappop ~op ~tys:[ty, pos] ~args:[rec_helper arg] emark
|
Expr.eappop ~op ~tys:[ty, pos] ~args:[rec_helper arg] emark
|
||||||
| S.Builtin _ ->
|
| S.Builtin _ ->
|
||||||
Message.raise_spanned_error pos "Invalid use of built-in: needs one operand"
|
Message.error ~pos "Invalid use of built-in: needs one operand"
|
||||||
| FunCall (f, args) ->
|
| FunCall (f, args) ->
|
||||||
let args = List.map rec_helper args in
|
let args = List.map rec_helper args in
|
||||||
Expr.eapp ~f:(rec_helper f) ~args ~tys:[] emark
|
Expr.eapp ~f:(rec_helper f) ~args ~tys:[] emark
|
||||||
| ScopeCall (((path, id), _), fields) ->
|
| ScopeCall (((path, id), _), fields) ->
|
||||||
if scope = None then
|
if scope = None then
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos "Scope calls are not allowed outside of a scope";
|
||||||
"Scope calls are not allowed outside of a scope";
|
|
||||||
let called_scope, scope_def =
|
let called_scope, scope_def =
|
||||||
let ctxt = Name_resolution.module_ctx ctxt path in
|
let ctxt = Name_resolution.module_ctx ctxt path in
|
||||||
let uid = Name_resolution.get_scope ctxt id in
|
let uid = Name_resolution.get_scope ctxt id in
|
||||||
@ -521,13 +522,14 @@ let rec translate_expr
|
|||||||
with
|
with
|
||||||
| Some (ScopeVar v) -> v
|
| Some (ScopeVar v) -> v
|
||||||
| Some (SubScope _) | None ->
|
| Some (SubScope _) | None ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
~suggestion:(Ident.Map.keys scope_def.var_idmap)
|
~suggestion:(Ident.Map.keys scope_def.var_idmap)
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get fld_id;
|
None, Mark.get fld_id;
|
||||||
( Some
|
( Some
|
||||||
(Format.asprintf "Scope %a declared here" ScopeName.format
|
(Format.asprintf "Scope %a declared here"
|
||||||
called_scope),
|
ScopeName.format called_scope),
|
||||||
Mark.get (ScopeName.get_info called_scope) );
|
Mark.get (ScopeName.get_info called_scope) );
|
||||||
]
|
]
|
||||||
"Scope %a has no input variable %a" ScopeName.format
|
"Scope %a has no input variable %a" ScopeName.format
|
||||||
@ -537,7 +539,7 @@ let rec translate_expr
|
|||||||
(function
|
(function
|
||||||
| None -> Some (rec_helper e)
|
| None -> Some (rec_helper e)
|
||||||
| Some _ ->
|
| Some _ ->
|
||||||
Message.raise_spanned_error (Mark.get fld_id)
|
Message.error ~pos:(Mark.get fld_id)
|
||||||
"Duplicate definition of scope input variable '%a'"
|
"Duplicate definition of scope input variable '%a'"
|
||||||
ScopeVar.format var)
|
ScopeVar.format var)
|
||||||
acc)
|
acc)
|
||||||
@ -565,7 +567,7 @@ let rec translate_expr
|
|||||||
| Some (Name_resolution.TScope (_, { out_struct_name = s_uid; _ })) ->
|
| Some (Name_resolution.TScope (_, { out_struct_name = s_uid; _ })) ->
|
||||||
s_uid
|
s_uid
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Mark.get s_name)
|
Message.error ~pos:(Mark.get s_name)
|
||||||
"This identifier should refer to a struct name"
|
"This identifier should refer to a struct name"
|
||||||
in
|
in
|
||||||
let s_fields =
|
let s_fields =
|
||||||
@ -576,15 +578,15 @@ let rec translate_expr
|
|||||||
StructName.Map.find s_uid
|
StructName.Map.find s_uid
|
||||||
(Ident.Map.find (Mark.remove f_name) ctxt.local.field_idmap)
|
(Ident.Map.find (Mark.remove f_name) ctxt.local.field_idmap)
|
||||||
with StructName.Map.Not_found _ | Ident.Map.Not_found _ ->
|
with StructName.Map.Not_found _ | Ident.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Mark.get f_name)
|
Message.error ~pos:(Mark.get f_name)
|
||||||
"This identifier should refer to a field of struct %s"
|
"This identifier should refer to a field of struct %s"
|
||||||
(Mark.remove s_name)
|
(Mark.remove s_name)
|
||||||
in
|
in
|
||||||
(match StructField.Map.find_opt f_uid s_fields with
|
(match StructField.Map.find_opt f_uid s_fields with
|
||||||
| None -> ()
|
| None -> ()
|
||||||
| Some e_field ->
|
| Some e_field ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[None, Mark.get f_e; None, Expr.pos e_field]
|
~extra_pos:[None, Mark.get f_e; None, Expr.pos e_field]
|
||||||
"The field %a has been defined twice:" StructField.format f_uid);
|
"The field %a has been defined twice:" StructField.format f_uid);
|
||||||
let f_e = rec_helper f_e in
|
let f_e = rec_helper f_e in
|
||||||
StructField.Map.add f_uid f_e s_fields)
|
StructField.Map.add f_uid f_e s_fields)
|
||||||
@ -596,7 +598,7 @@ let rec translate_expr
|
|||||||
(fun expected_f _ -> not (StructField.Map.mem expected_f s_fields))
|
(fun expected_f _ -> not (StructField.Map.mem expected_f s_fields))
|
||||||
expected_s_fields
|
expected_s_fields
|
||||||
then
|
then
|
||||||
Message.raise_spanned_error pos "Missing field(s) for structure %a:@\n%a"
|
Message.error ~pos "Missing field(s) for structure %a:@\n%a"
|
||||||
StructName.format s_uid
|
StructName.format s_uid
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||||
@ -634,7 +636,7 @@ let rec translate_expr
|
|||||||
(* No enum name was specified *)
|
(* No enum name was specified *)
|
||||||
EnumName.Map.cardinal possible_c_uids > 1
|
EnumName.Map.cardinal possible_c_uids > 1
|
||||||
then
|
then
|
||||||
Message.raise_spanned_error pos_constructor
|
Message.error ~pos:pos_constructor
|
||||||
"This constructor name is ambiguous, it can belong to %a. \
|
"This constructor name is ambiguous, it can belong to %a. \
|
||||||
Desambiguate it by prefixing it with the enum name."
|
Desambiguate it by prefixing it with the enum name."
|
||||||
(EnumName.Map.format_keys ~pp_sep:(fun fmt () ->
|
(EnumName.Map.format_keys ~pp_sep:(fun fmt () ->
|
||||||
@ -669,8 +671,8 @@ let rec translate_expr
|
|||||||
| None -> Expr.elit LUnit mark_constructor)
|
| None -> Expr.elit LUnit mark_constructor)
|
||||||
~cons:c_uid ~name:e_uid emark
|
~cons:c_uid ~name:e_uid emark
|
||||||
with EnumName.Map.Not_found _ ->
|
with EnumName.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error pos "Enum %s does not contain case %s"
|
Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum)
|
||||||
(Mark.remove enum) constructor))
|
constructor))
|
||||||
| MatchWith (e1, (cases, _cases_pos)) ->
|
| MatchWith (e1, (cases, _cases_pos)) ->
|
||||||
let e1 = rec_helper e1 in
|
let e1 = rec_helper e1 in
|
||||||
let cases_d, e_uid =
|
let cases_d, e_uid =
|
||||||
@ -682,7 +684,7 @@ let rec translate_expr
|
|||||||
(match snd (Mark.remove pattern) with
|
(match snd (Mark.remove pattern) with
|
||||||
| None -> ()
|
| None -> ()
|
||||||
| Some binding ->
|
| Some binding ->
|
||||||
Message.emit_spanned_warning (Mark.get binding)
|
Message.warning ~pos:(Mark.get binding)
|
||||||
"This binding will be ignored (remove it to suppress warning)");
|
"This binding will be ignored (remove it to suppress warning)");
|
||||||
let enum_uid, c_uid =
|
let enum_uid, c_uid =
|
||||||
disambiguate_constructor ctxt
|
disambiguate_constructor ctxt
|
||||||
@ -872,8 +874,7 @@ let rec translate_expr
|
|||||||
| S.Money -> LMoney (Runtime.money_of_cents_integer i0)
|
| S.Money -> LMoney (Runtime.money_of_cents_integer i0)
|
||||||
| S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0)
|
| S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0)
|
||||||
| t ->
|
| t ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos "It is impossible to sum values of type %a together"
|
||||||
"It is impossible to sum values of type %a together"
|
|
||||||
SurfacePrint.format_primitive_typ t
|
SurfacePrint.format_primitive_typ t
|
||||||
in
|
in
|
||||||
let op_f =
|
let op_f =
|
||||||
@ -962,8 +963,8 @@ and disambiguate_match_and_build_expression
|
|||||||
| Some e_uid ->
|
| Some e_uid ->
|
||||||
if e_uid = e_uid' then e_uid
|
if e_uid = e_uid' then e_uid
|
||||||
else
|
else
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get case.S.match_case_pattern)
|
~pos:(Mark.get case.S.match_case_pattern)
|
||||||
"This case matches a constructor of enumeration %a but previous \
|
"This case matches a constructor of enumeration %a but previous \
|
||||||
case were matching constructors of enumeration %a"
|
case were matching constructors of enumeration %a"
|
||||||
EnumName.format e_uid EnumName.format e_uid'
|
EnumName.format e_uid EnumName.format e_uid'
|
||||||
@ -971,7 +972,8 @@ and disambiguate_match_and_build_expression
|
|||||||
(match EnumConstructor.Map.find_opt c_uid cases_d with
|
(match EnumConstructor.Map.find_opt c_uid cases_d with
|
||||||
| None -> ()
|
| None -> ()
|
||||||
| Some e_case ->
|
| Some e_case ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
|
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
|
||||||
"The constructor %a has been matched twice:" EnumConstructor.format
|
"The constructor %a has been matched twice:" EnumConstructor.format
|
||||||
c_uid);
|
c_uid);
|
||||||
@ -990,7 +992,8 @@ and disambiguate_match_and_build_expression
|
|||||||
| S.WildCard match_case_expr -> (
|
| S.WildCard match_case_expr -> (
|
||||||
let nb_cases = List.length cases in
|
let nb_cases = List.length cases in
|
||||||
let raise_wildcard_not_last_case_err () =
|
let raise_wildcard_not_last_case_err () =
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "Not ending wildcard:", case_pos;
|
Some "Not ending wildcard:", case_pos;
|
||||||
( Some "Next reachable case:",
|
( Some "Next reachable case:",
|
||||||
@ -1001,7 +1004,7 @@ and disambiguate_match_and_build_expression
|
|||||||
match e_uid with
|
match e_uid with
|
||||||
| None ->
|
| None ->
|
||||||
if 1 = nb_cases then
|
if 1 = nb_cases then
|
||||||
Message.raise_spanned_error case_pos
|
Message.error ~pos:case_pos
|
||||||
"Couldn't infer the enumeration name from lonely wildcard \
|
"Couldn't infer the enumeration name from lonely wildcard \
|
||||||
(wildcard cannot be used as single match case)"
|
(wildcard cannot be used as single match case)"
|
||||||
else raise_wildcard_not_last_case_err ()
|
else raise_wildcard_not_last_case_err ()
|
||||||
@ -1015,7 +1018,7 @@ and disambiguate_match_and_build_expression
|
|||||||
| None -> Some c_uid)
|
| None -> Some c_uid)
|
||||||
in
|
in
|
||||||
if EnumConstructor.Map.is_empty missing_constructors then
|
if EnumConstructor.Map.is_empty missing_constructors then
|
||||||
Message.emit_spanned_warning case_pos
|
Message.warning ~pos:case_pos
|
||||||
"Unreachable match case, all constructors of the enumeration %a \
|
"Unreachable match case, all constructors of the enumeration %a \
|
||||||
are already specified"
|
are already specified"
|
||||||
EnumName.format e_uid;
|
EnumName.format e_uid;
|
||||||
@ -1078,12 +1081,13 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
|
|||||||
match pdecl, pdefs with
|
match pdecl, pdefs with
|
||||||
| [], [] -> ()
|
| [], [] -> ()
|
||||||
| [], (arg, apos) :: _ ->
|
| [], (arg, apos) :: _ ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
|
~extra_pos:[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
|
||||||
"This definition has an extra, undeclared argument '%a'" Print.lit_style
|
"This definition has an extra, undeclared argument '%a'" Print.lit_style
|
||||||
arg
|
arg
|
||||||
| (arg, apos) :: _, [] ->
|
| (arg, apos) :: _, [] ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "Argument declared here:", apos;
|
Some "Argument declared here:", apos;
|
||||||
Some "Mismatching definition:", pos_def;
|
Some "Mismatching definition:", pos_def;
|
||||||
@ -1092,9 +1096,11 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
|
|||||||
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
|
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
|
||||||
arglist_eq_check pos_decl pos_def pdecl pdefs
|
arglist_eq_check pos_decl pos_def pdecl pdefs
|
||||||
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
|
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos;
|
Some "Argument declared here:", decl_apos;
|
||||||
|
Some "Defined here:", def_apos;
|
||||||
]
|
]
|
||||||
"Function argument name mismatch between declaration ('%a') and \
|
"Function argument name mismatch between declaration ('%a') and \
|
||||||
definition ('%a')"
|
definition ('%a')"
|
||||||
@ -1111,17 +1117,20 @@ let process_rule_parameters
|
|||||||
match declared_params, def.S.definition_parameter with
|
match declared_params, def.S.definition_parameter with
|
||||||
| None, None -> Ident.Map.empty, None
|
| None, None -> Ident.Map.empty, None
|
||||||
| None, Some (_, pos) ->
|
| None, Some (_, pos) ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "Declared here without arguments", decl_pos;
|
Some "Declared here without arguments", decl_pos;
|
||||||
Some "Unexpected arguments appearing here", pos;
|
Some "Unexpected arguments appearing here", pos;
|
||||||
]
|
]
|
||||||
"Extra arguments in this definition of %a" Ast.ScopeDef.format decl_name
|
"Extra arguments in this definition of %a" Ast.ScopeDef.format decl_name
|
||||||
| Some (_, pos), None ->
|
| Some (_, pos), None ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "Arguments declared here", pos;
|
Some "Arguments declared here", pos;
|
||||||
Some "Definition missing the arguments", Mark.get def.S.definition_name;
|
( Some "Definition missing the arguments",
|
||||||
|
Mark.get def.S.definition_name );
|
||||||
]
|
]
|
||||||
"This definition for %a is missing the arguments" Ast.ScopeDef.format
|
"This definition for %a is missing the arguments" Ast.ScopeDef.format
|
||||||
decl_name
|
decl_name
|
||||||
@ -1222,7 +1231,7 @@ let process_def
|
|||||||
in
|
in
|
||||||
ExceptionToLabel (label_id, Mark.get label_str)
|
ExceptionToLabel (label_id, Mark.get label_str)
|
||||||
with Ident.Map.Not_found _ ->
|
with Ident.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Mark.get label_str)
|
Message.error ~pos:(Mark.get label_str)
|
||||||
"Unknown label for the scope variable %a: \"%s\""
|
"Unknown label for the scope variable %a: \"%s\""
|
||||||
Ast.ScopeDef.format def_key (Mark.remove label_str))
|
Ast.ScopeDef.format def_key (Mark.remove label_str))
|
||||||
in
|
in
|
||||||
@ -1337,8 +1346,8 @@ let process_scope_use_item
|
|||||||
scope.scope_options
|
scope.scope_options
|
||||||
with
|
with
|
||||||
| Some (_, old_pos) ->
|
| Some (_, old_pos) ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[None, old_pos; None, Mark.get item]
|
~extra_pos:[None, old_pos; None, Mark.get item]
|
||||||
"You cannot set multiple date rounding modes"
|
"You cannot set multiple date rounding modes"
|
||||||
| None ->
|
| None ->
|
||||||
{
|
{
|
||||||
@ -1390,10 +1399,11 @@ let check_unlabeled_exception
|
|||||||
| S.UnlabeledException -> (
|
| S.UnlabeledException -> (
|
||||||
match scope_def_ctxt.default_exception_rulename with
|
match scope_def_ctxt.default_exception_rulename with
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error (Mark.get item)
|
Message.error ~pos:(Mark.get item)
|
||||||
"This exception does not have a corresponding definition"
|
"This exception does not have a corresponding definition"
|
||||||
| Some (Ambiguous pos) ->
|
| Some (Ambiguous pos) ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
([Some "Ambiguous exception", Mark.get item]
|
([Some "Ambiguous exception", Mark.get item]
|
||||||
@ List.map (fun p -> Some "Candidate definition", p) pos)
|
@ List.map (fun p -> Some "Candidate definition", p) pos)
|
||||||
"This exception can refer to several definitions. Try using labels \
|
"This exception can refer to several definitions. Try using labels \
|
||||||
@ -1451,7 +1461,7 @@ let process_topdef
|
|||||||
let () =
|
let () =
|
||||||
match tys with
|
match tys with
|
||||||
| [(Data (S.TTuple _), pos)] ->
|
| [(Data (S.TTuple _), pos)] ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Defining arguments of a function as a tuple is not supported, \
|
"Defining arguments of a function as a tuple is not supported, \
|
||||||
please name the individual arguments"
|
please name the individual arguments"
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
@ -1472,7 +1482,8 @@ let process_topdef
|
|||||||
| None, eopt -> Some (eopt, typ)
|
| None, eopt -> Some (eopt, typ)
|
||||||
| Some (eopt0, ty0), eopt -> (
|
| Some (eopt0, ty0), eopt -> (
|
||||||
let err msg =
|
let err msg =
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get (TopdefName.get_info id);
|
None, Mark.get (TopdefName.get_info id);
|
||||||
None, Mark.get def.S.topdef_name;
|
None, Mark.get def.S.topdef_name;
|
||||||
|
@ -37,8 +37,8 @@ let detect_empty_definitions (p : program) : unit =
|
|||||||
| NoInput -> true
|
| NoInput -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
then
|
then
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
(ScopeDef.get_position scope_def_key)
|
~pos:(ScopeDef.get_position scope_def_key)
|
||||||
"In scope \"%a\", the variable \"%a\" is declared but never \
|
"In scope \"%a\", the variable \"%a\" is declared but never \
|
||||||
defined; did you forget something?"
|
defined; did you forget something?"
|
||||||
ScopeName.format scope_name Ast.ScopeDef.format scope_def_key)
|
ScopeName.format scope_name Ast.ScopeDef.format scope_def_key)
|
||||||
@ -94,7 +94,7 @@ let detect_identical_rules (p : program) : unit =
|
|||||||
RuleExpressionsMap.iter
|
RuleExpressionsMap.iter
|
||||||
(fun _ pos ->
|
(fun _ pos ->
|
||||||
if List.length pos > 1 then
|
if List.length pos > 1 then
|
||||||
Message.emit_multispanned_warning pos
|
Message.warning ~extra_pos:pos
|
||||||
"These %s have identical justifications and consequences; is \
|
"These %s have identical justifications and consequences; is \
|
||||||
it a mistake?"
|
it a mistake?"
|
||||||
(if scope_def.scope_def_is_condition then "rules"
|
(if scope_def.scope_def_is_condition then "rules"
|
||||||
@ -153,8 +153,8 @@ let detect_unused_struct_fields (p : program) : unit =
|
|||||||
&& not (StructField.Set.mem field scope_out_structs_fields))
|
&& not (StructField.Set.mem field scope_out_structs_fields))
|
||||||
fields
|
fields
|
||||||
then
|
then
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
(snd (StructName.get_info s_name))
|
~pos:(snd (StructName.get_info s_name))
|
||||||
"The structure \"%a\" is never used; maybe it's unnecessary?"
|
"The structure \"%a\" is never used; maybe it's unnecessary?"
|
||||||
StructName.format s_name
|
StructName.format s_name
|
||||||
else
|
else
|
||||||
@ -164,8 +164,8 @@ let detect_unused_struct_fields (p : program) : unit =
|
|||||||
(not (StructField.Set.mem field struct_fields_used))
|
(not (StructField.Set.mem field struct_fields_used))
|
||||||
&& not (StructField.Set.mem field scope_out_structs_fields)
|
&& not (StructField.Set.mem field scope_out_structs_fields)
|
||||||
then
|
then
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
(snd (StructField.get_info field))
|
~pos:(snd (StructField.get_info field))
|
||||||
"The field \"%a\" of struct @{<yellow>\"%a\"@} is never \
|
"The field \"%a\" of struct @{<yellow>\"%a\"@} is never \
|
||||||
used; maybe it's unnecessary?"
|
used; maybe it's unnecessary?"
|
||||||
StructField.format field StructName.format s_name)
|
StructField.format field StructName.format s_name)
|
||||||
@ -211,8 +211,8 @@ let detect_unused_enum_constructors (p : program) : unit =
|
|||||||
not (EnumConstructor.Set.mem cons enum_constructors_used))
|
not (EnumConstructor.Set.mem cons enum_constructors_used))
|
||||||
constructors
|
constructors
|
||||||
then
|
then
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
(snd (EnumName.get_info e_name))
|
~pos:(snd (EnumName.get_info e_name))
|
||||||
"The enumeration \"%a\" is never used; maybe it's unnecessary?"
|
"The enumeration \"%a\" is never used; maybe it's unnecessary?"
|
||||||
EnumName.format e_name
|
EnumName.format e_name
|
||||||
else
|
else
|
||||||
@ -221,8 +221,8 @@ let detect_unused_enum_constructors (p : program) : unit =
|
|||||||
if
|
if
|
||||||
not (EnumConstructor.Set.mem constructor enum_constructors_used)
|
not (EnumConstructor.Set.mem constructor enum_constructors_used)
|
||||||
then
|
then
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
(snd (EnumConstructor.get_info constructor))
|
~pos:(snd (EnumConstructor.get_info constructor))
|
||||||
"The constructor \"%a\" of enumeration \"%a\" is never used; \
|
"The constructor \"%a\" of enumeration \"%a\" is never used; \
|
||||||
maybe it's unnecessary?"
|
maybe it's unnecessary?"
|
||||||
EnumConstructor.format constructor EnumName.format e_name)
|
EnumConstructor.format constructor EnumName.format e_name)
|
||||||
@ -266,8 +266,8 @@ let detect_dead_code (p : program) : unit =
|
|||||||
in
|
in
|
||||||
let is_alive = Reachability.analyze is_alive scope_dependencies in
|
let is_alive = Reachability.analyze is_alive scope_dependencies in
|
||||||
let emit_unused_warning vx =
|
let emit_unused_warning vx =
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
(Mark.get (Dependency.Vertex.info vx))
|
~pos:(Mark.get (Dependency.Vertex.info vx))
|
||||||
"Unused varible: %a does not contribute to computing any of scope %a \
|
"Unused varible: %a does not contribute to computing any of scope %a \
|
||||||
outputs. Did you forget something?"
|
outputs. Did you forget something?"
|
||||||
Dependency.Vertex.format vx ScopeName.format scope_name
|
Dependency.Vertex.format vx ScopeName.format scope_name
|
||||||
|
@ -99,12 +99,12 @@ type context = {
|
|||||||
(** Temporary function raising an error message saying that a feature is not
|
(** Temporary function raising an error message saying that a feature is not
|
||||||
supported yet *)
|
supported yet *)
|
||||||
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
|
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
|
||||||
Message.raise_spanned_error pos "Unsupported feature: %s" msg
|
Message.error ~pos "Unsupported feature: %s" msg
|
||||||
|
|
||||||
(** Function to call whenever an identifier used somewhere has not been declared
|
(** Function to call whenever an identifier used somewhere has not been declared
|
||||||
in the program previously *)
|
in the program previously *)
|
||||||
let raise_unknown_identifier (msg : string) (ident : Ident.t Mark.pos) =
|
let raise_unknown_identifier (msg : string) (ident : Ident.t Mark.pos) =
|
||||||
Message.raise_spanned_error (Mark.get ident)
|
Message.error ~pos:(Mark.get ident)
|
||||||
"@{<yellow>\"%s\"@}: unknown identifier %s" (Mark.remove ident) msg
|
"@{<yellow>\"%s\"@}: unknown identifier %s" (Mark.remove ident) msg
|
||||||
|
|
||||||
(** Gets the type associated to an uid *)
|
(** Gets the type associated to an uid *)
|
||||||
@ -181,62 +181,63 @@ let get_enum ctxt id =
|
|||||||
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
||||||
| TEnum id -> id
|
| TEnum id -> id
|
||||||
| TStruct sid ->
|
| TStruct sid ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get id;
|
None, Mark.get id;
|
||||||
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
||||||
]
|
]
|
||||||
"Expecting an enum, but found a structure"
|
"Expecting an enum, but found a structure"
|
||||||
| TScope (sid, _) ->
|
| TScope (sid, _) ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get id;
|
None, Mark.get id;
|
||||||
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
|
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
|
||||||
]
|
]
|
||||||
"Expecting an enum, but found a scope"
|
"Expecting an enum, but found a scope"
|
||||||
| exception Ident.Map.Not_found _ ->
|
| exception Ident.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Mark.get id) "No enum named %s found"
|
Message.error ~pos:(Mark.get id) "No enum named %s found" (Mark.remove id)
|
||||||
(Mark.remove id)
|
|
||||||
|
|
||||||
let get_struct ctxt id =
|
let get_struct ctxt id =
|
||||||
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
||||||
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
|
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
|
||||||
| TEnum eid ->
|
| TEnum eid ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get id;
|
None, Mark.get id;
|
||||||
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
||||||
]
|
]
|
||||||
"Expecting a struct, but found an enum"
|
"Expecting a struct, but found an enum"
|
||||||
| exception Ident.Map.Not_found _ ->
|
| exception Ident.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Mark.get id) "No struct named %s found"
|
Message.error ~pos:(Mark.get id) "No struct named %s found" (Mark.remove id)
|
||||||
(Mark.remove id)
|
|
||||||
|
|
||||||
let get_scope ctxt id =
|
let get_scope ctxt id =
|
||||||
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
||||||
| TScope (id, _) -> id
|
| TScope (id, _) -> id
|
||||||
| TEnum eid ->
|
| TEnum eid ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get id;
|
None, Mark.get id;
|
||||||
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
||||||
]
|
]
|
||||||
"Expecting an scope, but found an enum"
|
"Expecting an scope, but found an enum"
|
||||||
| TStruct sid ->
|
| TStruct sid ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get id;
|
None, Mark.get id;
|
||||||
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
||||||
]
|
]
|
||||||
"Expecting an scope, but found a structure"
|
"Expecting an scope, but found a structure"
|
||||||
| exception Ident.Map.Not_found _ ->
|
| exception Ident.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Mark.get id) "No scope named %s found"
|
Message.error ~pos:(Mark.get id) "No scope named %s found" (Mark.remove id)
|
||||||
(Mark.remove id)
|
|
||||||
|
|
||||||
let get_modname ctxt (id, pos) =
|
let get_modname ctxt (id, pos) =
|
||||||
match Ident.Map.find_opt id ctxt.local.used_modules with
|
match Ident.Map.find_opt id ctxt.local.used_modules with
|
||||||
| None ->
|
| None -> Message.error ~pos "Module \"@{<blue>%s@}\" not found" id
|
||||||
Message.raise_spanned_error pos "Module \"@{<blue>%s@}\" not found" id
|
|
||||||
| Some modname -> modname
|
| Some modname -> modname
|
||||||
|
|
||||||
let get_module_ctx ctxt id =
|
let get_module_ctx ctxt id =
|
||||||
@ -269,8 +270,8 @@ let process_subscope_decl
|
|||||||
| ScopeVar v -> ScopeVar.get_info v
|
| ScopeVar v -> ScopeVar.get_info v
|
||||||
| SubScope (ssc, _, _) -> ScopeVar.get_info ssc
|
| SubScope (ssc, _, _) -> ScopeVar.get_info ssc
|
||||||
in
|
in
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[Some "first use", Mark.get info; Some "second use", s_pos]
|
~extra_pos:[Some "first use", Mark.get info; Some "second use", s_pos]
|
||||||
"Subscope name @{<yellow>\"%s\"@} already used" (Mark.remove subscope)
|
"Subscope name @{<yellow>\"%s\"@} already used" (Mark.remove subscope)
|
||||||
| None ->
|
| None ->
|
||||||
let sub_scope_uid = ScopeVar.fresh (name, name_pos) in
|
let sub_scope_uid = ScopeVar.fresh (name, name_pos) in
|
||||||
@ -331,14 +332,14 @@ let rec process_base_typ
|
|||||||
| Some (TScope (_, scope_str)) ->
|
| Some (TScope (_, scope_str)) ->
|
||||||
TStruct scope_str.out_struct_name, typ_pos
|
TStruct scope_str.out_struct_name, typ_pos
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error typ_pos
|
Message.error ~pos:typ_pos
|
||||||
"Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
|
"Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
|
||||||
declared"
|
declared"
|
||||||
ident)
|
ident)
|
||||||
| Surface.Ast.Named ((modul, mpos) :: path, id) -> (
|
| Surface.Ast.Named ((modul, mpos) :: path, id) -> (
|
||||||
match Ident.Map.find_opt modul ctxt.local.used_modules with
|
match Ident.Map.find_opt modul ctxt.local.used_modules with
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error mpos
|
Message.error ~pos:mpos
|
||||||
"This refers to module @{<blue>%s@}, which was not found" modul
|
"This refers to module @{<blue>%s@}, which was not found" modul
|
||||||
| Some mname ->
|
| Some mname ->
|
||||||
let mod_ctxt = ModuleName.Map.find mname ctxt.modules in
|
let mod_ctxt = ModuleName.Map.find mname ctxt.modules in
|
||||||
@ -372,8 +373,8 @@ let process_data_decl
|
|||||||
| ScopeVar v -> ScopeVar.get_info v
|
| ScopeVar v -> ScopeVar.get_info v
|
||||||
| SubScope (ssc, _, _) -> ScopeVar.get_info ssc
|
| SubScope (ssc, _, _) -> ScopeVar.get_info ssc
|
||||||
in
|
in
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[Some "First use:", Mark.get info; Some "Second use:", pos]
|
~extra_pos:[Some "First use:", Mark.get info; Some "Second use:", pos]
|
||||||
"Variable name @{<yellow>\"%s\"@} already used" name
|
"Variable name @{<yellow>\"%s\"@} already used" name
|
||||||
| None ->
|
| None ->
|
||||||
let uid = ScopeVar.fresh (name, pos) in
|
let uid = ScopeVar.fresh (name, pos) in
|
||||||
@ -388,7 +389,8 @@ let process_data_decl
|
|||||||
(fun state_id ((states_idmap : StateName.t Ident.Map.t), states_list) ->
|
(fun state_id ((states_idmap : StateName.t Ident.Map.t), states_list) ->
|
||||||
let state_id_name = Mark.remove state_id in
|
let state_id_name = Mark.remove state_id in
|
||||||
if Ident.Map.mem state_id_name states_idmap then
|
if Ident.Map.mem state_id_name states_idmap then
|
||||||
Message.raise_multispanned_error_full
|
Message.error
|
||||||
|
~fmt_pos:
|
||||||
[
|
[
|
||||||
( Some
|
( Some
|
||||||
(fun ppf ->
|
(fun ppf ->
|
||||||
@ -438,8 +440,8 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
|
|||||||
context =
|
context =
|
||||||
let s_uid = get_struct ctxt sdecl.struct_decl_name in
|
let s_uid = get_struct ctxt sdecl.struct_decl_name in
|
||||||
if sdecl.struct_decl_fields = [] then
|
if sdecl.struct_decl_fields = [] then
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get sdecl.struct_decl_name)
|
~pos:(Mark.get sdecl.struct_decl_name)
|
||||||
"The struct %s does not have any fields; give it some for Catala to be \
|
"The struct %s does not have any fields; give it some for Catala to be \
|
||||||
able to accept it."
|
able to accept it."
|
||||||
(Mark.remove sdecl.struct_decl_name);
|
(Mark.remove sdecl.struct_decl_name);
|
||||||
@ -483,8 +485,8 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
|
|||||||
=
|
=
|
||||||
let e_uid = get_enum ctxt edecl.enum_decl_name in
|
let e_uid = get_enum ctxt edecl.enum_decl_name in
|
||||||
if List.length edecl.enum_decl_cases = 0 then
|
if List.length edecl.enum_decl_cases = 0 then
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get edecl.enum_decl_name)
|
~pos:(Mark.get edecl.enum_decl_name)
|
||||||
"The enum %s does not have any cases; give it some for Catala to be able \
|
"The enum %s does not have any cases; give it some for Catala to be able \
|
||||||
to accept it."
|
to accept it."
|
||||||
(Mark.remove edecl.enum_decl_name);
|
(Mark.remove edecl.enum_decl_name);
|
||||||
@ -645,7 +647,8 @@ let typedef_info = function
|
|||||||
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||||
context =
|
context =
|
||||||
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
|
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
|
||||||
Message.raise_multispanned_error_full
|
Message.error
|
||||||
|
~fmt_pos:
|
||||||
[
|
[
|
||||||
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
|
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
|
||||||
Mark.get use );
|
Mark.get use );
|
||||||
@ -779,19 +782,23 @@ let get_def_key
|
|||||||
Some
|
Some
|
||||||
(Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap)
|
(Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap)
|
||||||
with Ident.Map.Not_found _ ->
|
with Ident.Map.Not_found _ ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get state;
|
None, Mark.get state;
|
||||||
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
|
( Some "Variable declaration:",
|
||||||
|
Mark.get (ScopeVar.get_info x_uid) );
|
||||||
]
|
]
|
||||||
"This identifier is not a state declared for variable %a."
|
"This identifier is not a state declared for variable %a."
|
||||||
ScopeVar.format x_uid)
|
ScopeVar.format x_uid)
|
||||||
| None ->
|
| None ->
|
||||||
if not (Ident.Map.is_empty var_sig.var_sig_states_idmap) then
|
if not (Ident.Map.is_empty var_sig.var_sig_states_idmap) then
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Mark.get x;
|
None, Mark.get x;
|
||||||
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
|
( Some "Variable declaration:",
|
||||||
|
Mark.get (ScopeVar.get_info x_uid) );
|
||||||
]
|
]
|
||||||
"This definition does not indicate which state has to be \
|
"This definition does not indicate which state has to be \
|
||||||
considered for variable %a."
|
considered for variable %a."
|
||||||
@ -802,18 +809,17 @@ let get_def_key
|
|||||||
match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
|
match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
|
||||||
| Some (SubScope (v, u, _)) -> v, u
|
| Some (SubScope (v, u, _)) -> v, u
|
||||||
| Some _ ->
|
| Some _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos "Invalid definition, %a is not a subscope"
|
||||||
"Invalid definition, %a is not a subscope" Print.lit_style
|
|
||||||
(Mark.remove y)
|
|
||||||
| None ->
|
|
||||||
Message.raise_spanned_error pos "No definition found for subscope %a"
|
|
||||||
Print.lit_style (Mark.remove y)
|
Print.lit_style (Mark.remove y)
|
||||||
|
| None ->
|
||||||
|
Message.error ~pos "No definition found for subscope %a" Print.lit_style
|
||||||
|
(Mark.remove y)
|
||||||
in
|
in
|
||||||
let var_within_origin_scope = get_var_uid name ctxt x in
|
let var_within_origin_scope = get_var_uid name ctxt x in
|
||||||
( (subscope_var, pos),
|
( (subscope_var, pos),
|
||||||
Ast.ScopeDef.SubScopeInput { name; var_within_origin_scope } )
|
Ast.ScopeDef.SubScopeInput { name; var_within_origin_scope } )
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"This line is defining a quantity that is neither a scope variable nor a \
|
"This line is defining a quantity that is neither a scope variable nor a \
|
||||||
subscope variable. In particular, it is not possible to define struct \
|
subscope variable. In particular, it is not possible to define struct \
|
||||||
fields individually in Catala."
|
fields individually in Catala."
|
||||||
@ -937,8 +943,8 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
|
|||||||
with
|
with
|
||||||
| Some (TScope (sn, _)) -> sn
|
| Some (TScope (sn, _)) -> sn
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get suse.Surface.Ast.scope_use_name)
|
~pos:(Mark.get suse.Surface.Ast.scope_use_name)
|
||||||
"@{<yellow>\"%s\"@}: this scope has not been declared anywhere, is it \
|
"@{<yellow>\"%s\"@}: this scope has not been declared anywhere, is it \
|
||||||
a typo?"
|
a typo?"
|
||||||
(Mark.remove suse.Surface.Ast.scope_use_name)
|
(Mark.remove suse.Surface.Ast.scope_use_name)
|
||||||
|
@ -86,19 +86,19 @@ let print_exceptions_graph
|
|||||||
(scope : ScopeName.t)
|
(scope : ScopeName.t)
|
||||||
(var : Ast.ScopeDef.t)
|
(var : Ast.ScopeDef.t)
|
||||||
(g : Dependency.ExceptionsDependencies.t) =
|
(g : Dependency.ExceptionsDependencies.t) =
|
||||||
Message.emit_result
|
Message.result
|
||||||
"Printing the tree of exceptions for the definitions of variable \"%a\" of \
|
"Printing the tree of exceptions for the definitions of variable \"%a\" of \
|
||||||
scope \"%a\"."
|
scope \"%a\"."
|
||||||
Ast.ScopeDef.format var ScopeName.format scope;
|
Ast.ScopeDef.format var ScopeName.format scope;
|
||||||
Dependency.ExceptionsDependencies.iter_vertex
|
Dependency.ExceptionsDependencies.iter_vertex
|
||||||
(fun ex ->
|
(fun ex ->
|
||||||
Message.emit_result "@[<v>Definitions with label \"%a\":@,%a@]"
|
Message.result "@[<v>Definitions with label \"%a\":@,%a@]"
|
||||||
LabelName.format ex.Dependency.ExceptionVertex.label
|
LabelName.format ex.Dependency.ExceptionVertex.label
|
||||||
(RuleName.Map.format_values Pos.format_loc_text)
|
(RuleName.Map.format_values Pos.format_loc_text)
|
||||||
ex.Dependency.ExceptionVertex.rules)
|
ex.Dependency.ExceptionVertex.rules)
|
||||||
g;
|
g;
|
||||||
let tree = build_exception_tree g in
|
let tree = build_exception_tree g in
|
||||||
Message.emit_result "@[<v>The exception tree structure is as follows:@,@,%a@]"
|
Message.result "@[<v>The exception tree structure is as follows:@,@,%a@]"
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,@,")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,@,")
|
||||||
(fun fmt tree -> format_exception_tree fmt tree))
|
(fun fmt tree -> format_exception_tree fmt tree))
|
||||||
|
@ -35,7 +35,7 @@ let load_module_interfaces
|
|||||||
(* Recurse into program modules, looking up files in [using] and loading
|
(* Recurse into program modules, looking up files in [using] and loading
|
||||||
them *)
|
them *)
|
||||||
if program.Surface.Ast.program_used_modules <> [] then
|
if program.Surface.Ast.program_used_modules <> [] then
|
||||||
Message.emit_debug "Loading module interfaces...";
|
Message.debug "Loading module interfaces...";
|
||||||
let includes =
|
let includes =
|
||||||
List.map options.Global.path_rewrite includes @ more_includes
|
List.map options.Global.path_rewrite includes @ more_includes
|
||||||
|> List.map File.Tree.build
|
|> List.map File.Tree.build
|
||||||
@ -56,13 +56,13 @@ let load_module_interfaces
|
|||||||
extensions
|
extensions
|
||||||
with
|
with
|
||||||
| [] ->
|
| [] ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
(err_req_pos (mpos :: req_chain))
|
~extra_pos:(err_req_pos (mpos :: req_chain))
|
||||||
"Required module not found: @{<blue>%s@}" mname
|
"Required module not found: @{<blue>%s@}" mname
|
||||||
| [f] -> f
|
| [f] -> f
|
||||||
| ms ->
|
| ms ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
(err_req_pos (mpos :: req_chain))
|
~extra_pos:(err_req_pos (mpos :: req_chain))
|
||||||
"Required module @{<blue>%s@} matches multiple files:@;<1 2>%a" mname
|
"Required module @{<blue>%s@} matches multiple files:@;<1 2>%a" mname
|
||||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space File.format)
|
(Format.pp_print_list ~pp_sep:Format.pp_print_space File.format)
|
||||||
ms
|
ms
|
||||||
@ -81,7 +81,8 @@ let load_module_interfaces
|
|||||||
(Mark.remove use.Surface.Ast.mod_use_alias)
|
(Mark.remove use.Surface.Ast.mod_use_alias)
|
||||||
modname use_map )
|
modname use_map )
|
||||||
| Some None ->
|
| Some None ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
|
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
|
||||||
"Circular module dependency"
|
"Circular module dependency"
|
||||||
| None ->
|
| None ->
|
||||||
@ -131,7 +132,7 @@ module Passes = struct
|
|||||||
(forwarding their options as needed) *)
|
(forwarding their options as needed) *)
|
||||||
|
|
||||||
let debug_pass_name s =
|
let debug_pass_name s =
|
||||||
Message.emit_debug "@{<bold;magenta>=@} @{<bold>%s@} @{<bold;magenta>=@}"
|
Message.debug "@{<bold;magenta>=@} @{<bold>%s@} @{<bold;magenta>=@}"
|
||||||
(String.uppercase_ascii s)
|
(String.uppercase_ascii s)
|
||||||
|
|
||||||
let surface options : Surface.Ast.program =
|
let surface options : Surface.Ast.program =
|
||||||
@ -146,13 +147,13 @@ module Passes = struct
|
|||||||
let prg = surface options in
|
let prg = surface options in
|
||||||
let mod_uses, modules = load_module_interfaces options includes prg in
|
let mod_uses, modules = load_module_interfaces options includes prg in
|
||||||
debug_pass_name "desugared";
|
debug_pass_name "desugared";
|
||||||
Message.emit_debug "Name resolution...";
|
Message.debug "Name resolution...";
|
||||||
let ctx = Desugared.Name_resolution.form_context (prg, mod_uses) modules in
|
let ctx = Desugared.Name_resolution.form_context (prg, mod_uses) modules in
|
||||||
Message.emit_debug "Desugaring...";
|
Message.debug "Desugaring...";
|
||||||
let prg = Desugared.From_surface.translate_program ctx prg in
|
let prg = Desugared.From_surface.translate_program ctx prg in
|
||||||
Message.emit_debug "Disambiguating...";
|
Message.debug "Disambiguating...";
|
||||||
let prg = Desugared.Disambiguate.program prg in
|
let prg = Desugared.Disambiguate.program prg in
|
||||||
Message.emit_debug "Linting...";
|
Message.debug "Linting...";
|
||||||
Desugared.Linting.lint_program prg;
|
Desugared.Linting.lint_program prg;
|
||||||
prg, ctx
|
prg, ctx
|
||||||
|
|
||||||
@ -185,16 +186,16 @@ module Passes = struct
|
|||||||
let (prg : ty Scopelang.Ast.program) =
|
let (prg : ty Scopelang.Ast.program) =
|
||||||
match typed with
|
match typed with
|
||||||
| Typed _ ->
|
| Typed _ ->
|
||||||
Message.emit_debug "Typechecking...";
|
Message.debug "Typechecking...";
|
||||||
Scopelang.Ast.type_program prg
|
Scopelang.Ast.type_program prg
|
||||||
| Untyped _ -> prg
|
| Untyped _ -> prg
|
||||||
| Custom _ -> invalid_arg "Driver.Passes.dcalc"
|
| Custom _ -> invalid_arg "Driver.Passes.dcalc"
|
||||||
in
|
in
|
||||||
Message.emit_debug "Translating to default calculus...";
|
Message.debug "Translating to default calculus...";
|
||||||
let prg = Dcalc.From_scopelang.translate_program prg in
|
let prg = Dcalc.From_scopelang.translate_program prg in
|
||||||
let prg =
|
let prg =
|
||||||
if optimize then begin
|
if optimize then begin
|
||||||
Message.emit_debug "Optimizing default calculus...";
|
Message.debug "Optimizing default calculus...";
|
||||||
Optimizations.optimize_program prg
|
Optimizations.optimize_program prg
|
||||||
end
|
end
|
||||||
else prg
|
else prg
|
||||||
@ -202,7 +203,7 @@ module Passes = struct
|
|||||||
let (prg : ty Dcalc.Ast.program) =
|
let (prg : ty Dcalc.Ast.program) =
|
||||||
match typed with
|
match typed with
|
||||||
| Typed _ -> (
|
| Typed _ -> (
|
||||||
Message.emit_debug "Typechecking again...";
|
Message.debug "Typechecking again...";
|
||||||
try Typing.program prg
|
try Typing.program prg
|
||||||
with Message.CompilerError error_content ->
|
with Message.CompilerError error_content ->
|
||||||
let bt = Printexc.get_raw_backtrace () in
|
let bt = Printexc.get_raw_backtrace () in
|
||||||
@ -214,16 +215,15 @@ module Passes = struct
|
|||||||
| Custom _ -> assert false
|
| Custom _ -> assert false
|
||||||
in
|
in
|
||||||
if check_invariants then (
|
if check_invariants then (
|
||||||
Message.emit_debug "Checking invariants...";
|
Message.debug "Checking invariants...";
|
||||||
match typed with
|
match typed with
|
||||||
| Typed _ ->
|
| Typed _ ->
|
||||||
if Dcalc.Invariants.check_all_invariants prg then
|
if Dcalc.Invariants.check_all_invariants prg then
|
||||||
Message.emit_result "All invariant checks passed"
|
Message.result "All invariant checks passed"
|
||||||
else
|
else
|
||||||
raise
|
raise
|
||||||
(Message.raise_internal_error "Some Dcalc invariants are invalid")
|
(Message.error ~internal:true "Some Dcalc invariants are invalid")
|
||||||
| _ ->
|
| _ -> Message.error "--check-invariants cannot be used with --no-typing");
|
||||||
Message.raise_error "--check-invariants cannot be used with --no-typing");
|
|
||||||
prg, type_ordering
|
prg, type_ordering
|
||||||
|
|
||||||
let lcalc
|
let lcalc
|
||||||
@ -246,7 +246,7 @@ module Passes = struct
|
|||||||
let prg =
|
let prg =
|
||||||
match avoid_exceptions, options.trace, typed with
|
match avoid_exceptions, options.trace, typed with
|
||||||
| true, true, _ ->
|
| true, true, _ ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Option --avoid-exceptions is not compatible with option --trace"
|
"Option --avoid-exceptions is not compatible with option --trace"
|
||||||
| true, _, Untyped _ ->
|
| true, _, Untyped _ ->
|
||||||
Lcalc.From_dcalc.translate_program_without_exceptions prg
|
Lcalc.From_dcalc.translate_program_without_exceptions prg
|
||||||
@ -260,32 +260,32 @@ module Passes = struct
|
|||||||
in
|
in
|
||||||
let prg =
|
let prg =
|
||||||
if optimize then begin
|
if optimize then begin
|
||||||
Message.emit_debug "Optimizing lambda calculus...";
|
Message.debug "Optimizing lambda calculus...";
|
||||||
Optimizations.optimize_program prg
|
Optimizations.optimize_program prg
|
||||||
end
|
end
|
||||||
else prg
|
else prg
|
||||||
in
|
in
|
||||||
let prg =
|
let prg =
|
||||||
if not closure_conversion then (
|
if not closure_conversion then (
|
||||||
Message.emit_debug "Retyping lambda calculus...";
|
Message.debug "Retyping lambda calculus...";
|
||||||
Typing.program ~fail_on_any:false prg)
|
Typing.program ~fail_on_any:false prg)
|
||||||
else (
|
else (
|
||||||
Message.emit_debug "Performing closure conversion...";
|
Message.debug "Performing closure conversion...";
|
||||||
let prg = Lcalc.Closure_conversion.closure_conversion prg in
|
let prg = Lcalc.Closure_conversion.closure_conversion prg in
|
||||||
let prg =
|
let prg =
|
||||||
if optimize then (
|
if optimize then (
|
||||||
Message.emit_debug "Optimizing lambda calculus...";
|
Message.debug "Optimizing lambda calculus...";
|
||||||
Optimizations.optimize_program prg)
|
Optimizations.optimize_program prg)
|
||||||
else prg
|
else prg
|
||||||
in
|
in
|
||||||
Message.emit_debug "Retyping lambda calculus...";
|
Message.debug "Retyping lambda calculus...";
|
||||||
Typing.program ~fail_on_any:false prg)
|
Typing.program ~fail_on_any:false prg)
|
||||||
in
|
in
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
if monomorphize_types then (
|
if monomorphize_types then (
|
||||||
Message.emit_debug "Monomorphizing types...";
|
Message.debug "Monomorphizing types...";
|
||||||
let prg, type_ordering = Lcalc.Monomorphize.program prg in
|
let prg, type_ordering = Lcalc.Monomorphize.program prg in
|
||||||
Message.emit_debug "Retyping lambda calculus...";
|
Message.debug "Retyping lambda calculus...";
|
||||||
let prg = Typing.program ~fail_on_any:false ~assume_op_types:true prg in
|
let prg = Typing.program ~fail_on_any:false ~assume_op_types:true prg in
|
||||||
prg, type_ordering)
|
prg, type_ordering)
|
||||||
else prg, type_ordering
|
else prg, type_ordering
|
||||||
@ -320,21 +320,21 @@ module Commands = struct
|
|||||||
|
|
||||||
let get_scope_uid (ctx : decl_ctx) (scope : string) : ScopeName.t =
|
let get_scope_uid (ctx : decl_ctx) (scope : string) : ScopeName.t =
|
||||||
if String.contains scope '.' then
|
if String.contains scope '.' then
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Bad scope argument @{<yellow>%s@}: only references to the top-level \
|
"Bad scope argument @{<yellow>%s@}: only references to the top-level \
|
||||||
module are allowed"
|
module are allowed"
|
||||||
scope;
|
scope;
|
||||||
try Ident.Map.find scope ctx.ctx_scope_index
|
try Ident.Map.find scope ctx.ctx_scope_index
|
||||||
with Ident.Map.Not_found _ ->
|
with Ident.Map.Not_found _ ->
|
||||||
Message.raise_error
|
Message.error "There is no scope \"@{<yellow>%s@}\" inside the program."
|
||||||
"There is no scope \"@{<yellow>%s@}\" inside the program." scope
|
scope
|
||||||
|
|
||||||
(* TODO: this is very weird but I'm trying to maintain the current behaviour
|
(* TODO: this is very weird but I'm trying to maintain the current behaviour
|
||||||
for now *)
|
for now *)
|
||||||
let get_random_scope_uid (ctx : decl_ctx) : ScopeName.t =
|
let get_random_scope_uid (ctx : decl_ctx) : ScopeName.t =
|
||||||
match Ident.Map.choose_opt ctx.ctx_scope_index with
|
match Ident.Map.choose_opt ctx.ctx_scope_index with
|
||||||
| Some (_, name) -> name
|
| Some (_, name) -> name
|
||||||
| None -> Message.raise_error "There isn't any scope inside the program."
|
| None -> Message.error "There isn't any scope inside the program."
|
||||||
|
|
||||||
let get_variable_uid
|
let get_variable_uid
|
||||||
(ctxt : Desugared.Name_resolution.context)
|
(ctxt : Desugared.Name_resolution.context)
|
||||||
@ -353,7 +353,7 @@ module Commands = struct
|
|||||||
(ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
|
(ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
|
||||||
with
|
with
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
|
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
|
||||||
variable ScopeName.format scope_uid
|
variable ScopeName.format scope_uid
|
||||||
| Some (ScopeVar v | SubScope (v, _, _)) ->
|
| Some (ScopeVar v | SubScope (v, _, _)) ->
|
||||||
@ -365,7 +365,7 @@ module Commands = struct
|
|||||||
match Ident.Map.find_opt id var_sig.var_sig_states_idmap with
|
match Ident.Map.find_opt id var_sig.var_sig_states_idmap with
|
||||||
| Some state -> state
|
| Some state -> state
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"State @{<yellow>\"%s\"@} is not found for variable \
|
"State @{<yellow>\"%s\"@} is not found for variable \
|
||||||
@{<yellow>\"%s\"@} of scope @{<yellow>\"%a\"@}"
|
@{<yellow>\"%s\"@} of scope @{<yellow>\"%a\"@}"
|
||||||
id first_part ScopeName.format scope_uid
|
id first_part ScopeName.format scope_uid
|
||||||
@ -387,7 +387,7 @@ module Commands = struct
|
|||||||
let backend_extensions_list = [".tex"] in
|
let backend_extensions_list = [".tex"] in
|
||||||
let source_file = Global.input_src_file options.Global.input_src in
|
let source_file = Global.input_src_file options.Global.input_src in
|
||||||
let output_file, with_output = get_output options ~ext:".d" output in
|
let output_file, with_output = get_output options ~ext:".d" output in
|
||||||
Message.emit_debug "Writing list of dependencies to %s..."
|
Message.debug "Writing list of dependencies to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
with_output
|
with_output
|
||||||
@@ fun oc ->
|
@@ fun oc ->
|
||||||
@ -410,7 +410,7 @@ module Commands = struct
|
|||||||
|
|
||||||
let html options output print_only_law wrap_weaved_output =
|
let html options output print_only_law wrap_weaved_output =
|
||||||
let prg = Passes.surface options in
|
let prg = Passes.surface options in
|
||||||
Message.emit_debug "Weaving literate program into HTML";
|
Message.debug "Weaving literate program into HTML";
|
||||||
let output_file, with_output =
|
let output_file, with_output =
|
||||||
get_output_format options ~ext:".html" output
|
get_output_format options ~ext:".html" output
|
||||||
in
|
in
|
||||||
@ -420,8 +420,7 @@ module Commands = struct
|
|||||||
Cli.file_lang (Global.input_src_file options.Global.input_src)
|
Cli.file_lang (Global.input_src_file options.Global.input_src)
|
||||||
in
|
in
|
||||||
let weave_output = Literate.Html.ast_to_html language ~print_only_law in
|
let weave_output = Literate.Html.ast_to_html language ~print_only_law in
|
||||||
Message.emit_debug "Writing to %s"
|
Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file);
|
||||||
(Option.value ~default:"stdout" output_file);
|
|
||||||
if wrap_weaved_output then
|
if wrap_weaved_output then
|
||||||
Literate.Html.wrap_html prg.Surface.Ast.program_source_files language fmt
|
Literate.Html.wrap_html prg.Surface.Ast.program_source_files language fmt
|
||||||
(fun fmt -> weave_output fmt prg)
|
(fun fmt -> weave_output fmt prg)
|
||||||
@ -448,7 +447,7 @@ module Commands = struct
|
|||||||
|> Surface.Fill_positions.fill_pos_with_legislative_info)
|
|> Surface.Fill_positions.fill_pos_with_legislative_info)
|
||||||
extra_files
|
extra_files
|
||||||
in
|
in
|
||||||
Message.emit_debug "Weaving literate program into LaTeX";
|
Message.debug "Weaving literate program into LaTeX";
|
||||||
let output_file, with_output =
|
let output_file, with_output =
|
||||||
get_output_format options ~ext:".tex" output
|
get_output_format options ~ext:".tex" output
|
||||||
in
|
in
|
||||||
@ -458,8 +457,7 @@ module Commands = struct
|
|||||||
Cli.file_lang (Global.input_src_file options.Global.input_src)
|
Cli.file_lang (Global.input_src_file options.Global.input_src)
|
||||||
in
|
in
|
||||||
let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in
|
let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in
|
||||||
Message.emit_debug "Writing to %s"
|
Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file);
|
||||||
(Option.value ~default:"stdout" output_file);
|
|
||||||
let weave fmt =
|
let weave fmt =
|
||||||
weave_output fmt prg;
|
weave_output fmt prg;
|
||||||
List.iter
|
List.iter
|
||||||
@ -548,13 +546,13 @@ module Commands = struct
|
|||||||
|
|
||||||
let typecheck options check_invariants includes =
|
let typecheck options check_invariants includes =
|
||||||
let prg = Passes.scopelang options ~includes in
|
let prg = Passes.scopelang options ~includes in
|
||||||
Message.emit_debug "Typechecking...";
|
Message.debug "Typechecking...";
|
||||||
let _type_ordering =
|
let _type_ordering =
|
||||||
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
|
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
|
||||||
prg.program_ctx.ctx_enums
|
prg.program_ctx.ctx_enums
|
||||||
in
|
in
|
||||||
let prg = Scopelang.Ast.type_program prg in
|
let prg = Scopelang.Ast.type_program prg in
|
||||||
Message.emit_debug "Translating to default calculus...";
|
Message.debug "Translating to default calculus...";
|
||||||
(* Strictly type-checking could stop here, but we also want this pass to
|
(* Strictly type-checking could stop here, but we also want this pass to
|
||||||
check full name-resolution and cycle detection. These are checked during
|
check full name-resolution and cycle detection. These are checked during
|
||||||
translation to dcalc so we run it here and drop the result. *)
|
translation to dcalc so we run it here and drop the result. *)
|
||||||
@ -563,12 +561,12 @@ module Commands = struct
|
|||||||
(* Additionally, we might want to check the invariants. *)
|
(* Additionally, we might want to check the invariants. *)
|
||||||
if check_invariants then (
|
if check_invariants then (
|
||||||
let prg = Shared_ast.Typing.program prg in
|
let prg = Shared_ast.Typing.program prg in
|
||||||
Message.emit_debug "Checking invariants...";
|
Message.debug "Checking invariants...";
|
||||||
if Dcalc.Invariants.check_all_invariants prg then
|
if Dcalc.Invariants.check_all_invariants prg then
|
||||||
Message.emit_result "All invariant checks passed"
|
Message.result "All invariant checks passed"
|
||||||
else
|
else
|
||||||
raise (Message.raise_internal_error "Some Dcalc invariants are invalid"));
|
raise (Message.error ~internal:true "Some Dcalc invariants are invalid"));
|
||||||
Message.emit_result "Typechecking successful!"
|
Message.result "Typechecking successful!"
|
||||||
|
|
||||||
let typecheck_cmd =
|
let typecheck_cmd =
|
||||||
Cmd.v
|
Cmd.v
|
||||||
@ -662,20 +660,20 @@ module Commands = struct
|
|||||||
$ Cli.Flags.disable_counterexamples)
|
$ Cli.Flags.disable_counterexamples)
|
||||||
|
|
||||||
let print_interpretation_results options interpreter prg scope_uid =
|
let print_interpretation_results options interpreter prg scope_uid =
|
||||||
Message.emit_debug "Starting interpretation...";
|
Message.debug "Starting interpretation...";
|
||||||
let results = interpreter prg scope_uid in
|
let results = interpreter prg scope_uid in
|
||||||
Message.emit_debug "End of interpretation";
|
Message.debug "End of interpretation";
|
||||||
let results =
|
let results =
|
||||||
List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results
|
List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results
|
||||||
in
|
in
|
||||||
Message.emit_result "Computation successful!%s"
|
Message.result "Computation successful!%s"
|
||||||
(if List.length results > 0 then " Results:" else "");
|
(if List.length results > 0 then " Results:" else "");
|
||||||
let language =
|
let language =
|
||||||
Cli.file_lang (Global.input_src_file options.Global.input_src)
|
Cli.file_lang (Global.input_src_file options.Global.input_src)
|
||||||
in
|
in
|
||||||
List.iter
|
List.iter
|
||||||
(fun ((var, _), result) ->
|
(fun ((var, _), result) ->
|
||||||
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
|
Message.result "@[<hov 2>%s@ =@ %a@]" var
|
||||||
(if options.Global.debug then Print.expr ~debug:false ()
|
(if options.Global.debug then Print.expr ~debug:false ()
|
||||||
else Print.UserFacing.value language)
|
else Print.UserFacing.value language)
|
||||||
result)
|
result)
|
||||||
@ -764,7 +762,7 @@ module Commands = struct
|
|||||||
=
|
=
|
||||||
if not lcalc then
|
if not lcalc then
|
||||||
if avoid_exceptions || closure_conversion || monomorphize_types then
|
if avoid_exceptions || closure_conversion || monomorphize_types then
|
||||||
Message.raise_error
|
Message.error
|
||||||
"The flags @{<bold>--avoid-exceptions@}, \
|
"The flags @{<bold>--avoid-exceptions@}, \
|
||||||
@{<bold>--closure-conversion@} and @{<bold>--monomorphize-types@} \
|
@{<bold>--closure-conversion@} and @{<bold>--monomorphize-types@} \
|
||||||
only make sense with the @{<bold>--lcalc@} option"
|
only make sense with the @{<bold>--lcalc@} option"
|
||||||
@ -814,8 +812,8 @@ module Commands = struct
|
|||||||
in
|
in
|
||||||
with_output
|
with_output
|
||||||
@@ fun fmt ->
|
@@ fun fmt ->
|
||||||
Message.emit_debug "Compiling program into OCaml...";
|
Message.debug "Compiling program into OCaml...";
|
||||||
Message.emit_debug "Writing to %s..."
|
Message.debug "Writing to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
|
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
|
||||||
Lcalc.To_ocaml.format_program fmt prg ?exec_scope type_ordering
|
Lcalc.To_ocaml.format_program fmt prg ?exec_scope type_ordering
|
||||||
@ -908,8 +906,8 @@ module Commands = struct
|
|||||||
let output_file, with_output =
|
let output_file, with_output =
|
||||||
get_output_format options ~ext:".py" output
|
get_output_format options ~ext:".py" output
|
||||||
in
|
in
|
||||||
Message.emit_debug "Compiling program into Python...";
|
Message.debug "Compiling program into Python...";
|
||||||
Message.emit_debug "Writing to %s..."
|
Message.debug "Writing to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
with_output
|
with_output
|
||||||
@@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
|
@@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
|
||||||
@ -937,8 +935,8 @@ module Commands = struct
|
|||||||
in
|
in
|
||||||
|
|
||||||
let output_file, with_output = get_output_format options ~ext:".r" output in
|
let output_file, with_output = get_output_format options ~ext:".r" output in
|
||||||
Message.emit_debug "Compiling program into R...";
|
Message.debug "Compiling program into R...";
|
||||||
Message.emit_debug "Writing to %s..."
|
Message.debug "Writing to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
with_output @@ fun fmt -> Scalc.To_r.format_program fmt prg type_ordering
|
with_output @@ fun fmt -> Scalc.To_r.format_program fmt prg type_ordering
|
||||||
|
|
||||||
@ -962,8 +960,8 @@ module Commands = struct
|
|||||||
~monomorphize_types:true
|
~monomorphize_types:true
|
||||||
in
|
in
|
||||||
let output_file, with_output = get_output_format options ~ext:".c" output in
|
let output_file, with_output = get_output_format options ~ext:".c" output in
|
||||||
Message.emit_debug "Compiling program into C...";
|
Message.debug "Compiling program into C...";
|
||||||
Message.emit_debug "Writing to %s..."
|
Message.debug "Writing to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
with_output @@ fun fmt -> Scalc.To_c.format_program fmt prg type_ordering
|
with_output @@ fun fmt -> Scalc.To_c.format_program fmt prg type_ordering
|
||||||
|
|
||||||
@ -1019,7 +1017,7 @@ module Commands = struct
|
|||||||
| None -> f
|
| None -> f
|
||||||
| Some pfx ->
|
| Some pfx ->
|
||||||
if not (Filename.is_relative f) then (
|
if not (Filename.is_relative f) then (
|
||||||
Message.emit_warning
|
Message.warning
|
||||||
"Not adding prefix to %s, which is an absolute path" f;
|
"Not adding prefix to %s, which is an absolute path" f;
|
||||||
f)
|
f)
|
||||||
else File.(pfx / f)
|
else File.(pfx / f)
|
||||||
@ -1090,7 +1088,7 @@ end
|
|||||||
let raise_help cmdname cmds =
|
let raise_help cmdname cmds =
|
||||||
let plugins = Plugin.names () in
|
let plugins = Plugin.names () in
|
||||||
let cmds = List.filter (fun name -> not (List.mem name plugins)) cmds in
|
let cmds = List.filter (fun name -> not (List.mem name plugins)) cmds in
|
||||||
Message.raise_error
|
Message.error
|
||||||
"One of the following commands was expected:@;\
|
"One of the following commands was expected:@;\
|
||||||
<1 4>@[<v>@{<bold;blue>%a@}@]%a@\n\
|
<1 4>@[<v>@{<bold;blue>%a@}@]%a@\n\
|
||||||
Run `@{<bold>%s --help@}' or `@{<bold>%s COMMAND --help@}' for details."
|
Run `@{<bold>%s --help@}' or `@{<bold>%s COMMAND --help@}' for details."
|
||||||
@ -1140,9 +1138,9 @@ let main () =
|
|||||||
else
|
else
|
||||||
match Sys.is_directory d with
|
match Sys.is_directory d with
|
||||||
| true -> Plugin.load_dir d
|
| true -> Plugin.load_dir d
|
||||||
| false -> Message.emit_debug "Could not read plugin directory %s" d
|
| false -> Message.debug "Could not read plugin directory %s" d
|
||||||
| exception Sys_error _ ->
|
| exception Sys_error _ ->
|
||||||
Message.emit_debug "Could not read plugin directory %s" d)
|
Message.debug "Could not read plugin directory %s" d)
|
||||||
plugins_dirs;
|
plugins_dirs;
|
||||||
Dynlink.allow_only ["Runtime_ocaml__Runtime"];
|
Dynlink.allow_only ["Runtime_ocaml__Runtime"];
|
||||||
(* We may use dynlink again, but only for runtime modules: no plugin
|
(* We may use dynlink again, but only for runtime modules: no plugin
|
||||||
|
@ -28,11 +28,11 @@ let rec translate_typ (tau : typ) : typ =
|
|||||||
| TStruct s -> TStruct s
|
| TStruct s -> TStruct s
|
||||||
| TEnum en -> TEnum en
|
| TEnum en -> TEnum en
|
||||||
| TOption _ ->
|
| TOption _ ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"The types option should not appear before the dcalc -> lcalc \
|
"The types option should not appear before the dcalc -> lcalc \
|
||||||
translation step."
|
translation step."
|
||||||
| TClosureEnv ->
|
| TClosureEnv ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"The types closure_env should not appear before the dcalc -> lcalc \
|
"The types closure_env should not appear before the dcalc -> lcalc \
|
||||||
translation step."
|
translation step."
|
||||||
| TAny -> TAny
|
| TAny -> TAny
|
||||||
|
@ -38,11 +38,11 @@ let rec translate_typ (tau : typ) : typ =
|
|||||||
| TStruct s -> TStruct s
|
| TStruct s -> TStruct s
|
||||||
| TEnum en -> TEnum en
|
| TEnum en -> TEnum en
|
||||||
| TOption _ ->
|
| TOption _ ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"The types option should not appear before the dcalc -> lcalc \
|
"The types option should not appear before the dcalc -> lcalc \
|
||||||
translation step."
|
translation step."
|
||||||
| TClosureEnv ->
|
| TClosureEnv ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"The types closure_env should not appear before the dcalc -> lcalc \
|
"The types closure_env should not appear before the dcalc -> lcalc \
|
||||||
translation step."
|
translation step."
|
||||||
| TAny -> TAny
|
| TAny -> TAny
|
||||||
|
@ -654,7 +654,7 @@ let format_scope_exec
|
|||||||
StructName.Map.find scope_body.scope_body_input_struct ctx.ctx_structs
|
StructName.Map.find scope_body.scope_body_input_struct ctx.ctx_structs
|
||||||
in
|
in
|
||||||
if not (StructField.Map.is_empty scope_input) then
|
if not (StructField.Map.is_empty scope_input) then
|
||||||
Message.raise_error
|
Message.error
|
||||||
"The scope @{<bold>%s@} defines input variables.@ This is not supported \
|
"The scope @{<bold>%s@} defines input variables.@ This is not supported \
|
||||||
for a main scope at the moment."
|
for a main scope at the moment."
|
||||||
scope_name_str;
|
scope_name_str;
|
||||||
@ -688,10 +688,10 @@ let format_scope_exec_args
|
|||||||
|> List.rev
|
|> List.rev
|
||||||
in
|
in
|
||||||
if scopes_with_no_input = [] then
|
if scopes_with_no_input = [] then
|
||||||
Message.raise_error
|
Message.error
|
||||||
"No scopes that don't require input were found, executable can't be \
|
"No scopes that don't require input were found, executable can't be \
|
||||||
generated";
|
generated";
|
||||||
Message.emit_debug "@[<hov 2>Generating entry points for scopes:@ %a@]@."
|
Message.debug "@[<hov 2>Generating entry points for scopes:@ %a@]@."
|
||||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (_, s, _) ->
|
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (_, s, _) ->
|
||||||
ScopeName.format ppf s))
|
ScopeName.format ppf s))
|
||||||
scopes_with_no_input;
|
scopes_with_no_input;
|
||||||
@ -793,7 +793,7 @@ let format_program
|
|||||||
format_scope_exec p.decl_ctx fmt bnd scope_name scope_body
|
format_scope_exec p.decl_ctx fmt bnd scope_name scope_body
|
||||||
| None, None -> if exec_args then format_scope_exec_args p.decl_ctx fmt bnd
|
| None, None -> if exec_args then format_scope_exec_args p.decl_ctx fmt bnd
|
||||||
| Some _, Some _ ->
|
| Some _, Some _ ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"OCaml generation: both module registration and top-level scope \
|
"OCaml generation: both module registration and top-level scope \
|
||||||
execution where required at the same time."
|
execution where required at the same time."
|
||||||
in
|
in
|
||||||
|
@ -100,7 +100,7 @@ let wrap_html
|
|||||||
(** Performs syntax highlighting on a piece of code by using Pygments and the
|
(** Performs syntax highlighting on a piece of code by using Pygments and the
|
||||||
special Catala lexer. *)
|
special Catala lexer. *)
|
||||||
let pygmentize_code (c : string Mark.pos) (lang : C.backend_lang) : string =
|
let pygmentize_code (c : string Mark.pos) (lang : C.backend_lang) : string =
|
||||||
Message.emit_debug "Pygmenting the code chunk %s" (Pos.to_string (Mark.get c));
|
Message.debug "Pygmenting the code chunk %s" (Pos.to_string (Mark.get c));
|
||||||
let output =
|
let output =
|
||||||
File.with_temp_file "catala_html_pygments" "in" ~contents:(Mark.remove c)
|
File.with_temp_file "catala_html_pygments" "in" ~contents:(Mark.remove c)
|
||||||
@@ fun temp_file_in ->
|
@@ fun temp_file_in ->
|
||||||
|
@ -339,5 +339,4 @@ let ast_to_latex
|
|||||||
Format.pp_print_cut fmt ())
|
Format.pp_print_cut fmt ())
|
||||||
program.program_items;
|
program.program_items;
|
||||||
Format.pp_close_box fmt ();
|
Format.pp_close_box fmt ();
|
||||||
Message.emit_debug "Lines of Catala inside literate source code: %d"
|
Message.debug "Lines of Catala inside literate source code: %d" !lines_of_code
|
||||||
!lines_of_code
|
|
||||||
|
@ -64,7 +64,7 @@ let get_language_extension = function
|
|||||||
| Pl -> "catala_pl"
|
| Pl -> "catala_pl"
|
||||||
|
|
||||||
let raise_failed_pandoc (command : string) (error_code : int) : 'a =
|
let raise_failed_pandoc (command : string) (error_code : int) : 'a =
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Weaving failed: pandoc command \"%s\" returned with error code %d" command
|
"Weaving failed: pandoc command \"%s\" returned with error code %d" command
|
||||||
error_code
|
error_code
|
||||||
|
|
||||||
@ -113,7 +113,8 @@ let check_exceeding_lines
|
|||||||
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
|
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
|
||||||
in
|
in
|
||||||
if len_s > max_len then
|
if len_s > max_len then
|
||||||
Message.emit_spanned_warning
|
Message.warning
|
||||||
|
~pos:
|
||||||
(Pos.from_info filename (start_line + i) (max_len + 1)
|
(Pos.from_info filename (start_line + i) (max_len + 1)
|
||||||
(start_line + i) (len_s + 1))
|
(start_line + i) (len_s + 1))
|
||||||
"This line is exceeding @{<bold;red>%d@} characters" max_len)
|
"This line is exceeding @{<bold;red>%d@} characters" max_len)
|
||||||
@ -132,7 +133,7 @@ let call_pygmentize ?lang args =
|
|||||||
let cmd = "pygmentize" in
|
let cmd = "pygmentize" in
|
||||||
let check_exit n =
|
let check_exit n =
|
||||||
if n <> 0 then
|
if n <> 0 then
|
||||||
Message.raise_error
|
Message.error
|
||||||
"Weaving failed: pygmentize command %S returned with error code %d"
|
"Weaving failed: pygmentize command %S returned with error code %d"
|
||||||
(String.concat " " (cmd :: args))
|
(String.concat " " (cmd :: args))
|
||||||
n
|
n
|
||||||
|
@ -32,26 +32,25 @@ let load_failures = Hashtbl.create 17
|
|||||||
|
|
||||||
let print_failures () =
|
let print_failures () =
|
||||||
if Hashtbl.length load_failures > 0 then
|
if Hashtbl.length load_failures > 0 then
|
||||||
Message.emit_warning "Some plugins could not be loaded:@,%a"
|
Message.warning "Some plugins could not be loaded:@,%a"
|
||||||
(Format.pp_print_seq (fun ppf -> Format.fprintf ppf " - %s"))
|
(Format.pp_print_seq (fun ppf -> Format.fprintf ppf " - %s"))
|
||||||
(Hashtbl.to_seq_values load_failures)
|
(Hashtbl.to_seq_values load_failures)
|
||||||
|
|
||||||
let load_file f =
|
let load_file f =
|
||||||
try
|
try
|
||||||
Dynlink.loadfile f;
|
Dynlink.loadfile f;
|
||||||
Message.emit_debug "Plugin %S loaded" f
|
Message.debug "Plugin %S loaded" f
|
||||||
with
|
with
|
||||||
| Dynlink.Error (Dynlink.Module_already_loaded s) ->
|
| Dynlink.Error (Dynlink.Module_already_loaded s) ->
|
||||||
Message.emit_debug "Plugin %S (%s) was already loaded, skipping" f s
|
Message.debug "Plugin %S (%s) was already loaded, skipping" f s
|
||||||
| Dynlink.Error err ->
|
| Dynlink.Error err ->
|
||||||
let msg = Dynlink.error_message err in
|
let msg = Dynlink.error_message err in
|
||||||
Message.emit_debug "Could not load plugin %S: %s" f msg;
|
Message.debug "Could not load plugin %S: %s" f msg;
|
||||||
Hashtbl.add load_failures f msg
|
Hashtbl.add load_failures f msg
|
||||||
| e ->
|
| e -> Message.warning "Could not load plugin %S: %s" f (Printexc.to_string e)
|
||||||
Message.emit_warning "Could not load plugin %S: %s" f (Printexc.to_string e)
|
|
||||||
|
|
||||||
let load_dir d =
|
let load_dir d =
|
||||||
Message.emit_debug "Loading plugins from %s" d;
|
Message.debug "Loading plugins from %s" d;
|
||||||
let dynlink_exts =
|
let dynlink_exts =
|
||||||
if Dynlink.is_native then [".cmxs"] else [".cmo"; ".cma"]
|
if Dynlink.is_native then [".cmxs"] else [".cmo"; ".cma"]
|
||||||
in
|
in
|
||||||
|
@ -308,7 +308,7 @@ module To_jsoo = struct
|
|||||||
(fun fmt (cname, typ) ->
|
(fun fmt (cname, typ) ->
|
||||||
match Mark.remove typ with
|
match Mark.remove typ with
|
||||||
| TTuple _ ->
|
| TTuple _ ->
|
||||||
Message.raise_spanned_error (Mark.get typ)
|
Message.error ~pos:(Mark.get typ)
|
||||||
"Tuples aren't yet supported in the conversion to JS..."
|
"Tuples aren't yet supported in the conversion to JS..."
|
||||||
| TLit TUnit ->
|
| TLit TUnit ->
|
||||||
Format.fprintf fmt "@[<hv 2>| \"%a\" ->@ %a.%a ()@]"
|
Format.fprintf fmt "@[<hv 2>| \"%a\" ->@ %a.%a ()@]"
|
||||||
@ -485,7 +485,7 @@ let run
|
|||||||
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
|
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
|
||||||
in
|
in
|
||||||
with_formatter (fun fmt ->
|
with_formatter (fun fmt ->
|
||||||
Message.emit_debug "Writing JSOO API code to %s..."
|
Message.debug "Writing JSOO API code to %s..."
|
||||||
(Option.value ~default:"stdout" jsoo_output_file);
|
(Option.value ~default:"stdout" jsoo_output_file);
|
||||||
let modname =
|
let modname =
|
||||||
match prg.module_name with
|
match prg.module_name with
|
||||||
|
@ -30,7 +30,7 @@ type flags = {
|
|||||||
(* -- Definition of the lazy interpreter -- *)
|
(* -- Definition of the lazy interpreter -- *)
|
||||||
|
|
||||||
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
|
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
|
||||||
let error e = Message.raise_spanned_error (Expr.pos e)
|
let error e = Message.error ~pos:(Expr.pos e)
|
||||||
let noassert = true
|
let noassert = true
|
||||||
|
|
||||||
module Env = struct
|
module Env = struct
|
||||||
@ -366,7 +366,8 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
|
|||||||
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
||||||
lazy_eval ctx env llevel e
|
lazy_eval ctx env llevel e
|
||||||
| _ :: _ :: _ ->
|
| _ :: _ :: _ ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
((None, Expr.mark_pos m)
|
((None, Expr.mark_pos m)
|
||||||
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
||||||
"Conflicting exceptions")
|
"Conflicting exceptions")
|
||||||
@ -693,7 +694,7 @@ let program_to_graph
|
|||||||
in
|
in
|
||||||
(G.add_edge g v child_v, var_vertices, env), v
|
(G.add_edge g v child_v, var_vertices, env), v
|
||||||
with Var.Map.Not_found _ ->
|
with Var.Map.Not_found _ ->
|
||||||
Message.emit_warning "VAR NOT FOUND: %a" Print.var var;
|
Message.warning "VAR NOT FOUND: %a" Print.var var;
|
||||||
let v = G.V.create e in
|
let v = G.V.create e in
|
||||||
let g = G.add_vertex g v in
|
let g = G.add_vertex g v in
|
||||||
(g, var_vertices, env), v))
|
(g, var_vertices, env), v))
|
||||||
|
@ -226,7 +226,7 @@ let run
|
|||||||
with_output
|
with_output
|
||||||
@@ fun fmt ->
|
@@ fun fmt ->
|
||||||
let scope_uid = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
|
let scope_uid = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
|
||||||
Message.emit_debug
|
Message.debug
|
||||||
"Writing JSON schema corresponding to the scope '%a' to the file %s..."
|
"Writing JSON schema corresponding to the scope '%a' to the file %s..."
|
||||||
ScopeName.format scope_uid
|
ScopeName.format scope_uid
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
|
@ -20,7 +20,7 @@ open Shared_ast
|
|||||||
(* -- Definition of the lazy interpreter -- *)
|
(* -- Definition of the lazy interpreter -- *)
|
||||||
|
|
||||||
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
|
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
|
||||||
let error e = Message.raise_spanned_error (Expr.pos e)
|
let error e = Message.error ~pos:(Expr.pos e)
|
||||||
let noassert = true
|
let noassert = true
|
||||||
|
|
||||||
type laziness_level = {
|
type laziness_level = {
|
||||||
@ -197,7 +197,8 @@ let rec lazy_eval :
|
|||||||
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
||||||
lazy_eval ctx env llevel e
|
lazy_eval ctx env llevel e
|
||||||
| _ :: _ :: _ ->
|
| _ :: _ :: _ ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
((None, Expr.mark_pos m)
|
((None, Expr.mark_pos m)
|
||||||
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
||||||
"Conflicting exceptions")
|
"Conflicting exceptions")
|
||||||
|
@ -39,9 +39,8 @@ let run
|
|||||||
in
|
in
|
||||||
|
|
||||||
let output_file, with_output = get_output_format options ~ext:".py" output in
|
let output_file, with_output = get_output_format options ~ext:".py" output in
|
||||||
Message.emit_debug "Compiling program into Python...";
|
Message.debug "Compiling program into Python...";
|
||||||
Message.emit_debug "Writing to %s..."
|
Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file);
|
||||||
(Option.value ~default:"stdout" output_file);
|
|
||||||
with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
|
with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
|
||||||
|
|
||||||
let term =
|
let term =
|
||||||
|
@ -58,7 +58,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
|
|||||||
with Var.Map.Not_found _ -> (
|
with Var.Map.Not_found _ -> (
|
||||||
try A.EFunc (Var.Map.find v ctxt.func_dict)
|
try A.EFunc (Var.Map.find v ctxt.func_dict)
|
||||||
with Var.Map.Not_found _ ->
|
with Var.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error (Expr.pos expr)
|
Message.error ~pos:(Expr.pos expr)
|
||||||
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
|
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
|
||||||
Print.var_debug v
|
Print.var_debug v
|
||||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf v ->
|
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf v ->
|
||||||
|
@ -158,7 +158,7 @@ let rec format_typ
|
|||||||
(List.mapi (fun x y -> y, x) ts)
|
(List.mapi (fun x y -> y, x) ts)
|
||||||
| TStruct s -> Format.fprintf fmt "%a %t" format_struct_name s element_name
|
| TStruct s -> Format.fprintf fmt "%a %t" format_struct_name s element_name
|
||||||
| TOption _ ->
|
| TOption _ ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"All option types should have been monomorphized before compilation to C."
|
"All option types should have been monomorphized before compilation to C."
|
||||||
| TDefault t -> format_typ decl_ctx element_name fmt t
|
| TDefault t -> format_typ decl_ctx element_name fmt t
|
||||||
| TEnum e -> Format.fprintf fmt "%a %t" format_enum_name e element_name
|
| TEnum e -> Format.fprintf fmt "%a %t" format_enum_name e element_name
|
||||||
@ -384,7 +384,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
|||||||
(format_expression ctx))
|
(format_expression ctx))
|
||||||
args
|
args
|
||||||
| ETuple _ | ETupleAccess _ ->
|
| ETuple _ | ETupleAccess _ ->
|
||||||
Message.raise_internal_error "Tuple compilation to C unimplemented!"
|
Message.error ~internal:true "Tuple compilation to C unimplemented!"
|
||||||
| EExternal _ -> failwith "TODO"
|
| EExternal _ -> failwith "TODO"
|
||||||
|
|
||||||
let typ_is_array (ctx : decl_ctx) (typ : typ) =
|
let typ_is_array (ctx : decl_ctx) (typ : typ) =
|
||||||
@ -402,7 +402,7 @@ let rec format_statement
|
|||||||
(s : stmt Mark.pos) : unit =
|
(s : stmt Mark.pos) : unit =
|
||||||
match Mark.remove s with
|
match Mark.remove s with
|
||||||
| SInnerFuncDef _ ->
|
| SInnerFuncDef _ ->
|
||||||
Message.raise_spanned_error (Mark.get s)
|
Message.error ~pos:(Mark.get s)
|
||||||
"Internal error: this inner functions should have been hoisted in Scalc"
|
"Internal error: this inner functions should have been hoisted in Scalc"
|
||||||
| SLocalDecl { name = v; typ = ty } ->
|
| SLocalDecl { name = v; typ = ty } ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@];"
|
Format.fprintf fmt "@[<hov 2>%a@];"
|
||||||
|
@ -339,7 +339,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
|||||||
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos)
|
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos)
|
||||||
(format_expression ctx) arg1
|
(format_expression ctx) arg1
|
||||||
| EAppOp { op = HandleDefaultOpt; _ } ->
|
| EAppOp { op = HandleDefaultOpt; _ } ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"R compilation does not currently support the avoiding of exceptions"
|
"R compilation does not currently support the avoiding of exceptions"
|
||||||
| EAppOp { op = HandleDefault as op; args; _ } ->
|
| EAppOp { op = HandleDefault as op; args; _ } ->
|
||||||
let pos = Mark.get e in
|
let pos = Mark.get e in
|
||||||
|
@ -118,8 +118,8 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
|
|||||||
(fun glo_name (expr, _) g ->
|
(fun glo_name (expr, _) g ->
|
||||||
let used_defs = expr_used_defs expr in
|
let used_defs = expr_used_defs expr in
|
||||||
if VMap.mem (Topdef glo_name) used_defs then
|
if VMap.mem (Topdef glo_name) used_defs then
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get (TopdefName.get_info glo_name))
|
~pos:(Mark.get (TopdefName.get_info glo_name))
|
||||||
"The Topdef %a has a definition that refers to itself, which is \
|
"The Topdef %a has a definition that refers to itself, which is \
|
||||||
forbidden since Catala does not provide recursion"
|
forbidden since Catala does not provide recursion"
|
||||||
TopdefName.format glo_name;
|
TopdefName.format glo_name;
|
||||||
@ -136,8 +136,8 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
|
|||||||
(fun g rule ->
|
(fun g rule ->
|
||||||
let used_defs = rule_used_defs rule in
|
let used_defs = rule_used_defs rule in
|
||||||
if VMap.mem (Scope scope_name) used_defs then
|
if VMap.mem (Scope scope_name) used_defs then
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
|
~pos:(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
|
||||||
"The scope %a is calling into itself as a subscope, which is \
|
"The scope %a is calling into itself as a subscope, which is \
|
||||||
forbidden since Catala does not provide recursion"
|
forbidden since Catala does not provide recursion"
|
||||||
ScopeName.format scope.Ast.scope_decl_name;
|
ScopeName.format scope.Ast.scope_decl_name;
|
||||||
@ -191,7 +191,7 @@ let check_for_cycle_in_defs (g : SDependencies.t) : unit =
|
|||||||
cycle
|
cycle
|
||||||
(List.tl cycle @ [List.hd cycle])
|
(List.tl cycle @ [List.hd cycle])
|
||||||
in
|
in
|
||||||
Message.raise_multispanned_error spans
|
Message.error ~extra_pos:spans
|
||||||
"@[<hov 2>Cyclic dependency detected between the following scopes:@ \
|
"@[<hov 2>Cyclic dependency detected between the following scopes:@ \
|
||||||
@[<hv>%a@]@]"
|
@[<hv>%a@]@]"
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
@ -282,7 +282,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
|
|||||||
TVertexSet.fold
|
TVertexSet.fold
|
||||||
(fun used g ->
|
(fun used g ->
|
||||||
if TVertex.equal used def then
|
if TVertex.equal used def then
|
||||||
Message.raise_spanned_error (Mark.get typ)
|
Message.error ~pos:(Mark.get typ)
|
||||||
"The type %a is defined using itself, which is forbidden \
|
"The type %a is defined using itself, which is forbidden \
|
||||||
since Catala does not provide recursive types"
|
since Catala does not provide recursive types"
|
||||||
TVertex.format used
|
TVertex.format used
|
||||||
@ -304,7 +304,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
|
|||||||
TVertexSet.fold
|
TVertexSet.fold
|
||||||
(fun used g ->
|
(fun used g ->
|
||||||
if TVertex.equal used def then
|
if TVertex.equal used def then
|
||||||
Message.raise_spanned_error (Mark.get typ)
|
Message.error ~pos:(Mark.get typ)
|
||||||
"The type %a is defined using itself, which is forbidden \
|
"The type %a is defined using itself, which is forbidden \
|
||||||
since Catala does not provide recursive types"
|
since Catala does not provide recursive types"
|
||||||
TVertex.format used
|
TVertex.format used
|
||||||
@ -347,6 +347,5 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
|
|||||||
])
|
])
|
||||||
scc)
|
scc)
|
||||||
in
|
in
|
||||||
Message.raise_multispanned_error spans
|
Message.error ~extra_pos:spans "Cyclic dependency detected between types!");
|
||||||
"Cyclic dependency detected between types!");
|
|
||||||
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])
|
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])
|
||||||
|
@ -214,7 +214,8 @@ let rule_to_exception_graph (scope : D.scope) = function
|
|||||||
let () =
|
let () =
|
||||||
match Mark.remove scope_def.D.scope_def_io.io_input with
|
match Mark.remove scope_def.D.scope_def_io.io_input with
|
||||||
| NoInput ->
|
| NoInput ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
(( Some "Incriminated subscope:",
|
(( Some "Incriminated subscope:",
|
||||||
Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
|
Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
|
||||||
:: ( Some "Incriminated variable:",
|
:: ( Some "Incriminated variable:",
|
||||||
@ -229,7 +230,8 @@ let rule_to_exception_graph (scope : D.scope) = function
|
|||||||
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
|
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
|
||||||
(* If the subscope variable is tagged as input, then it shall be
|
(* If the subscope variable is tagged as input, then it shall be
|
||||||
defined. *)
|
defined. *)
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
( Some "Incriminated subscope:",
|
( Some "Incriminated subscope:",
|
||||||
Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
|
Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
|
||||||
@ -251,7 +253,8 @@ let rule_to_exception_graph (scope : D.scope) = function
|
|||||||
match Mark.remove scope_def.D.scope_def_io.io_input with
|
match Mark.remove scope_def.D.scope_def_io.io_input with
|
||||||
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
|
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
|
||||||
(* If the variable is tagged as input, then it shall not be redefined. *)
|
(* If the variable is tagged as input, then it shall not be redefined. *)
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
|
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
|
||||||
:: List.map
|
:: List.map
|
||||||
(fun rule ->
|
(fun rule ->
|
||||||
@ -909,8 +912,7 @@ let translate_program
|
|||||||
(fun id -> function
|
(fun id -> function
|
||||||
| Some e, ty -> Expr.unbox (translate_expr ctx e), ty
|
| Some e, ty -> Expr.unbox (translate_expr ctx e), ty
|
||||||
| None, (_, pos) ->
|
| None, (_, pos) ->
|
||||||
Message.raise_spanned_error pos "No definition found for %a"
|
Message.error ~pos "No definition found for %a" TopdefName.format id)
|
||||||
TopdefName.format id)
|
|
||||||
desugared.program_root.module_topdefs
|
desugared.program_root.module_topdefs
|
||||||
in
|
in
|
||||||
let program_scopes =
|
let program_scopes =
|
||||||
|
@ -89,12 +89,12 @@ module Box = struct
|
|||||||
match fv b with
|
match fv b with
|
||||||
| [] -> ()
|
| [] -> ()
|
||||||
| [h] ->
|
| [h] ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"The boxed term is not closed the variable %s is free in the global \
|
"The boxed term is not closed the variable %s is free in the global \
|
||||||
context"
|
context"
|
||||||
h
|
h
|
||||||
| l ->
|
| l ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"The boxed term is not closed the variables %a is free in the global \
|
"The boxed term is not closed the variables %a is free in the global \
|
||||||
context"
|
context"
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
@ -935,10 +935,10 @@ let make_tupleaccess e index size pos =
|
|||||||
| TTuple tl, _ -> (
|
| TTuple tl, _ -> (
|
||||||
try List.nth tl index
|
try List.nth tl index
|
||||||
with Failure _ ->
|
with Failure _ ->
|
||||||
Message.raise_internal_error "Trying to build invalid tuple access")
|
Message.error ~internal:true "Trying to build invalid tuple access")
|
||||||
| TAny, pos -> TAny, pos
|
| TAny, pos -> TAny, pos
|
||||||
| ty ->
|
| ty ->
|
||||||
Message.raise_internal_error "Unexpected non-tuple type annotation %a"
|
Message.error ~internal:true "Unexpected non-tuple type annotation %a"
|
||||||
Print.typ_debug ty)
|
Print.typ_debug ty)
|
||||||
(Mark.get e)
|
(Mark.get e)
|
||||||
in
|
in
|
||||||
@ -957,7 +957,7 @@ let make_app f args tys pos =
|
|||||||
tr
|
tr
|
||||||
| TAny -> fty.ty
|
| TAny -> fty.ty
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"wrong type: found %a while expecting either an Arrow or Any"
|
"wrong type: found %a while expecting either an Arrow or Any"
|
||||||
Print.typ_debug fty.ty))
|
Print.typ_debug fty.ty))
|
||||||
(List.map Mark.get (f :: args))
|
(List.map Mark.get (f :: args))
|
||||||
@ -972,7 +972,7 @@ let make_erroronempty e =
|
|||||||
| TDefault ty, _ -> ty
|
| TDefault ty, _ -> ty
|
||||||
| TAny, pos -> TAny, pos
|
| TAny, pos -> TAny, pos
|
||||||
| ty ->
|
| ty ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"wrong type: found %a while expecting a TDefault on@;<1 2>%a"
|
"wrong type: found %a while expecting a TDefault on@;<1 2>%a"
|
||||||
Print.typ_debug ty format (unbox e))
|
Print.typ_debug ty format (unbox e))
|
||||||
(Mark.get e)
|
(Mark.get e)
|
||||||
|
@ -38,8 +38,8 @@ let print_log lang entry infos pos e =
|
|||||||
if Global.options.trace then
|
if Global.options.trace then
|
||||||
match entry with
|
match entry with
|
||||||
| VarDef _ ->
|
| VarDef _ ->
|
||||||
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
|
Message.log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry entry
|
||||||
entry Print.uid_list infos
|
Print.uid_list infos
|
||||||
(Message.unformat (fun ppf ->
|
(Message.unformat (fun ppf ->
|
||||||
(if Global.options.debug then Print.expr ~debug:true ()
|
(if Global.options.debug then Print.expr ~debug:true ()
|
||||||
else Print.UserFacing.expr lang)
|
else Print.UserFacing.expr lang)
|
||||||
@ -47,17 +47,17 @@ let print_log lang entry infos pos e =
|
|||||||
| PosRecordIfTrueBool -> (
|
| PosRecordIfTrueBool -> (
|
||||||
match pos <> Pos.no_pos, Mark.remove e with
|
match pos <> Pos.no_pos, Mark.remove e with
|
||||||
| true, ELit (LBool true) ->
|
| true, ELit (LBool true) ->
|
||||||
Message.emit_log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]"
|
Message.log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]" !indent_str
|
||||||
!indent_str Print.log_entry entry Pos.format_loc_text pos
|
Print.log_entry entry Pos.format_loc_text pos
|
||||||
| _ -> ())
|
| _ -> ())
|
||||||
| BeginCall ->
|
| BeginCall ->
|
||||||
Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
|
Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list
|
||||||
Print.uid_list infos;
|
infos;
|
||||||
indent_str := !indent_str ^ " "
|
indent_str := !indent_str ^ " "
|
||||||
| EndCall ->
|
| EndCall ->
|
||||||
indent_str := String.sub !indent_str 0 (String.length !indent_str - 2);
|
indent_str := String.sub !indent_str 0 (String.length !indent_str - 2);
|
||||||
Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
|
Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list
|
||||||
Print.uid_list infos
|
infos
|
||||||
|
|
||||||
exception CatalaException of except * Pos.t
|
exception CatalaException of except * Pos.t
|
||||||
|
|
||||||
@ -130,19 +130,21 @@ let rec evaluate_operator
|
|||||||
in
|
in
|
||||||
try f x y with
|
try f x y with
|
||||||
| Division_by_zero ->
|
| Division_by_zero ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "The division operator:", pos;
|
Some "The division operator:", pos;
|
||||||
Some "The null denominator:", Expr.pos (List.nth args 1);
|
Some "The null denominator:", Expr.pos (List.nth args 1);
|
||||||
]
|
]
|
||||||
"division by zero at runtime"
|
"division by zero at runtime"
|
||||||
| Runtime.UncomparableDurations ->
|
| Runtime.UncomparableDurations ->
|
||||||
Message.raise_multispanned_error (get_binop_args_pos args)
|
Message.error ~extra_pos:(get_binop_args_pos args)
|
||||||
"Cannot compare together durations that cannot be converted to a \
|
"Cannot compare together durations that cannot be converted to a \
|
||||||
precise number of days"
|
precise number of days"
|
||||||
in
|
in
|
||||||
let err () =
|
let err () =
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
([
|
([
|
||||||
( Some
|
( Some
|
||||||
(Format.asprintf "Operator (value %a):"
|
(Format.asprintf "Operator (value %a):"
|
||||||
@ -234,8 +236,8 @@ let rec evaluate_operator
|
|||||||
with
|
with
|
||||||
| ELit (LBool b), _ -> b
|
| ELit (LBool b), _ -> b
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Expr.pos (List.nth args 0))
|
~pos:(Expr.pos (List.nth args 0))
|
||||||
"This predicate evaluated to something else than a boolean \
|
"This predicate evaluated to something else than a boolean \
|
||||||
(should not happen if the term was well-typed)")
|
(should not happen if the term was well-typed)")
|
||||||
es)
|
es)
|
||||||
@ -391,7 +393,7 @@ let rec evaluate_operator
|
|||||||
(evaluate_expr (Expr.unthunk_term_nobox cons (Mark.get cons)))
|
(evaluate_expr (Expr.unthunk_term_nobox cons (Mark.get cons)))
|
||||||
| ELit (LBool false) -> raise (CatalaException (EmptyError, pos))
|
| ELit (LBool false) -> raise (CatalaException (EmptyError, pos))
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Default justification has not been reduced to a boolean at \
|
"Default justification has not been reduced to a boolean at \
|
||||||
evaluation (should not happen if the term was well-typed@\n\
|
evaluation (should not happen if the term was well-typed@\n\
|
||||||
%a@."
|
%a@."
|
||||||
@ -602,7 +604,7 @@ and val_to_runtime :
|
|||||||
curry [] targs
|
curry [] targs
|
||||||
| TDefault ty, _ -> val_to_runtime eval_expr ctx ty v
|
| TDefault ty, _ -> val_to_runtime eval_expr ctx ty v
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_internal_error
|
Message.error ~internal:true
|
||||||
"Could not convert value of type %a to runtime: %a" (Print.typ ctx) ty
|
"Could not convert value of type %a to runtime: %a" (Print.typ ctx) ty
|
||||||
Expr.format v
|
Expr.format v
|
||||||
|
|
||||||
@ -617,7 +619,7 @@ let rec evaluate_expr :
|
|||||||
let pos = Expr.mark_pos m in
|
let pos = Expr.mark_pos m in
|
||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| EVar _ ->
|
| EVar _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"free variable found at evaluation (should not happen if term was \
|
"free variable found at evaluation (should not happen if term was \
|
||||||
well-typed)"
|
well-typed)"
|
||||||
| EExternal { name } ->
|
| EExternal { name } ->
|
||||||
@ -637,7 +639,7 @@ let rec evaluate_expr :
|
|||||||
(TStruct scope_info.out_struct_name, pos) ),
|
(TStruct scope_info.out_struct_name, pos) ),
|
||||||
pos )
|
pos )
|
||||||
with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ ->
|
with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error pos "Reference to %a could not be resolved"
|
Message.error ~pos "Reference to %a could not be resolved"
|
||||||
Print.external_ref name
|
Print.external_ref name
|
||||||
in
|
in
|
||||||
let runtime_path =
|
let runtime_path =
|
||||||
@ -659,8 +661,7 @@ let rec evaluate_expr :
|
|||||||
evaluate_expr ctx lang
|
evaluate_expr ctx lang
|
||||||
(Bindlib.msubst binder (Array.of_list (List.map Mark.remove args)))
|
(Bindlib.msubst binder (Array.of_list (List.map Mark.remove args)))
|
||||||
else
|
else
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos "wrong function call, expected %d arguments, got %d"
|
||||||
"wrong function call, expected %d arguments, got %d"
|
|
||||||
(Bindlib.mbinder_arity binder)
|
(Bindlib.mbinder_arity binder)
|
||||||
(List.length args)
|
(List.length args)
|
||||||
| ECustom { obj; targs; tret } ->
|
| ECustom { obj; targs; tret } ->
|
||||||
@ -674,7 +675,7 @@ let rec evaluate_expr :
|
|||||||
|> fun o ->
|
|> fun o ->
|
||||||
runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o
|
runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"function has not been reduced to a lambda at evaluation (should not \
|
"function has not been reduced to a lambda at evaluation (should not \
|
||||||
happen if the term was well-typed")
|
happen if the term was well-typed")
|
||||||
| EAppOp { op; args; _ } ->
|
| EAppOp { op; args; _ } ->
|
||||||
@ -697,19 +698,19 @@ let rec evaluate_expr :
|
|||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| EStruct { fields = es; name } -> (
|
| EStruct { fields = es; name } -> (
|
||||||
if not (StructName.equal s name) then
|
if not (StructName.equal s name) then
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[None, pos; None, Expr.pos e]
|
~extra_pos:[None, pos; None, Expr.pos e]
|
||||||
"Error during struct access: not the same structs (should not happen \
|
"Error during struct access: not the same structs (should not happen \
|
||||||
if the term was well-typed)";
|
if the term was well-typed)";
|
||||||
match StructField.Map.find_opt field es with
|
match StructField.Map.find_opt field es with
|
||||||
| Some e' -> e'
|
| Some e' -> e'
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Invalid field access %a in struct %a (should not happen if the term \
|
"Invalid field access %a in struct %a (should not happen if the term \
|
||||||
was well-typed)"
|
was well-typed)"
|
||||||
StructField.format field StructName.format s)
|
StructField.format field StructName.format s)
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The expression %a should be a struct %a but is not (should not happen \
|
"The expression %a should be a struct %a but is not (should not happen \
|
||||||
if the term was well-typed)"
|
if the term was well-typed)"
|
||||||
(Print.UserFacing.expr lang)
|
(Print.UserFacing.expr lang)
|
||||||
@ -719,7 +720,7 @@ let rec evaluate_expr :
|
|||||||
match evaluate_expr ctx lang e1 with
|
match evaluate_expr ctx lang e1 with
|
||||||
| ETuple es, _ when List.length es = size -> List.nth es index
|
| ETuple es, _ when List.length es = size -> List.nth es index
|
||||||
| e ->
|
| e ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The expression %a was expected to be a tuple of size %d (should not \
|
"The expression %a was expected to be a tuple of size %d (should not \
|
||||||
happen if the term was well-typed)"
|
happen if the term was well-typed)"
|
||||||
(Print.UserFacing.expr lang)
|
(Print.UserFacing.expr lang)
|
||||||
@ -732,15 +733,15 @@ let rec evaluate_expr :
|
|||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| EInj { e = e1; cons; name = name' } ->
|
| EInj { e = e1; cons; name = name' } ->
|
||||||
if not (EnumName.equal name name') then
|
if not (EnumName.equal name name') then
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[None, Expr.pos e; None, Expr.pos e1]
|
~extra_pos:[None, Expr.pos e; None, Expr.pos e1]
|
||||||
"Error during match: two different enums found (should not happen if \
|
"Error during match: two different enums found (should not happen if \
|
||||||
the term was well-typed)";
|
the term was well-typed)";
|
||||||
let es_n =
|
let es_n =
|
||||||
match EnumConstructor.Map.find_opt cons cases with
|
match EnumConstructor.Map.find_opt cons cases with
|
||||||
| Some es_n -> es_n
|
| Some es_n -> es_n
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"sum type index error (should not happen if the term was \
|
"sum type index error (should not happen if the term was \
|
||||||
well-typed)"
|
well-typed)"
|
||||||
in
|
in
|
||||||
@ -750,7 +751,7 @@ let rec evaluate_expr :
|
|||||||
let new_e = Mark.add m (EApp { f = es_n; args = [e1]; tys = [ty] }) in
|
let new_e = Mark.add m (EApp { f = es_n; args = [e1]; tys = [ty] }) in
|
||||||
evaluate_expr ctx lang new_e
|
evaluate_expr ctx lang new_e
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Expected a term having a sum type as an argument to a match (should \
|
"Expected a term having a sum type as an argument to a match (should \
|
||||||
not happen if the term was well-typed")
|
not happen if the term was well-typed")
|
||||||
| EIfThenElse { cond; etrue; efalse } -> (
|
| EIfThenElse { cond; etrue; efalse } -> (
|
||||||
@ -759,7 +760,7 @@ let rec evaluate_expr :
|
|||||||
| ELit (LBool true) -> evaluate_expr ctx lang etrue
|
| ELit (LBool true) -> evaluate_expr ctx lang etrue
|
||||||
| ELit (LBool false) -> evaluate_expr ctx lang efalse
|
| ELit (LBool false) -> evaluate_expr ctx lang efalse
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos cond)
|
Message.error ~pos:(Expr.pos cond)
|
||||||
"Expected a boolean literal for the result of this condition (should \
|
"Expected a boolean literal for the result of this condition (should \
|
||||||
not happen if the term was well-typed)")
|
not happen if the term was well-typed)")
|
||||||
| EArray es ->
|
| EArray es ->
|
||||||
@ -770,18 +771,18 @@ let rec evaluate_expr :
|
|||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| ELit (LBool true) -> Mark.add m (ELit LUnit)
|
| ELit (LBool true) -> Mark.add m (ELit LUnit)
|
||||||
| ELit (LBool false) ->
|
| ELit (LBool false) ->
|
||||||
Message.raise_spanned_error (Expr.pos e') "Assertion failed:@\n%a"
|
Message.error ~pos:(Expr.pos e') "Assertion failed:@\n%a"
|
||||||
(Print.UserFacing.expr lang)
|
(Print.UserFacing.expr lang)
|
||||||
(partially_evaluate_expr_for_assertion_failure_message ctx lang
|
(partially_evaluate_expr_for_assertion_failure_message ctx lang
|
||||||
(Expr.skip_wrappers e'))
|
(Expr.skip_wrappers e'))
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e')
|
Message.error ~pos:(Expr.pos e')
|
||||||
"Expected a boolean literal for the result of this assertion (should \
|
"Expected a boolean literal for the result of this assertion (should \
|
||||||
not happen if the term was well-typed)")
|
not happen if the term was well-typed)")
|
||||||
| EErrorOnEmpty e' -> (
|
| EErrorOnEmpty e' -> (
|
||||||
match evaluate_expr ctx lang e' with
|
match evaluate_expr ctx lang e' with
|
||||||
| EEmptyError, _ ->
|
| EEmptyError, _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e')
|
Message.error ~pos:(Expr.pos e')
|
||||||
"This variable evaluated to an empty term (no rule that defined it \
|
"This variable evaluated to an empty term (no rule that defined it \
|
||||||
applied in this situation)"
|
applied in this situation)"
|
||||||
| e -> e)
|
| e -> e)
|
||||||
@ -795,7 +796,7 @@ let rec evaluate_expr :
|
|||||||
| ELit (LBool true) -> evaluate_expr ctx lang cons
|
| ELit (LBool true) -> evaluate_expr ctx lang cons
|
||||||
| ELit (LBool false) -> Mark.copy e EEmptyError
|
| ELit (LBool false) -> Mark.copy e EEmptyError
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Default justification has not been reduced to a boolean at \
|
"Default justification has not been reduced to a boolean at \
|
||||||
evaluation (should not happen if the term was well-typed")
|
evaluation (should not happen if the term was well-typed")
|
||||||
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
|
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
|
||||||
@ -913,11 +914,12 @@ let delcustom e =
|
|||||||
|
|
||||||
let interp_failure_message ~pos = function
|
let interp_failure_message ~pos = function
|
||||||
| NoValueProvided ->
|
| NoValueProvided ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"This variable evaluated to an empty term (no rule that defined it \
|
"This variable evaluated to an empty term (no rule that defined it \
|
||||||
applied in this situation)"
|
applied in this situation)"
|
||||||
| ConflictError cpos ->
|
| ConflictError cpos ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
(List.map
|
(List.map
|
||||||
(fun pos -> Some "This consequence has a valid justification:", pos)
|
(fun pos -> Some "This consequence has a valid justification:", pos)
|
||||||
cpos)
|
cpos)
|
||||||
@ -925,9 +927,9 @@ let interp_failure_message ~pos = function
|
|||||||
the same variable."
|
the same variable."
|
||||||
| Crash ->
|
| Crash ->
|
||||||
(* This constructor seems to be never used *)
|
(* This constructor seems to be never used *)
|
||||||
Message.raise_spanned_error pos "Internal error, the interpreter crashed"
|
Message.error ~pos "Internal error, the interpreter crashed"
|
||||||
| EmptyError ->
|
| EmptyError ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Internal error, a variable without valid definition escaped"
|
"Internal error, a variable without valid definition escaped"
|
||||||
|
|
||||||
let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
||||||
@ -980,7 +982,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
|||||||
]
|
]
|
||||||
mark_e
|
mark_e
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Mark.get ty)
|
Message.error ~pos:(Mark.get ty)
|
||||||
"This scope needs an input argument of type %a to be executed. \
|
"This scope needs an input argument of type %a to be executed. \
|
||||||
But the Catala built-in interpreter does not have a way to \
|
But the Catala built-in interpreter does not have a way to \
|
||||||
retrieve input values from the command line, so it cannot \
|
retrieve input values from the command line, so it cannot \
|
||||||
@ -1006,12 +1008,12 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
|||||||
| exception CatalaException (except, pos) ->
|
| exception CatalaException (except, pos) ->
|
||||||
interp_failure_message ~pos except
|
interp_failure_message ~pos except
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The interpretation of a program should always yield a struct \
|
"The interpretation of a program should always yield a struct \
|
||||||
corresponding to the scope variables"
|
corresponding to the scope variables"
|
||||||
end
|
end
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The interpreter can only interpret terms starting with functions having \
|
"The interpreter can only interpret terms starting with functions having \
|
||||||
thunked arguments"
|
thunked arguments"
|
||||||
|
|
||||||
@ -1038,7 +1040,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
|||||||
(Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out)
|
(Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out)
|
||||||
ty_in (Expr.mark_pos mark_e)
|
ty_in (Expr.mark_pos mark_e)
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Mark.get ty)
|
Message.error ~pos:(Mark.get ty)
|
||||||
"This scope needs input arguments to be executed. But the Catala \
|
"This scope needs input arguments to be executed. But the Catala \
|
||||||
built-in interpreter does not have a way to retrieve input \
|
built-in interpreter does not have a way to retrieve input \
|
||||||
values from the command line, so it cannot execute this scope. \
|
values from the command line, so it cannot execute this scope. \
|
||||||
@ -1063,12 +1065,12 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
|||||||
| exception CatalaException (except, pos) ->
|
| exception CatalaException (except, pos) ->
|
||||||
interp_failure_message ~pos except
|
interp_failure_message ~pos except
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The interpretation of a program should always yield a struct \
|
"The interpretation of a program should always yield a struct \
|
||||||
corresponding to the scope variables"
|
corresponding to the scope variables"
|
||||||
end
|
end
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"The interpreter can only interpret terms starting with functions having \
|
"The interpreter can only interpret terms starting with functions having \
|
||||||
thunked arguments"
|
thunked arguments"
|
||||||
|
|
||||||
@ -1088,23 +1090,22 @@ let load_runtime_modules prg =
|
|||||||
^ ".cmo")
|
^ ".cmo")
|
||||||
in
|
in
|
||||||
if not (Sys.file_exists obj_file) then
|
if not (Sys.file_exists obj_file) then
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
|
~pos_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
|
||||||
(Mark.get (ModuleName.get_info m))
|
~pos:(Mark.get (ModuleName.get_info m))
|
||||||
"Compiled OCaml object %a not found. Make sure it has been suitably \
|
"Compiled OCaml object %a not found. Make sure it has been suitably \
|
||||||
compiled."
|
compiled."
|
||||||
File.format obj_file
|
File.format obj_file
|
||||||
else
|
else
|
||||||
try Dynlink.loadfile obj_file
|
try Dynlink.loadfile obj_file
|
||||||
with Dynlink.Error dl_err ->
|
with Dynlink.Error dl_err ->
|
||||||
Message.raise_error
|
Message.error "Error loading compiled module from %a:@;<1 2>@[<hov>%a@]"
|
||||||
"Error loading compiled module from %a:@;<1 2>@[<hov>%a@]" File.format
|
File.format obj_file Format.pp_print_text
|
||||||
obj_file Format.pp_print_text
|
|
||||||
(Dynlink.error_message dl_err)
|
(Dynlink.error_message dl_err)
|
||||||
in
|
in
|
||||||
let modules_list_topo = Program.modules_to_list prg.decl_ctx.ctx_modules in
|
let modules_list_topo = Program.modules_to_list prg.decl_ctx.ctx_modules in
|
||||||
if modules_list_topo <> [] then
|
if modules_list_topo <> [] then
|
||||||
Message.emit_debug "Loading shared modules... %a"
|
Message.debug "Loading shared modules... %a"
|
||||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space ModuleName.format)
|
(Format.pp_print_list ~pp_sep:Format.pp_print_space ModuleName.format)
|
||||||
modules_list_topo;
|
modules_list_topo;
|
||||||
List.iter load modules_list_topo
|
List.iter load modules_list_topo
|
||||||
|
@ -548,7 +548,8 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
|
|||||||
in
|
in
|
||||||
resolve_overload_aux (Mark.remove op) operands
|
resolve_overload_aux (Mark.remove op) operands
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
((None, Mark.get op)
|
((None, Mark.get op)
|
||||||
:: List.map
|
:: List.map
|
||||||
(fun ty ->
|
(fun ty ->
|
||||||
|
@ -71,7 +71,7 @@ let rec typ_to_ast ~(flags : flags) (ty : unionfind_typ) : A.typ =
|
|||||||
(* No polymorphism in Catala: type inference should return full types
|
(* No polymorphism in Catala: type inference should return full types
|
||||||
without wildcards, and this function is used to recover the types after
|
without wildcards, and this function is used to recover the types after
|
||||||
typing. *)
|
typing. *)
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Internal error: typing at this point could not be resolved"
|
"Internal error: typing at this point could not be resolved"
|
||||||
else A.TAny, pos
|
else A.TAny, pos
|
||||||
| TClosureEnv -> TClosureEnv, pos
|
| TClosureEnv -> TClosureEnv, pos
|
||||||
@ -186,8 +186,8 @@ let rec unify
|
|||||||
(t1 : unionfind_typ)
|
(t1 : unionfind_typ)
|
||||||
(t2 : unionfind_typ) : unit =
|
(t2 : unionfind_typ) : unit =
|
||||||
let unify = unify ctx in
|
let unify = unify ctx in
|
||||||
(* Message.emit_debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ
|
(* Message.debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx)
|
||||||
ctx) t2; *)
|
t2; *)
|
||||||
let t1_repr = UnionFind.get (UnionFind.find t1) in
|
let t1_repr = UnionFind.get (UnionFind.find t1) in
|
||||||
let t2_repr = UnionFind.get (UnionFind.find t2) in
|
let t2_repr = UnionFind.get (UnionFind.find t2) in
|
||||||
let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in
|
let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in
|
||||||
@ -263,8 +263,8 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
|
|||||||
t2_pos );
|
t2_pos );
|
||||||
]
|
]
|
||||||
in
|
in
|
||||||
Message.raise_multispanned_error_full
|
Message.error
|
||||||
(List.map (fun (a, b) -> Some a, b) pos_msgs)
|
~fmt_pos:(List.map (fun (a, b) -> Some a, b) pos_msgs)
|
||||||
"@[<v>Error during typechecking, incompatible types:@,\
|
"@[<v>Error during typechecking, incompatible types:@,\
|
||||||
@[<v>@{<bold;blue>@<3>%s@} @[<hov>%a@]@,\
|
@[<v>@{<bold;blue>@<3>%s@} @[<hov>%a@]@,\
|
||||||
@{<bold;blue>@<3>%s@} @[<hov>%a@]@]@]" "┌─⯈" (format_typ ctx) t1 "└─⯈"
|
@{<bold;blue>@<3>%s@} @[<hov>%a@]@]@]" "┌─⯈" (format_typ ctx) t1 "└─⯈"
|
||||||
@ -350,7 +350,7 @@ let polymorphic_op_return_type
|
|||||||
| (HandleDefault | HandleDefaultOpt), [_; _; tf] -> return_type tf 1
|
| (HandleDefault | HandleDefaultOpt), [_; _; tf] -> return_type tf 1
|
||||||
| ToClosureEnv, _ -> uf TClosureEnv
|
| ToClosureEnv, _ -> uf TClosureEnv
|
||||||
| FromClosureEnv, _ -> any ()
|
| FromClosureEnv, _ -> any ()
|
||||||
| _ -> Message.raise_spanned_error pos "Mismatched operator arguments"
|
| _ -> Message.error ~pos "Mismatched operator arguments"
|
||||||
|
|
||||||
let resolve_overload_ret_type
|
let resolve_overload_ret_type
|
||||||
~flags
|
~flags
|
||||||
@ -472,7 +472,7 @@ and typecheck_expr_top_down :
|
|||||||
(a, m) A.gexpr ->
|
(a, m) A.gexpr ->
|
||||||
(a, unionfind_typ A.custom) A.boxed_gexpr =
|
(a, unionfind_typ A.custom) A.boxed_gexpr =
|
||||||
fun ctx env tau e ->
|
fun ctx env tau e ->
|
||||||
(* Message.emit_debug "Propagating type %a for naked_expr :@.@[<hov 2>%a@]"
|
(* Message.debug "Propagating type %a for naked_expr :@.@[<hov 2>%a@]"
|
||||||
(format_typ ctx) tau Expr.format e; *)
|
(format_typ ctx) tau Expr.format e; *)
|
||||||
let pos_e = Expr.pos e in
|
let pos_e = Expr.pos e in
|
||||||
let flags = env.flags in
|
let flags = env.flags in
|
||||||
@ -504,8 +504,7 @@ and typecheck_expr_top_down :
|
|||||||
match ty_opt with
|
match ty_opt with
|
||||||
| Some ty -> ty
|
| Some ty -> ty
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error pos_e "Reference to %a not found"
|
Message.error ~pos:pos_e "Reference to %a not found" (Print.expr ()) e
|
||||||
(Print.expr ()) e
|
|
||||||
in
|
in
|
||||||
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
|
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
|
||||||
| A.EStruct { name; fields } ->
|
| A.EStruct { name; fields } ->
|
||||||
@ -539,7 +538,7 @@ and typecheck_expr_top_down :
|
|||||||
(A.StructField.Map.bindings extra_fields)
|
(A.StructField.Map.bindings extra_fields)
|
||||||
in
|
in
|
||||||
if errs <> [] then
|
if errs <> [] then
|
||||||
Message.raise_multispanned_error errs
|
Message.error ~extra_pos:errs
|
||||||
"Mismatching field definitions for structure %a" A.StructName.format
|
"Mismatching field definitions for structure %a" A.StructName.format
|
||||||
name
|
name
|
||||||
in
|
in
|
||||||
@ -565,15 +564,15 @@ and typecheck_expr_top_down :
|
|||||||
Printf.ksprintf failwith
|
Printf.ksprintf failwith
|
||||||
"Disambiguation failed before reaching field %s" field
|
"Disambiguation failed before reaching field %s" field
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"This is not a structure, cannot access field %s (found type: %a)"
|
"This is not a structure, cannot access field %s (found type: %a)"
|
||||||
field (format_typ ctx) (ty e_struct')
|
field (format_typ ctx) (ty e_struct')
|
||||||
in
|
in
|
||||||
let str =
|
let str =
|
||||||
try A.StructName.Map.find name env.structs
|
try A.StructName.Map.find name env.structs
|
||||||
with A.StructName.Map.Not_found _ ->
|
with A.StructName.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error pos_e "No structure %a found"
|
Message.error ~pos:pos_e "No structure %a found" A.StructName.format
|
||||||
A.StructName.format name
|
name
|
||||||
in
|
in
|
||||||
let field =
|
let field =
|
||||||
let candidate_structs =
|
let candidate_structs =
|
||||||
@ -587,7 +586,8 @@ and typecheck_expr_top_down :
|
|||||||
ctx.ctx_scopes
|
ctx.ctx_scopes
|
||||||
with
|
with
|
||||||
| Some (scope_out, _) ->
|
| Some (scope_out, _) ->
|
||||||
Message.raise_multispanned_error_full
|
Message.error
|
||||||
|
~fmt_pos:
|
||||||
[
|
[
|
||||||
( Some
|
( Some
|
||||||
(fun ppf ->
|
(fun ppf ->
|
||||||
@ -605,7 +605,8 @@ and typecheck_expr_top_down :
|
|||||||
~suggestion:
|
~suggestion:
|
||||||
(List.map A.StructField.to_string (A.StructField.Map.keys str))
|
(List.map A.StructField.to_string (A.StructField.Map.keys str))
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, Expr.mark_pos context_mark;
|
None, Expr.mark_pos context_mark;
|
||||||
( Some "Structure definition",
|
( Some "Structure definition",
|
||||||
@ -618,8 +619,8 @@ and typecheck_expr_top_down :
|
|||||||
in
|
in
|
||||||
try A.StructName.Map.find name candidate_structs
|
try A.StructName.Map.find name candidate_structs
|
||||||
with A.StructName.Map.Not_found _ ->
|
with A.StructName.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error
|
Message.error
|
||||||
(Expr.mark_pos context_mark)
|
~pos:(Expr.mark_pos context_mark)
|
||||||
"@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
|
"@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
|
||||||
@{<yellow>\"%a\"@}@ (however, structure %a defines it)@]"
|
@{<yellow>\"%a\"@}@ (however, structure %a defines it)@]"
|
||||||
field A.StructName.format name
|
field A.StructName.format name
|
||||||
@ -638,12 +639,13 @@ and typecheck_expr_top_down :
|
|||||||
let str =
|
let str =
|
||||||
try A.StructName.Map.find name env.structs
|
try A.StructName.Map.find name env.structs
|
||||||
with A.StructName.Map.Not_found _ ->
|
with A.StructName.Map.Not_found _ ->
|
||||||
Message.raise_spanned_error pos_e "No structure %a found"
|
Message.error ~pos:pos_e "No structure %a found" A.StructName.format
|
||||||
A.StructName.format name
|
name
|
||||||
in
|
in
|
||||||
try A.StructField.Map.find field str
|
try A.StructField.Map.find field str
|
||||||
with A.StructField.Map.Not_found _ ->
|
with A.StructField.Map.Not_found _ ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
None, pos_e;
|
None, pos_e;
|
||||||
( Some "Structure %a declared here",
|
( Some "Structure %a declared here",
|
||||||
@ -747,14 +749,14 @@ and typecheck_expr_top_down :
|
|||||||
match Env.get env v with
|
match Env.get env v with
|
||||||
| Some t -> t
|
| Some t -> t
|
||||||
| None ->
|
| None ->
|
||||||
Message.raise_spanned_error pos_e
|
Message.error ~pos:pos_e "Variable %s not found in the current context"
|
||||||
"Variable %s not found in the current context" (Bindlib.name_of v)
|
(Bindlib.name_of v)
|
||||||
in
|
in
|
||||||
Expr.evar (Var.translate v) (mark_with_tau_and_unify tau')
|
Expr.evar (Var.translate v) (mark_with_tau_and_unify tau')
|
||||||
| A.EExternal { name } ->
|
| A.EExternal { name } ->
|
||||||
let ty =
|
let ty =
|
||||||
let not_found pr x =
|
let not_found pr x =
|
||||||
Message.raise_spanned_error pos_e
|
Message.error ~pos:pos_e
|
||||||
"Could not resolve the reference to %a.@ Make sure the corresponding \
|
"Could not resolve the reference to %a.@ Make sure the corresponding \
|
||||||
module was properly loaded?"
|
module was properly loaded?"
|
||||||
pr x
|
pr x
|
||||||
@ -783,8 +785,8 @@ and typecheck_expr_top_down :
|
|||||||
Expr.etuple es' mark
|
Expr.etuple es' mark
|
||||||
| A.ETupleAccess { e = e1; index; size } ->
|
| A.ETupleAccess { e = e1; index; size } ->
|
||||||
if index >= size then
|
if index >= size then
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e) "Tuple access out of bounds (%d/%d)" index
|
||||||
"Tuple access out of bounds (%d/%d)" index size;
|
size;
|
||||||
let tuple_ty =
|
let tuple_ty =
|
||||||
TTuple
|
TTuple
|
||||||
(List.init size (fun n ->
|
(List.init size (fun n ->
|
||||||
@ -794,7 +796,7 @@ and typecheck_expr_top_down :
|
|||||||
Expr.etupleaccess ~e:e1' ~index ~size context_mark
|
Expr.etupleaccess ~e:e1' ~index ~size context_mark
|
||||||
| A.EAbs { binder; tys = t_args } ->
|
| A.EAbs { binder; tys = t_args } ->
|
||||||
if Bindlib.mbinder_arity binder <> List.length t_args then
|
if Bindlib.mbinder_arity binder <> List.length t_args then
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"function has %d variables but was supplied %d types\n%a"
|
"function has %d variables but was supplied %d types\n%a"
|
||||||
(Bindlib.mbinder_arity binder)
|
(Bindlib.mbinder_arity binder)
|
||||||
(List.length t_args) Expr.format e
|
(List.length t_args) Expr.format e
|
||||||
@ -833,7 +835,7 @@ and typecheck_expr_top_down :
|
|||||||
match UnionFind.get t with TTuple tys, _ -> tys | _ -> t_args)
|
match UnionFind.get t with TTuple tys, _ -> tys | _ -> t_args)
|
||||||
| _ ->
|
| _ ->
|
||||||
if List.length t_args <> List.length args' then
|
if List.length t_args <> List.length args' then
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
(match e1 with
|
(match e1 with
|
||||||
| EAbs _, _ -> "This binds %d variables, but %d were provided."
|
| EAbs _, _ -> "This binds %d variables, but %d were provided."
|
||||||
| _ -> "This function application has %d arguments, but expects %d.")
|
| _ -> "This function application has %d arguments, but expects %d.")
|
||||||
|
@ -845,7 +845,7 @@ let lex_line (lexbuf : lexbuf) : (string * L.line_token) option =
|
|||||||
let id = Re.Group.get (Re.exec line_test_id_re str) 1 in
|
let id = Re.Group.get (Re.exec line_test_id_re str) 1 in
|
||||||
Some (str, LINE_TEST id)
|
Some (str, LINE_TEST id)
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
Message.emit_spanned_warning (Pos.from_lpos (lexing_positions lexbuf))
|
Message.warning ~pos:(Pos.from_lpos (lexing_positions lexbuf))
|
||||||
"Ignored invalid test section, must have an explicit \
|
"Ignored invalid test section, must have an explicit \
|
||||||
`{ id = \"name\" }` specification";
|
`{ id = \"name\" }` specification";
|
||||||
Some (str, LINE_ANY))
|
Some (str, LINE_ANY))
|
||||||
|
@ -60,7 +60,7 @@ let update_acc (lexbuf : lexbuf) : unit =
|
|||||||
|
|
||||||
(** Error-generating helper *)
|
(** Error-generating helper *)
|
||||||
let raise_lexer_error (loc : Pos.t) (token : string) =
|
let raise_lexer_error (loc : Pos.t) (token : string) =
|
||||||
Message.raise_spanned_error loc
|
Message.error ~pos:loc
|
||||||
"Parsing error after token \"%s\": what comes after is unknown" token
|
"Parsing error after token \"%s\": what comes after is unknown" token
|
||||||
|
|
||||||
(** Associative list matching each punctuation string part of the Catala syntax
|
(** Associative list matching each punctuation string part of the Catala syntax
|
||||||
|
@ -136,7 +136,7 @@ let lident :=
|
|||||||
| i = LIDENT ; {
|
| i = LIDENT ; {
|
||||||
match Localisation.lex_builtin i with
|
match Localisation.lex_builtin i with
|
||||||
| Some _ ->
|
| Some _ ->
|
||||||
Message.raise_spanned_error
|
Message.error ~pos:
|
||||||
(Pos.from_lpos $sloc)
|
(Pos.from_lpos $sloc)
|
||||||
"Reserved builtin name"
|
"Reserved builtin name"
|
||||||
| None ->
|
| None ->
|
||||||
@ -173,7 +173,7 @@ let naked_expression ==
|
|||||||
match Localisation.lex_builtin (Mark.remove id), state with
|
match Localisation.lex_builtin (Mark.remove id), state with
|
||||||
| Some b, None -> Builtin b
|
| Some b, None -> Builtin b
|
||||||
| Some _, Some _ ->
|
| Some _, Some _ ->
|
||||||
Message.raise_spanned_error
|
Message.error ~pos:
|
||||||
(Pos.from_lpos $loc(id))
|
(Pos.from_lpos $loc(id))
|
||||||
"Invalid use of built-in @{<bold>%s@}" (Mark.remove id)
|
"Invalid use of built-in @{<bold>%s@}" (Mark.remove id)
|
||||||
| None, state -> Ident ([], id, state)
|
| None, state -> Ident ([], id, state)
|
||||||
@ -524,7 +524,7 @@ let scope_item :=
|
|||||||
| Some Round ->
|
| Some Round ->
|
||||||
DateRounding(v), Mark.get v
|
DateRounding(v), Mark.get v
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error
|
Message.error ~pos:
|
||||||
(Pos.from_lpos $loc(i))
|
(Pos.from_lpos $loc(i))
|
||||||
"Expected the form 'date round increasing' or 'date round decreasing'"
|
"Expected the form 'date round increasing' or 'date round decreasing'"
|
||||||
}
|
}
|
||||||
@ -563,7 +563,7 @@ let scope_decl_item_attribute ==
|
|||||||
i = lident ; {
|
i = lident ; {
|
||||||
match input, output with
|
match input, output with
|
||||||
| (Some Internal, _), (true, pos) ->
|
| (Some Internal, _), (true, pos) ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"A variable cannot be declared both 'internal' and 'output'."
|
"A variable cannot be declared both 'internal' and 'output'."
|
||||||
| input, output -> input, output, i
|
| input, output -> input, output, i
|
||||||
}
|
}
|
||||||
@ -573,7 +573,7 @@ let scope_decl_item_attribute_mandatory ==
|
|||||||
let in_attr_opt, out_attr, i = attr in
|
let in_attr_opt, out_attr, i = attr in
|
||||||
let in_attr = match in_attr_opt, out_attr with
|
let in_attr = match in_attr_opt, out_attr with
|
||||||
| (None, _), (false, _) ->
|
| (None, _), (false, _) ->
|
||||||
Message.raise_spanned_error (Pos.from_lpos $loc(attr))
|
Message.error ~pos:(Pos.from_lpos $loc(attr))
|
||||||
"Variable declaration requires input qualification ('internal', \
|
"Variable declaration requires input qualification ('internal', \
|
||||||
'input' or 'context')"
|
'input' or 'context')"
|
||||||
| (None, pos), (true, _) -> Internal, pos
|
| (None, pos), (true, _) -> Internal, pos
|
||||||
@ -612,7 +612,7 @@ let scope_decl_item :=
|
|||||||
scope_decl_context_io_output = out;
|
scope_decl_context_io_output = out;
|
||||||
};
|
};
|
||||||
| (Some _, pos), _ ->
|
| (Some _, pos), _ ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"Scope declaration does not support input qualifiers ('internal', \
|
"Scope declaration does not support input qualifiers ('internal', \
|
||||||
'input' or 'context')"
|
'input' or 'context')"
|
||||||
in
|
in
|
||||||
|
@ -72,7 +72,8 @@ let raise_parser_error
|
|||||||
(last_good_loc : Pos.t option)
|
(last_good_loc : Pos.t option)
|
||||||
(token : string)
|
(token : string)
|
||||||
(msg : Format.formatter -> unit) : 'a =
|
(msg : Format.formatter -> unit) : 'a =
|
||||||
Message.raise_multispanned_error_full ?suggestion
|
Message.error ?suggestion
|
||||||
|
~fmt_pos:
|
||||||
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
|
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
|
||||||
::
|
::
|
||||||
(match last_good_loc with
|
(match last_good_loc with
|
||||||
@ -244,7 +245,7 @@ let with_sedlex_file file f =
|
|||||||
(** Parses a single source file *)
|
(** Parses a single source file *)
|
||||||
let rec parse_source (lexbuf : Sedlexing.lexbuf) : Ast.program =
|
let rec parse_source (lexbuf : Sedlexing.lexbuf) : Ast.program =
|
||||||
let source_file_name = lexbuf_file lexbuf in
|
let source_file_name = lexbuf_file lexbuf in
|
||||||
Message.emit_debug "Parsing %a" File.format source_file_name;
|
Message.debug "Parsing %a" File.format source_file_name;
|
||||||
let language = Cli.file_lang source_file_name in
|
let language = Cli.file_lang source_file_name in
|
||||||
let commands = localised_parser language lexbuf in
|
let commands = localised_parser language lexbuf in
|
||||||
let program = expand_includes source_file_name commands in
|
let program = expand_includes source_file_name commands in
|
||||||
@ -266,8 +267,8 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
|
|||||||
match acc.Ast.program_module_name, name_opt with
|
match acc.Ast.program_module_name, name_opt with
|
||||||
| opt, None | None, opt -> opt
|
| opt, None | None, opt -> opt
|
||||||
| Some id1, Some id2 ->
|
| Some id1, Some id2 ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
[None, Mark.get id1; None, Mark.get id2]
|
~extra_pos:[None, Mark.get id1; None, Mark.get id2]
|
||||||
"Multiple definitions of the module name"
|
"Multiple definitions of the module name"
|
||||||
in
|
in
|
||||||
match command with
|
match command with
|
||||||
@ -295,7 +296,8 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
|
|||||||
includ_program.Ast.program_module_name
|
includ_program.Ast.program_module_name
|
||||||
|> Option.iter
|
|> Option.iter
|
||||||
@@ fun id ->
|
@@ fun id ->
|
||||||
Message.raise_multispanned_error
|
Message.error
|
||||||
|
~extra_pos:
|
||||||
[
|
[
|
||||||
Some "File include", Mark.get inc_file;
|
Some "File include", Mark.get inc_file;
|
||||||
Some "Module declaration", Mark.get id;
|
Some "Module declaration", Mark.get id;
|
||||||
@ -403,7 +405,7 @@ let check_modname program source_file =
|
|||||||
| ( Some (mname, pos),
|
| ( Some (mname, pos),
|
||||||
(Global.FileName file | Global.Contents (_, file) | Global.Stdin file) )
|
(Global.FileName file | Global.Contents (_, file) | Global.Stdin file) )
|
||||||
when not File.(equal mname Filename.(remove_extension (basename file))) ->
|
when not File.(equal mname Filename.(remove_extension (basename file))) ->
|
||||||
Message.raise_spanned_error pos
|
Message.error ~pos
|
||||||
"@[<hov>Module declared as@ @{<blue>%s@},@ which@ does@ not@ match@ the@ \
|
"@[<hov>Module declared as@ @{<blue>%s@},@ which@ does@ not@ match@ the@ \
|
||||||
file@ name@ %a.@ Rename the module to@ @{<blue>%s@}@ or@ the@ file@ to@ \
|
file@ name@ %a.@ Rename the module to@ @{<blue>%s@}@ or@ the@ file@ to@ \
|
||||||
%a.@]"
|
%a.@]"
|
||||||
@ -422,7 +424,7 @@ let load_interface ?default_module_name source_file =
|
|||||||
| None, Some n ->
|
| None, Some n ->
|
||||||
n, Pos.from_info (Global.input_src_file source_file) 0 0 0 0
|
n, Pos.from_info (Global.input_src_file source_file) 0 0 0 0
|
||||||
| None, None ->
|
| None, None ->
|
||||||
Message.raise_error
|
Message.error
|
||||||
"%a doesn't define a module name. It should contain a '@{<cyan>> \
|
"%a doesn't define a module name. It should contain a '@{<cyan>> \
|
||||||
Module %s@}' directive."
|
Module %s@}' directive."
|
||||||
File.format
|
File.format
|
||||||
|
@ -115,7 +115,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
|
|||||||
match Mark.remove body with
|
match Mark.remove body with
|
||||||
| EErrorOnEmpty e -> e
|
| EErrorOnEmpty e -> e
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Internal error: this expression does not have the structure expected \
|
"Internal error: this expression does not have the structure expected \
|
||||||
by the VC generator:\n\
|
by the VC generator:\n\
|
||||||
%a"
|
%a"
|
||||||
@ -300,7 +300,7 @@ let rec generate_verification_conditions_scope_body_expr
|
|||||||
let e = match_and_ignore_outer_reentrant_default ctx e in
|
let e = match_and_ignore_outer_reentrant_default ctx e in
|
||||||
ctx, [], [e]
|
ctx, [], [e]
|
||||||
| _ ->
|
| _ ->
|
||||||
Message.raise_spanned_error (Expr.pos e)
|
Message.error ~pos:(Expr.pos e)
|
||||||
"Internal error: this assertion does not have the structure \
|
"Internal error: this assertion does not have the structure \
|
||||||
expected by the VC generator:\n\
|
expected by the VC generator:\n\
|
||||||
%a"
|
%a"
|
||||||
|
@ -144,9 +144,9 @@ module MakeBackendIO (B : Backend) = struct
|
|||||||
(vc : Conditions.verification_condition * vc_encoding_result) : bool =
|
(vc : Conditions.verification_condition * vc_encoding_result) : bool =
|
||||||
let vc, z3_vc = vc in
|
let vc, z3_vc = vc in
|
||||||
|
|
||||||
Message.emit_debug "@[<v>For this variable:@,%a@,@]" Pos.format_loc_text
|
Message.debug "@[<v>For this variable:@,%a@,@]" Pos.format_loc_text
|
||||||
(Expr.pos vc.Conditions.vc_guard);
|
(Expr.pos vc.Conditions.vc_guard);
|
||||||
Message.emit_debug
|
Message.debug
|
||||||
"@[<v>This verification condition was generated for @{<yellow>%s@}:@,\
|
"@[<v>This verification condition was generated for @{<yellow>%s@}:@,\
|
||||||
%a@,\
|
%a@,\
|
||||||
with assertions:@,\
|
with assertions:@,\
|
||||||
@ -159,16 +159,16 @@ module MakeBackendIO (B : Backend) = struct
|
|||||||
|
|
||||||
match z3_vc with
|
match z3_vc with
|
||||||
| Success (encoding, backend_ctx) -> (
|
| Success (encoding, backend_ctx) -> (
|
||||||
Message.emit_debug "@[<v>The translation to Z3 is the following:@,%s@]"
|
Message.debug "@[<v>The translation to Z3 is the following:@,%s@]"
|
||||||
(B.print_encoding encoding);
|
(B.print_encoding encoding);
|
||||||
match B.solve_vc_encoding backend_ctx encoding with
|
match B.solve_vc_encoding backend_ctx encoding with
|
||||||
| ProvenTrue -> true
|
| ProvenTrue -> true
|
||||||
| ProvenFalse model ->
|
| ProvenFalse model ->
|
||||||
Message.emit_warning "%s" (print_negative_result vc backend_ctx model);
|
Message.warning "%s" (print_negative_result vc backend_ctx model);
|
||||||
false
|
false
|
||||||
| Unknown -> failwith "The solver failed at proving or disproving the VC")
|
| Unknown -> failwith "The solver failed at proving or disproving the VC")
|
||||||
| Fail msg ->
|
| Fail msg ->
|
||||||
Message.emit_warning
|
Message.warning
|
||||||
"@[<v>@{<yellow>[%a.%s]@} The translation to Z3 failed:@,%s@]"
|
"@[<v>@{<yellow>[%a.%s]@} The translation to Z3 failed:@,%s@]"
|
||||||
ScopeName.format vc.vc_scope
|
ScopeName.format vc.vc_scope
|
||||||
(Bindlib.name_of (Mark.remove vc.vc_variable))
|
(Bindlib.name_of (Mark.remove vc.vc_variable))
|
||||||
|
@ -48,5 +48,4 @@ let solve_vc
|
|||||||
else false)
|
else false)
|
||||||
true z3_vcs
|
true z3_vcs
|
||||||
in
|
in
|
||||||
if all_proven then
|
if all_proven then Message.result "No errors found during the proof mode run."
|
||||||
Message.emit_result "No errors found during the proof mode run."
|
|
||||||
|
@ -18,7 +18,7 @@
|
|||||||
without the expected backend. All functions print an error message and exit *)
|
without the expected backend. All functions print an error message and exit *)
|
||||||
|
|
||||||
let dummy () =
|
let dummy () =
|
||||||
Catala_utils.Message.raise_error
|
Catala_utils.Message.error
|
||||||
"This instance of Catala was compiled without Z3 support."
|
"This instance of Catala was compiled without Z3 support."
|
||||||
|
|
||||||
module Io = struct
|
module Io = struct
|
||||||
|
@ -804,8 +804,7 @@ module Backend = struct
|
|||||||
let ctx, vc = translate_expr ctx e in
|
let ctx, vc = translate_expr ctx e in
|
||||||
add_z3constraint vc ctx
|
add_z3constraint vc ctx
|
||||||
|
|
||||||
let init_backend () =
|
let init_backend () = Message.debug "Running Z3 version %s" Version.to_string
|
||||||
Message.emit_debug "Running Z3 version %s" Version.to_string
|
|
||||||
|
|
||||||
let make_context (decl_ctx : decl_ctx) : backend_context =
|
let make_context (decl_ctx : decl_ctx) : backend_context =
|
||||||
let cfg =
|
let cfg =
|
||||||
|
Loading…
Reference in New Issue
Block a user