diff --git a/.github/workflows/run-make-all.yml b/.github/workflows/run-make-all.yml index 3bd9da0a..c6a5e741 100644 --- a/.github/workflows/run-make-all.yml +++ b/.github/workflows/run-make-all.yml @@ -22,8 +22,8 @@ jobs: fetch-depth: 0 - name: Prepare container with all dependencies run: git archive HEAD | docker build - --target dev-build-context - - name: Escape slashes in IMAGE_TAG (to avoid Docker issues) - run: echo "IMAGE_TAG=${IMAGE_TAG////--}" >> $GITHUB_ENV + - name: Escape chars in IMAGE_TAG (to avoid Docker issues) + run: sed 's/[^a-zA-Z0-9-]/-/g; s/^/IMAGE_TAG=/' <<<"${IMAGE_TAG}" >> $GITHUB_ENV - name: Run builds, checks and tests run: git archive HEAD | docker build - --force-rm -t "catalalang/catala-build:${IMAGE_TAG}" - name: Cleanup Docker image diff --git a/Makefile b/Makefile index c5058f32..2e4bc71f 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ export # Dependencies ########################################## -EXECUTABLES = groff python3 colordiff node node npm ninja pandoc +EXECUTABLES = groff python3 node npm ninja pandoc K := $(foreach exec,$(EXECUTABLES),\ $(if $(shell which $(exec)),some string,$(warning [WARNING] No "$(exec)" executable found. \ Please install this executable for everything to work smoothly))) @@ -315,10 +315,10 @@ CLERK=$(CLERK_BIN) --exe $(CATALA_BIN) \ .FORCE: -test_suite: .FORCE compiler +test_suite: .FORCE install @$(MAKE) -C tests pass_all_tests -test_examples: .FORCE compiler +test_examples: .FORCE install @$(MAKE) -C examples pass_all_tests #> tests : Run interpreter tests diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index f8469d47..dc9d8b0b 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -171,94 +171,7 @@ let readdir_sort (dirname : string) : string array = let dirs = Sys.readdir dirname in Array.fast_sort String.compare dirs; dirs - with Sys_error _ -> Array.make 0 "" - -type test = { - text_before : string; - (** Verbatim of everything from the last test end or beginning of file up - to the test output start *) - params : string list; - (** Catala command-line arguments for the test *) - (* Also contains test_output and return_code, but they are not relevant - for just running the test *) -} - -type file_tests = { - tests : test list; - text_after : string; (** Verbatim of everything following the last test *) -} - -let inline_test_start_key = "```catala-test-inline" - -let has_inline_tests (file : string) : bool = - let rec aux ic = - match input_line ic with - | exception End_of_file -> false - | li -> String.starts_with ~prefix:inline_test_start_key li || aux ic - in - File.with_in_channel file aux - -let [@ocamlformat "disable"] scan_for_inline_tests (file : string) - : file_tests option = - File.with_in_channel file - @@ fun ic -> - (* Matches something of the form: {v - ```catala-test-inline - $ catala Interpret -s A - ... output from catala ... - #return code 10# - ``` - v} *) - let test_start_rex = - Re.(compile (seq [bol; str inline_test_start_key; rep space; char '\n'])) - in - let test_content_rex = - Re.compile - Re.( - seq - [ - seq [char '$'; rep space; str "catala"; group (rep1 notnl); - char '\n']; - group (non_greedy (rep any)); - seq [bol; str "```\n"]; - ]) - in - let file_str = really_input_string ic (in_channel_length ic) in - let rec scan acc pos0 = - try - let header = Re.exec ~pos:pos0 test_start_rex file_str in - let pos = Re.Group.stop header 0 in - let test_contents = - try Re.exec ~pos test_content_rex file_str - with Not_found -> - let line = - String.fold_left - (fun n -> function '\n' -> n + 1 | _ -> n) - 1 - (String.sub file_str 0 pos) - in - Message.raise_error "Bad inline-test format at %s line %d" file line - in - let params = - List.filter (( <> ) "") - (String.split_on_char ' ' (Re.Group.get test_contents 1)) - in - let out_start = Re.Group.start test_contents 2 in - let test = - { text_before = String.sub file_str pos0 (out_start - pos0); params } - in - scan (test :: acc) (Re.Group.stop test_contents 2) - with Not_found -> ( - match acc with - | [] -> None - | tests -> - Some - { - tests = List.rev tests; - text_after = String.sub file_str pos0 (String.length file_str - pos0); - }) - in - scan [] 0 + with Sys_error _ -> [||] (** Given a file, looks in the relative [output] directory if there are files with the same base name that contain expected outputs for different *) @@ -477,7 +390,7 @@ let collect_inline_ninja_builds (ninja : ninja) (tested_file : string) (reset_test_outputs : bool) : (string * ninja) option = - if not (has_inline_tests tested_file) then None + if not (Clerk_runtest.has_inline_tests tested_file) then None else let ninja = let vars = [Var.(name tested_file), Nj.Expr.Lit tested_file] in @@ -609,74 +522,6 @@ let add_root_test_build ninja.builds; } -(** Directly runs the test (not using ninja, this will be called by ninja rules - through the "clerk runtest" command) *) -let run_inline_tests - ~(reset : bool) - (file : string) - (catala_exe : string) - (catala_opts : string list) = - match scan_for_inline_tests file with - | None -> Message.emit_warning "No inline tests found in %s" file - | Some file_tests -> - let run oc = - List.iter - (fun test -> - output_string oc test.text_before; - let cmd_out_rd, cmd_out_wr = Unix.pipe () in - let ic = Unix.in_channel_of_descr cmd_out_rd in - let cmd = - Array.of_list ((catala_exe :: catala_opts) @ test.params @ [file]) - in - let env = - Unix.environment () - |> Array.to_seq - |> Seq.filter (fun s -> - not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s)) - |> Seq.cons "CATALA_OUT=-" - |> Seq.cons "CATALA_COLOR=never" - |> Seq.cons "CATALA_PLUGINS=" - |> Array.of_seq - in - let pid = - Unix.create_process_env catala_exe cmd env Unix.stdin cmd_out_wr - cmd_out_wr - in - Unix.close cmd_out_wr; - let rec process_cmd_out () = - let s = input_line ic in - if s = "```" || String.starts_with ~prefix:"#return code" s then - output_char oc '\\'; - let rec trail s i = - if i < 1 then String.length s - else if s.[i - 1] = ' ' then trail s (i - 1) - else i - in - output_substring oc s 0 (trail s (String.length s)); - output_char oc '\n'; - process_cmd_out () - in - let () = try process_cmd_out () with End_of_file -> close_in ic in - let return_code = - match Unix.waitpid [] pid with - | _, Unix.WEXITED n -> n - | _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n - in - if return_code <> 0 then - Printf.fprintf oc "#return code %d#\n" return_code) - file_tests.tests; - output_string oc file_tests.text_after; - flush oc - in - if reset then ( - let out = file ^ ".out" in - (try File.with_out_channel out run - with e -> - Sys.remove out; - raise e); - Sys.rename out file) - else run stdout - (**{1 Running}*) let run_file @@ -688,7 +533,7 @@ let run_file String.concat " " (List.filter (fun s -> s <> "") - [catala_exe; catala_opts; "-s " ^ scope; "Interpret"; file]) + [catala_exe; "Interpret"; file; catala_opts; "-s " ^ scope]) in Message.emit_debug "Running: %s" command; Sys.command command @@ -950,7 +795,7 @@ let driver | "runtest" -> ( match files_or_folders with | [f] -> - run_inline_tests ~reset:reset_test_outputs f catala_exe + Clerk_runtest.run_inline_tests ~reset:reset_test_outputs f catala_exe (List.filter (( <> ) "") (String.split_on_char ' ' catala_opts)); 0 | _ -> Message.raise_error "Please specify a single catala file to test") diff --git a/build_system/clerk_runtest.ml b/build_system/clerk_runtest.ml new file mode 100644 index 00000000..9c554113 --- /dev/null +++ b/build_system/clerk_runtest.ml @@ -0,0 +1,271 @@ +(* This file is part of the Catala build system, a specification language for + tax and social benefits computation rules. Copyright (C) 2022-2023 Inria, + contributors: Louis Gesbert + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Catala_utils + +type test = { + text_before : string; + (** Verbatim of everything from the last test end or beginning of file up + to the test output start *) + params : string list; + (** Catala command-line arguments for the test *) + (* Also contains test_output and return_code, but they are not relevant + for just running the test *) +} + +type file_tests = { + filename : string; + tests : test list; + text_after : string; (** Verbatim of everything following the last test *) +} + +let checkfile parents file = + let file = try Unix.realpath file with Unix.Unix_error _ -> file in + if List.mem file parents then + Message.raise_error "@[Cyclic file inclusion:@ %a@]" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf " %a@ " String.format "→") + Format.pp_print_string) + (List.rev (file :: parents)); + file :: parents, file + +let with_in_channel_safe parents file f = + try File.with_in_channel file f + with Sys_error err -> + Message.raise_error "Could not open file %S:@ %s@ %a" file err + (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf f -> + Format.fprintf ppf "included from %S" f)) + parents + +(* Matches both test starts and includes; discriminate by checking [Group.get g + 1], which will be defined only for includes (and equal to the included + file) *) +let test_scan_rex = + let open Re in + let inline_test_start_key = str "```catala-test-inline" in + let include_regexp = + (* TODO: we match on "Inclu*" which will work for now but may not scale to + new languages. The reasonable alternative would be to run the appropriate + lexer on all files, but it might not yet be worth the added complexity + (?) *) + seq + [ + char '>'; + rep1 blank; + str "Inclu"; + rep1 alpha; + rep blank; + char ':'; + rep blank; + group (rep1 notnl); + ] + in + compile + (seq [bol; alt [inline_test_start_key; include_regexp]; rep blank; eol]) + +let rec has_inline_tests ?(parents = []) (file : string) : bool = + let parents, file = checkfile parents file in + let rec aux ic = + match input_line ic with + | exception End_of_file -> false + | li -> ( + match Re.exec_opt test_scan_rex li with + | None -> aux ic + | Some gr -> ( + match Re.Group.get_opt gr 1 with + | None -> true + | Some incl -> + let incl_file = File.(Filename.dirname file / incl) in + aux ic + || + (close_in ic; + has_inline_tests ~parents incl_file))) + in + with_in_channel_safe parents file aux + +let has_inline_tests file = has_inline_tests file (* hide optional parameter *) + +let [@ocamlformat "disable"] rec scan_for_inline_tests + ?(parents=[]) (file : string) + : file_tests list = + let parents, file = checkfile parents file in + let read_file ic = + (* Matches something of the form: {v + ```catala-test-inline + $ catala Interpret -s A + ... output from catala ... + #return code 10# + ``` + v} *) + let test_content_rex = + Re.(compile @@ + seq + [ + seq [char '$'; rep space; str "catala"; group (rep1 notnl); + char '\n']; + group (non_greedy (rep any)); + seq [bol; str "```\n"]; + ]) + in + let file_str = really_input_string ic (in_channel_length ic) in + let rec scan incls acc pos_scan pos_block = + try + let scan_grp = Re.exec ~pos:pos_scan test_scan_rex file_str in + let pos = Re.Group.stop scan_grp 0 in + match Re.Group.get_opt scan_grp 1 with + | Some incl -> + let incl_file = File.(Filename.dirname file / incl) in + scan (incl_file::incls) acc (Re.Group.stop scan_grp 0) pos_block + | None -> + let test_contents = + try Re.exec ~pos test_content_rex file_str + with Not_found -> + let line = + String.fold_left + (fun n -> function '\n' -> n + 1 | _ -> n) + 1 + (String.sub file_str 0 pos) + in + Message.raise_error "Bad inline-test format at %s line %d" + file line + in + let params = + List.filter (( <> ) "") + (String.split_on_char ' ' (Re.Group.get test_contents 1)) + in + let out_start = Re.Group.start test_contents 2 in + let test = + { text_before = String.sub file_str pos_block (out_start - pos_block); + params } + in + let pos_next = Re.Group.stop test_contents 2 in + scan incls (test :: acc) pos_next pos_next + with Not_found -> ( + match acc with + | [] -> List.rev incls, [] + | tests -> + List.rev incls, + [{ + filename = file; + tests = List.rev tests; + text_after = + String.sub file_str pos_block + (String.length file_str - pos_block); + }]) + in + scan [] [] 0 0 + in + let incls, tests = with_in_channel_safe parents file read_file in + List.fold_left (fun tests incfile -> + List.rev_append (scan_for_inline_tests ~parents incfile) tests) + (List.rev tests) incls + |> List.rev + +(** Directly runs the test (not using ninja, this will be called by ninja rules + through the "clerk runtest" command) *) +let run_inline_tests + ~(reset : bool) + (file : string) + (catala_exe : string) + (catala_opts : string list) = + let _, file = checkfile [] file in + match scan_for_inline_tests file with + | [] -> Message.emit_warning "No inline tests found in %s" file + | file_tests -> + Message.emit_debug "@[Running tests:@ %a@]" + (Format.pp_print_list (fun ppf t -> + Format.fprintf ppf "- @[%s:@ %d tests@]" t.filename + (List.length t.tests))) + file_tests; + let run test oc = + List.iter + (fun test -> + output_string oc test.text_before; + let cmd_out_rd, cmd_out_wr = Unix.pipe () in + let ic = Unix.in_channel_of_descr cmd_out_rd in + let file_dir, file = Filename.dirname file, Filename.basename file in + let catala_exe = + (* If the exe name contains directories, make it absolute. Otherwise + don't modify it so that it can be looked up in PATH. *) + if String.contains catala_exe Filename.dir_sep.[0] then + Unix.realpath catala_exe + else catala_exe + in + let cmd = + Array.of_list ((catala_exe :: catala_opts) @ test.params @ [file]) + in + let env = + Unix.environment () + |> Array.to_seq + |> Seq.filter (fun s -> + not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s)) + |> Seq.cons "CATALA_OUT=-" + |> Seq.cons "CATALA_COLOR=never" + |> Seq.cons "CATALA_PLUGINS=" + |> Array.of_seq + in + let pid = + let cwd = Unix.getcwd () in + (* Catala depends on the CWD when printing relative file locations + in error messages. Here we are dealing with inline tests, and it + would be inconvenient for the file to contain its own location + relative to where the test was run from ; to avoid that, we + ensure to always run the catala exec from the directory where the + test file was found. *) + Unix.chdir file_dir; + Fun.protect ~finally:(fun () -> Unix.chdir cwd) + @@ fun () -> + Unix.create_process_env catala_exe cmd env Unix.stdin cmd_out_wr + cmd_out_wr + in + Unix.close cmd_out_wr; + let rec process_cmd_out () = + let s = input_line ic in + if s = "```" || String.starts_with ~prefix:"#return code" s then + output_char oc '\\'; + let rec trail s i = + if i < 1 then String.length s + else if s.[i - 1] = ' ' then trail s (i - 1) + else i + in + output_substring oc s 0 (trail s (String.length s)); + output_char oc '\n'; + process_cmd_out () + in + let () = try process_cmd_out () with End_of_file -> close_in ic in + let return_code = + match Unix.waitpid [] pid with + | _, Unix.WEXITED n -> n + | _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n + in + if return_code <> 0 then + Printf.fprintf oc "#return code %d#\n" return_code) + test.tests; + output_string oc test.text_after; + flush oc + in + List.iter + (fun test -> + if test.filename <> file then () + else if reset then ( + let out = test.filename ^ ".out" in + (try File.with_out_channel out (run test) + with e -> + Sys.remove out; + raise e); + Sys.rename out test.filename) + else run test stdout) + file_tests diff --git a/build_system/clerk_runtest.mli b/build_system/clerk_runtest.mli new file mode 100644 index 00000000..f80a9977 --- /dev/null +++ b/build_system/clerk_runtest.mli @@ -0,0 +1,31 @@ +(* This file is part of the Catala build system, a specification language for + tax and social benefits computation rules. Copyright (C) 2022-2023 Inria, + contributors: Louis Gesbert + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +(** This module contains specific commands used to detect and run inline tests + in Catala files. The functionality is built into the `clerk runtest` + subcommand, but is separate from the normal Clerk behaviour: Clerk drives + Ninja, which in turn might need to evaluate tests as part of some rules and + can run `clerk runtest` in a reentrant way. *) + +val has_inline_tests : string -> bool +(** Checks if the given named file contains inline tests (either directly or + through includes) *) + +val run_inline_tests : reset:bool -> string -> string -> string list -> unit +(** [run_inline_tests ~reset file catala_exe catala_opts] runs the tests in + Catala [file] using the given path to the Catala executable and the provided + options. Output is printed to [stdout] if [reset] is false, otherwise [file] + is replaced with the updated test results. *) diff --git a/build_system/dune b/build_system/dune index acd36da3..303a15a3 100644 --- a/build_system/dune +++ b/build_system/dune @@ -14,7 +14,7 @@ cmdliner re ocolor) - (modules clerk_driver)) + (modules clerk_runtest clerk_driver)) (rule (target custom_linking.sexp) diff --git a/compiler/catala_utils/map.ml b/compiler/catala_utils/map.ml index 64790791..2d56a8c2 100644 --- a/compiler/catala_utils/map.ml +++ b/compiler/catala_utils/map.ml @@ -29,6 +29,10 @@ end module type S = sig include Stdlib.Map.S + exception Not_found of key + (* Slightly more informative [Not_found] exception *) + + val find : key -> 'a t -> 'a val keys : 'a t -> key list val values : 'a t -> 'a list val of_list : (key * 'a) list -> 'a t @@ -70,6 +74,16 @@ end module Make (Ord : OrderedType) : S with type key = Ord.t = struct include Stdlib.Map.Make (Ord) + exception Not_found of key + + let () = + Printexc.register_printer + @@ function + | Not_found k -> + Some (Format.asprintf "key '%a' not found in map" Ord.format k) + | _ -> None + + let find k t = try find k t with Stdlib.Not_found -> raise (Not_found k) let keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev let values t = fold (fun _ v acc -> v :: acc) t [] |> List.rev let of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l diff --git a/compiler/catala_utils/uid.ml b/compiler/catala_utils/uid.ml index f6d89215..451b4db6 100644 --- a/compiler/catala_utils/uid.ml +++ b/compiler/catala_utils/uid.ml @@ -35,7 +35,6 @@ module type Id = sig val hash : t -> int module Set : Set.S with type elt = t - module SetLabels : MoreLabels.Set.S with type elt = t and type t = Set.t module Map : Map.S with type key = t end @@ -43,7 +42,7 @@ module Make (X : Info) () : Id with type info = X.info = struct module Ordering = struct type t = { id : int; info : X.info } - let compare (x : t) (y : t) : int = compare x.id y.id + let compare (x : t) (y : t) : int = Int.compare x.id y.id let equal x y = Int.equal x.id y.id let format ppf t = X.format ppf t.info end @@ -59,15 +58,14 @@ module Make (X : Info) () : Id with type info = X.info = struct { id = !counter; info } let get_info (uid : t) : X.info = uid.info - let format (fmt : Format.formatter) (x : t) : unit = X.format fmt x.info let hash (x : t) : int = x.id module Set = Set.Make (Ordering) module Map = Map.Make (Ordering) - module SetLabels = MoreLabels.Set.Make (Ordering) - module MapLabels = MoreLabels.Map.Make (Ordering) end +(* - Raw idents - *) + module MarkedString = struct type info = string Mark.pos @@ -78,3 +76,54 @@ module MarkedString = struct end module Gen () = Make (MarkedString) () + +(* - Modules, paths and qualified idents - *) + +module Module = struct + include String + + let to_string m = m + let format ppf m = Format.fprintf ppf "@{%s@}" m + let of_string m = m +end +(* TODO: should probably be turned into an uid once we implement module import + directives; that will incur an additional resolution work on all paths though + ([module Module = Gen ()]) *) + +module Path = struct + type t = Module.t list + + let format ppf p = + Format.pp_print_list + ~pp_sep:(fun _ () -> ()) + (fun ppf m -> Format.fprintf ppf "%a@{.@}" Module.format m) + ppf p + + let to_string p = String.concat "." p + let equal = List.equal String.equal + let compare = List.compare String.compare +end + +module QualifiedMarkedString = struct + type info = Path.t * MarkedString.info + + let to_string (p, i) = + Format.asprintf "%a%a" Path.format p MarkedString.format i + + let format fmt (p, i) = + Path.format fmt p; + MarkedString.format fmt i + + let equal (p1, i1) (p2, i2) = Path.equal p1 p2 && MarkedString.equal i1 i2 + + let compare (p1, i1) (p2, i2) = + match Path.compare p1 p2 with 0 -> MarkedString.compare i1 i2 | n -> n +end + +module Gen_qualified () = struct + include Make (QualifiedMarkedString) () + + let fresh path t = fresh (path, t) + let path t = fst (get_info t) + let get_info t = snd (get_info t) +end diff --git a/compiler/catala_utils/uid.mli b/compiler/catala_utils/uid.mli index deb198e2..ef59e552 100644 --- a/compiler/catala_utils/uid.mli +++ b/compiler/catala_utils/uid.mli @@ -50,7 +50,6 @@ module type Id = sig val hash : t -> int module Set : Set.S with type elt = t - module SetLabels : MoreLabels.Set.S with type elt = t and type t = Set.t module Map : Map.S with type key = t end @@ -61,3 +60,36 @@ module Make (X : Info) () : Id with type info = X.info module Gen () : Id with type info = MarkedString.info (** Shortcut for creating a kind of uids over marked strings *) + +(** {2 Handling of Uids with additional path information} *) + +module Module : sig + type t = private string (* TODO: this will become an uid at some point *) + + val to_string : t -> string + val format : Format.formatter -> t -> unit + val equal : t -> t -> bool + val compare : t -> t -> int + val of_string : string -> t + + module Set : Set.S with type elt = t + module Map : Map.S with type key = t +end + +module Path : sig + type t = Module.t list + + val to_string : t -> string + val format : Format.formatter -> t -> unit + val equal : t -> t -> bool + val compare : t -> t -> int +end + +(** Same as [Gen] but also registers path information *) +module Gen_qualified () : sig + include Id with type info = Path.t * MarkedString.info + + val fresh : Path.t -> MarkedString.info -> t + val path : t -> Path.t + val get_info : t -> MarkedString.info +end diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 14d7103d..106e668f 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -29,26 +29,27 @@ type scope_input_var_ctx = { scope_input_typ : naked_typ; } +type 'm scope_ref = + | Local_scope_ref of 'm Ast.expr Var.t + | External_scope_ref of ScopeName.t Mark.pos + type 'm scope_sig_ctx = { scope_sig_local_vars : scope_var_ctx list; (** List of scope variables *) - scope_sig_scope_var : 'm Ast.expr Var.t; (** Var representing the scope *) - scope_sig_input_var : 'm Ast.expr Var.t; - (** Var representing the scope input inside the scope func *) + scope_sig_scope_ref : 'm scope_ref; + (** Var or external representing the scope *) scope_sig_input_struct : StructName.t; (** Scope input *) scope_sig_output_struct : StructName.t; (** Scope output *) scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t; (** Mapping between the input scope variables and the input struct fields. *) - scope_sig_out_fields : StructField.t ScopeVar.Map.t; - (** Mapping between the output scope variables and the output struct - fields. TODO: could likely be removed now that we have it in the - program ctx *) } -type 'm scope_sigs_ctx = 'm scope_sig_ctx ScopeName.Map.t +type 'm scope_sigs_ctx = { + scope_sigs : 'm scope_sig_ctx ScopeName.Map.t; + scope_sigs_modules : 'm scope_sigs_ctx ModuleName.Map.t; +} type 'm ctx = { - structs : struct_ctx; - enums : enum_ctx; + decl_ctx : decl_ctx; scope_name : ScopeName.t option; scopes_parameters : 'm scope_sigs_ctx; toplevel_vars : ('m Ast.expr Var.t * naked_typ) TopdefName.Map.t; @@ -72,6 +73,14 @@ let pos_mark_mk (type a m) (e : (a, m) gexpr) : let pos_mark_as e = pos_mark (Mark.get e) in pos_mark, pos_mark_as +let module_scope_sig scope_sig_ctx scope = + let ssctx = + List.fold_left + (fun ssctx m -> ModuleName.Map.find m ssctx.scope_sigs_modules) + scope_sig_ctx (ScopeName.path scope) + in + ScopeName.Map.find scope ssctx.scope_sigs + let merge_defaults ~(is_func : bool) (caller : (dcalc, 'm) boxed_gexpr) @@ -203,14 +212,14 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : let m = Mark.get e in match Mark.remove e with | EMatch { e = e1; name; cases = e_cases } -> - let enum_sig = EnumName.Map.find name ctx.enums in + let enum_sig = EnumName.Map.find name ctx.decl_ctx.ctx_enums in let d_cases, remaining_e_cases = (* FIXME: these checks should probably be moved to a better place *) EnumConstructor.Map.fold (fun constructor _ (d_cases, e_cases) -> let case_e = try EnumConstructor.Map.find constructor e_cases - with Not_found -> + with EnumConstructor.Map.Not_found _ -> Message.raise_spanned_error (Expr.pos e) "The constructor %a of enum %a is missing from this pattern \ matching" @@ -230,10 +239,10 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : Format.fprintf fmt ", ")) remaining_e_cases; let e1 = translate_expr ctx e1 in - Expr.ematch e1 name d_cases m + Expr.ematch ~e:e1 ~name ~cases:d_cases m | EScopeCall { scope; args } -> let pos = Expr.mark_pos m in - let sc_sig = ScopeName.Map.find scope ctx.scopes_parameters in + let sc_sig = module_scope_sig ctx.scopes_parameters scope in let in_var_map = ScopeVar.Map.merge (fun var_name (str_field : scope_input_var_ctx option) expr -> @@ -280,12 +289,18 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : in_var_map StructField.Map.empty in let arg_struct = - Expr.estruct sc_sig.scope_sig_input_struct field_map (mark_tany m pos) + Expr.estruct ~name:sc_sig.scope_sig_input_struct ~fields:field_map + (mark_tany m pos) in let called_func = - tag_with_log_entry - (Expr.evar sc_sig.scope_sig_scope_var (mark_tany m pos)) - BeginCall + let m = mark_tany m pos in + let e = + match sc_sig.scope_sig_scope_ref with + | Local_scope_ref v -> Expr.evar v m + | External_scope_ref name -> + Expr.eexternal ~name:(Mark.map (fun s -> External_scope s) name) m + in + tag_with_log_entry e BeginCall [ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"] in let single_arg = @@ -332,62 +347,67 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : (* result_eta_expanded = { struct_output_function_field = lambda x -> log (struct_output.struct_output_function_field x) ... } *) let result_eta_expanded = - Expr.estruct sc_sig.scope_sig_output_struct - (StructField.Map.mapi - (fun field typ -> - let original_field_expr = - Expr.estructaccess - (Expr.make_var result_var - (Expr.with_ty m - (TStruct sc_sig.scope_sig_output_struct, Expr.pos e))) - field sc_sig.scope_sig_output_struct (Expr.with_ty m typ) - in - match Mark.remove typ with - | TArrow (ts_in, t_out) -> - (* Here the output scope struct field is a function so we - eta-expand it and insert logging instructions. Invariant: - works because there is no partial evaluation. *) - let params_vars = - ListLabels.mapi ts_in ~f:(fun i _ -> - Var.make ("param" ^ string_of_int i)) + Expr.estruct ~name:sc_sig.scope_sig_output_struct + ~fields: + (StructField.Map.mapi + (fun field typ -> + let original_field_expr = + Expr.estructaccess + ~e: + (Expr.make_var result_var + (Expr.with_ty m + (TStruct sc_sig.scope_sig_output_struct, Expr.pos e))) + ~field ~name:sc_sig.scope_sig_output_struct + (Expr.with_ty m typ) in - let f_markings = - [ScopeName.get_info scope; StructField.get_info field] - in - Expr.make_abs - (Array.of_list params_vars) - (tag_with_log_entry - (tag_with_log_entry - (Expr.eapp - (tag_with_log_entry original_field_expr BeginCall - f_markings) - (ListLabels.mapi (List.combine params_vars ts_in) - ~f:(fun i (param_var, t_in) -> - tag_with_log_entry - (Expr.make_var param_var (Expr.with_ty m t_in)) - (VarDef - { - log_typ = Mark.remove t_in; - log_io_output = false; - log_io_input = OnlyInput; - }) - (f_markings - @ [ - Mark.add (Expr.pos e) - ("input" ^ string_of_int i); - ]))) - (Expr.with_ty m t_out)) - (VarDef - { - log_typ = Mark.remove t_out; - log_io_output = true; - log_io_input = NoInput; - }) - (f_markings @ [Mark.add (Expr.pos e) "output"])) - EndCall f_markings) - ts_in (Expr.pos e) - | _ -> original_field_expr) - (StructName.Map.find sc_sig.scope_sig_output_struct ctx.structs)) + match Mark.remove typ with + | TArrow (ts_in, t_out) -> + (* Here the output scope struct field is a function so we + eta-expand it and insert logging instructions. Invariant: + works because there is no partial evaluation. *) + let params_vars = + ListLabels.mapi ts_in ~f:(fun i _ -> + Var.make ("param" ^ string_of_int i)) + in + let f_markings = + [ScopeName.get_info scope; StructField.get_info field] + in + Expr.make_abs + (Array.of_list params_vars) + (tag_with_log_entry + (tag_with_log_entry + (Expr.eapp + (tag_with_log_entry original_field_expr BeginCall + f_markings) + (ListLabels.mapi (List.combine params_vars ts_in) + ~f:(fun i (param_var, t_in) -> + tag_with_log_entry + (Expr.make_var param_var + (Expr.with_ty m t_in)) + (VarDef + { + log_typ = Mark.remove t_in; + log_io_output = false; + log_io_input = OnlyInput; + }) + (f_markings + @ [ + Mark.add (Expr.pos e) + ("input" ^ string_of_int i); + ]))) + (Expr.with_ty m t_out)) + (VarDef + { + log_typ = Mark.remove t_out; + log_io_output = true; + log_io_input = NoInput; + }) + (f_markings @ [Mark.add (Expr.pos e) "output"])) + EndCall f_markings) + ts_in (Expr.pos e) + | _ -> original_field_expr) + (StructName.Map.find sc_sig.scope_sig_output_struct + ctx.decl_ctx.ctx_structs)) (Expr.with_ty m (TStruct sc_sig.scope_sig_output_struct, Expr.pos e)) in (* Here we have to go through an if statement that records a decision being @@ -439,10 +459,10 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : match ctx.scope_name, Mark.remove f with | Some sname, ELocation loc -> ( match loc with - | ScopelangScopeVar (v, _) -> + | ScopelangScopeVar { name = v, _; _ } -> [ScopeName.get_info sname; ScopeVar.get_info v] - | SubScopeVar (s, _, (v, _)) -> - [ScopeName.get_info s; ScopeVar.get_info v] + | SubScopeVar { scope; var = v, _; _ } -> + [ScopeName.get_info scope; ScopeVar.get_info v] | ToplevelVar _ -> []) | _ -> [] in @@ -453,8 +473,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : in let new_args = List.map (translate_expr ctx) args in let input_typs, output_typ = - (* NOTE: this is a temporary solution, it works because it's assume that - all function calls are from scope variable. However, this will change + (* NOTE: this is a temporary solution, it works because it's assumed that + all function calls are from scope variables. However, this will change -- for more information see https://github.com/CatalaLang/catala/pull/280#discussion_r898851693. *) let retrieve_in_and_out_typ_or_any var vars = @@ -465,15 +485,18 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : | _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny in match Mark.remove f with - | ELocation (ScopelangScopeVar var) -> + | ELocation (ScopelangScopeVar { name = var }) -> retrieve_in_and_out_typ_or_any var ctx.scope_vars - | ELocation (SubScopeVar (_, sname, var)) -> + | ELocation (SubScopeVar { alias; var; _ }) -> ctx.subscope_vars - |> SubScopeName.Map.find (Mark.remove sname) + |> SubScopeName.Map.find (Mark.remove alias) |> retrieve_in_and_out_typ_or_any var - | ELocation (ToplevelVar tvar) -> ( - let _, typ = TopdefName.Map.find (Mark.remove tvar) ctx.toplevel_vars in - match typ with + | ELocation (ToplevelVar { name }) -> ( + let decl_ctx = + Program.module_ctx ctx.decl_ctx (TopdefName.path (Mark.remove name)) + in + let typ = TopdefName.Map.find (Mark.remove name) decl_ctx.ctx_topdefs in + match Mark.remove typ with | TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout | _ -> Message.raise_spanned_error (Expr.pos e) @@ -522,17 +545,17 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : Expr.edefault (List.map (translate_expr ctx) excepts) (translate_expr ctx just) (translate_expr ctx cons) m - | ELocation (ScopelangScopeVar a) -> + | ELocation (ScopelangScopeVar { name = a }) -> let v, _, _ = ScopeVar.Map.find (Mark.remove a) ctx.scope_vars in Expr.evar v m - | ELocation (SubScopeVar (_, s, a)) -> ( + | ELocation (SubScopeVar { alias = s; var = a; _ }) -> ( try let v, _, _ = ScopeVar.Map.find (Mark.remove a) (SubScopeName.Map.find (Mark.remove s) ctx.subscope_vars) in Expr.evar v m - with Not_found -> + with ScopeVar.Map.Not_found _ | SubScopeName.Map.Not_found _ -> Message.raise_multispanned_error [ Some "Incriminated variable usage:", Expr.pos e; @@ -545,15 +568,18 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) : %a's results. Maybe you forgot to qualify it as an output?" SubScopeName.format (Mark.remove s) ScopeVar.format (Mark.remove a) SubScopeName.format (Mark.remove s)) - | ELocation (ToplevelVar v) -> - let v, _ = TopdefName.Map.find (Mark.remove v) ctx.toplevel_vars in - Expr.evar v m + | ELocation (ToplevelVar { name }) -> + let path = TopdefName.path (Mark.remove name) in + if path = [] then + let v, _ = TopdefName.Map.find (Mark.remove name) ctx.toplevel_vars in + Expr.evar v m + else Expr.eexternal ~name:(Mark.map (fun n -> External_value n) name) m | EOp { op = Add_dat_dur _; tys } -> Expr.eop (Add_dat_dur ctx.date_rounding) tys m | EOp { op; tys } -> Expr.eop (Operator.translate op) tys m - | ( EVar _ | EAbs _ | ELit _ | EExternal _ | EStruct _ | EStructAccess _ - | ETuple _ | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ - | EArray _ | EIfThenElse _ ) as e -> + | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _ + | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _ + | EIfThenElse _ ) as e -> Expr.map ~f:(translate_expr ctx) (e, m) (** The result of a rule translation is a list of assignment, with variables and @@ -569,7 +595,7 @@ let translate_rule 'm Ast.expr scope_body_expr Bindlib.box) * 'm ctx = match rule with - | Definition ((ScopelangScopeVar a, var_def_pos), tau, a_io, e) -> + | Definition ((ScopelangScopeVar { name = a }, var_def_pos), tau, a_io, e) -> let pos_mark, pos_mark_as = pos_mark_mk e in let a_name = ScopeVar.get_info (Mark.remove a) in let a_var = Var.make (Mark.remove a_name) in @@ -615,7 +641,7 @@ let translate_rule ctx.scope_vars; } ) | Definition - ( (SubScopeVar (_subs_name, subs_index, subs_var), var_def_pos), + ( (SubScopeVar { alias = subs_index; var = subs_var; _ }, var_def_pos), tau, a_io, e ) -> @@ -682,7 +708,11 @@ let translate_rule could be made more specific to avoid this case, but the added complexity didn't seem worth it *) | Call (subname, subindex, m) -> - let subscope_sig = ScopeName.Map.find subname ctx.scopes_parameters in + let subscope_sig = module_scope_sig ctx.scopes_parameters subname in + let scope_sig_decl = + ScopeName.Map.find subname + (Program.module_ctx ctx.decl_ctx (ScopeName.path subname)).ctx_scopes + in let all_subscope_vars = subscope_sig.scope_sig_local_vars in let all_subscope_input_vars = List.filter @@ -698,17 +728,23 @@ let translate_rule Mark.remove var_ctx.scope_var_io.Desugared.Ast.io_output) all_subscope_vars in - let scope_dcalc_var = subscope_sig.scope_sig_scope_var in + let pos_call = Mark.get (SubScopeName.get_info subindex) in + let scope_dcalc_ref = + let m = mark_tany m pos_call in + match subscope_sig.scope_sig_scope_ref with + | Local_scope_ref var -> Expr.make_var var m + | External_scope_ref name -> + Expr.eexternal ~name:(Mark.map (fun n -> External_scope n) name) m + in let called_scope_input_struct = subscope_sig.scope_sig_input_struct in let called_scope_return_struct = subscope_sig.scope_sig_output_struct in let subscope_vars_defined = try SubScopeName.Map.find subindex ctx.subscope_vars - with Not_found -> ScopeVar.Map.empty + with SubScopeName.Map.Not_found _ -> ScopeVar.Map.empty in let subscope_var_not_yet_defined subvar = not (ScopeVar.Map.mem subvar subscope_vars_defined) in - let pos_call = Mark.get (SubScopeName.get_info subindex) in let subscope_args = List.fold_left (fun acc (subvar : scope_var_ctx) -> @@ -734,7 +770,7 @@ let translate_rule StructField.Map.empty all_subscope_input_vars in let subscope_struct_arg = - Expr.estruct called_scope_input_struct subscope_args + Expr.estruct ~name:called_scope_input_struct ~fields:subscope_args (mark_tany m pos_call) in let all_subscope_output_vars_dcalc = @@ -750,9 +786,7 @@ let translate_rule all_subscope_output_vars in let subscope_func = - tag_with_log_entry - (Expr.make_var scope_dcalc_var (mark_tany m pos_call)) - BeginCall + tag_with_log_entry scope_dcalc_ref BeginCall [ sigma_name, pos_sigma; SubScopeName.get_info subindex; @@ -790,7 +824,7 @@ let translate_rule (fun (var_ctx, v) next -> let field = ScopeVar.Map.find var_ctx.scope_var_name - subscope_sig.scope_sig_out_fields + scope_sig_decl.out_struct_fields in Bindlib.box_apply2 (fun next r -> @@ -849,6 +883,7 @@ let translate_rule let translate_rules (ctx : 'm ctx) + (scope_name : ScopeName.t) (rules : 'm Scopelang.Ast.rule list) ((sigma_name, pos_sigma) : Uid.MarkedString.info) (mark : 'm mark) @@ -864,17 +899,21 @@ let translate_rules ((fun next -> next), ctx) rules in + let scope_sig_decl = ScopeName.Map.find scope_name ctx.decl_ctx.ctx_scopes in let return_exp = - Expr.estruct scope_sig.scope_sig_output_struct - (ScopeVar.Map.fold - (fun var (dcalc_var, _, io) acc -> - if Mark.remove io.Desugared.Ast.io_output then - let field = ScopeVar.Map.find var scope_sig.scope_sig_out_fields in - StructField.Map.add field - (Expr.make_var dcalc_var (mark_tany mark pos_sigma)) - acc - else acc) - new_ctx.scope_vars StructField.Map.empty) + Expr.estruct ~name:scope_sig.scope_sig_output_struct + ~fields: + (ScopeVar.Map.fold + (fun var (dcalc_var, _, io) acc -> + if Mark.remove io.Desugared.Ast.io_output then + let field = + ScopeVar.Map.find var scope_sig_decl.out_struct_fields + in + StructField.Map.add field + (Expr.make_var dcalc_var (mark_tany mark pos_sigma)) + acc + else acc) + new_ctx.scope_vars StructField.Map.empty) (mark_tany mark pos_sigma) in ( scope_lets @@ -883,6 +922,8 @@ let translate_rules (Expr.Box.lift return_exp)), new_ctx ) +(* From a scope declaration and definitions, create the corresponding scope body + wrapped in the appropriate call convention. *) let translate_scope_decl (ctx : 'm ctx) (scope_name : ScopeName.t) @@ -890,7 +931,7 @@ let translate_scope_decl 'm Ast.expr scope_body Bindlib.box * struct_ctx = let sigma_info = ScopeName.get_info sigma.scope_decl_name in let scope_sig = - ScopeName.Map.find sigma.scope_decl_name ctx.scopes_parameters + ScopeName.Map.find sigma.scope_decl_name ctx.scopes_parameters.scope_sigs in let scope_variables = scope_sig.scope_sig_local_vars in let ctx = { ctx with scope_name = Some scope_name } in @@ -926,12 +967,26 @@ let translate_scope_decl | None -> AbortOnRound in let ctx = { ctx with date_rounding } in - let scope_input_var = scope_sig.scope_sig_input_var in + let scope_input_var = + Var.make (Mark.remove (ScopeName.get_info scope_name) ^ "_in") + in let scope_input_struct_name = scope_sig.scope_sig_input_struct in let scope_return_struct_name = scope_sig.scope_sig_output_struct in let pos_sigma = Mark.get sigma_info in + let scope_mark = + (* Find a witness of a mark in the definitions *) + match sigma.scope_decl_rules with + | [] -> + (* 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 + or not ? *) + Message.raise_spanned_error pos_sigma "Scope %a has no content" + ScopeName.format scope_name + | (Definition (_, _, _, (_, m)) | Assertion (_, m) | Call (_, _, m)) :: _ -> + m + in let rules_with_return_expr, ctx = - translate_rules ctx sigma.scope_decl_rules sigma_info sigma.scope_mark + translate_rules ctx scope_name sigma.scope_decl_rules sigma_info scope_mark scope_sig in let scope_variables = @@ -982,14 +1037,24 @@ let translate_scope_decl scope_let_expr = ( EStructAccess { name = scope_input_struct_name; e = r; field }, - mark_tany sigma.scope_mark pos_sigma ); + mark_tany scope_mark pos_sigma ); }) (Bindlib.bind_var v next) (Expr.Box.lift - (Expr.make_var scope_input_var - (mark_tany sigma.scope_mark pos_sigma)))) + (Expr.make_var scope_input_var (mark_tany scope_mark pos_sigma)))) scope_input_variables next in + let scope_body = + Bindlib.box_apply + (fun scope_body_expr -> + { + scope_body_expr; + scope_body_input_struct = scope_input_struct_name; + scope_body_output_struct = scope_return_struct_name; + }) + (Bindlib.bind_var scope_input_var + (input_destructurings rules_with_return_expr)) + in let field_map = List.fold_left (fun acc (var_ctx, _) -> @@ -1003,16 +1068,7 @@ let translate_scope_decl let new_struct_ctx = StructName.Map.singleton scope_input_struct_name field_map in - ( Bindlib.box_apply - (fun scope_body_expr -> - { - scope_body_expr; - scope_body_input_struct = scope_input_struct_name; - scope_body_output_struct = scope_return_struct_name; - }) - (Bindlib.bind_var scope_input_var - (input_destructurings rules_with_return_expr)), - new_struct_ctx ) + scope_body, new_struct_ctx let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = let defs_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in @@ -1022,55 +1078,111 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = in let decl_ctx = prgm.program_ctx in let sctx : 'm scope_sigs_ctx = - ScopeName.Map.mapi - (fun scope_name scope -> - let scope_dvar = - Var.make - (Mark.remove - (ScopeName.get_info scope.Scopelang.Ast.scope_decl_name)) - in - let scope_return = ScopeName.Map.find scope_name decl_ctx.ctx_scopes in - let scope_input_var = - Var.make (Mark.remove (ScopeName.get_info scope_name) ^ "_in") - in - let scope_input_struct_name = - StructName.fresh - (Mark.map (fun s -> s ^ "_in") (ScopeName.get_info scope_name)) - in - let scope_sig_in_fields = - ScopeVar.Map.filter_map - (fun dvar (typ, vis) -> - match Mark.remove vis.Desugared.Ast.io_input with - | NoInput -> None - | OnlyInput | Reentrant -> - let info = ScopeVar.get_info dvar in - let s = Mark.remove info ^ "_in" in - Some - { - scope_input_name = StructField.fresh (s, Mark.get info); - scope_input_io = vis.Desugared.Ast.io_input; - scope_input_typ = Mark.remove typ; - }) - scope.scope_sig - in - { - scope_sig_local_vars = - List.map - (fun (scope_var, (tau, vis)) -> + let process_scope_sig scope_name scope = + let scope_path = ScopeName.path scope_name in + let scope_ref = + if scope_path = [] then + let v = Var.make (Mark.remove (ScopeName.get_info scope_name)) in + Local_scope_ref v + else + External_scope_ref + (Mark.copy (ScopeName.get_info scope_name) scope_name) + in + let scope_info = + try + ScopeName.Map.find scope_name + (Program.module_ctx decl_ctx scope_path).ctx_scopes + with ScopeName.Map.Not_found _ -> + Message.raise_spanned_error + (Mark.get (ScopeName.get_info scope_name)) + "Could not find scope %a" ScopeName.format scope_name + in + let scope_sig_in_fields = + (* Output fields have already been generated and added to the program + ctx at this point, because they are visible to the user (manipulated + as the return type of ScopeCalls) ; but input fields are used purely + internally and need to be created here to implement the call + convention for scopes. *) + ScopeVar.Map.filter_map + (fun dvar (typ, vis) -> + match Mark.remove vis.Desugared.Ast.io_input with + | NoInput -> None + | OnlyInput | Reentrant -> + let info = ScopeVar.get_info dvar in + let s = Mark.remove info ^ "_in" in + Some { - scope_var_name = scope_var; - scope_var_typ = Mark.remove tau; - scope_var_io = vis; + scope_input_name = StructField.fresh (s, Mark.get info); + scope_input_io = vis.Desugared.Ast.io_input; + scope_input_typ = Mark.remove typ; }) - (ScopeVar.Map.bindings scope.scope_sig); - scope_sig_scope_var = scope_dvar; - scope_sig_input_var = scope_input_var; - scope_sig_input_struct = scope_input_struct_name; - scope_sig_output_struct = scope_return.out_struct_name; - scope_sig_in_fields; - scope_sig_out_fields = scope_return.out_struct_fields; - }) - prgm.Scopelang.Ast.program_scopes + scope.Scopelang.Ast.scope_sig + in + { + scope_sig_local_vars = + List.map + (fun (scope_var, (tau, vis)) -> + { + scope_var_name = scope_var; + scope_var_typ = Mark.remove tau; + scope_var_io = vis; + }) + (ScopeVar.Map.bindings scope.scope_sig); + scope_sig_scope_ref = scope_ref; + scope_sig_input_struct = scope_info.in_struct_name; + scope_sig_output_struct = scope_info.out_struct_name; + scope_sig_in_fields; + } + in + let rec process_modules prg = + { + scope_sigs = + ScopeName.Map.mapi + (fun scope_name (scope_decl, _) -> + process_scope_sig scope_name scope_decl) + prg.Scopelang.Ast.program_scopes; + scope_sigs_modules = + ModuleName.Map.map process_modules prg.Scopelang.Ast.program_modules; + } + in + { + scope_sigs = + ScopeName.Map.mapi + (fun scope_name (scope_decl, _) -> + process_scope_sig scope_name scope_decl) + prgm.Scopelang.Ast.program_scopes; + scope_sigs_modules = + ModuleName.Map.map process_modules prgm.Scopelang.Ast.program_modules; + } + in + let rec gather_module_in_structs acc sctx = + (* Expose all added in_structs from submodules at toplevel *) + ModuleName.Map.fold + (fun _ scope_sigs acc -> + let acc = gather_module_in_structs acc scope_sigs.scope_sigs_modules in + ScopeName.Map.fold + (fun _ scope_sig_ctx acc -> + let fields = + ScopeVar.Map.fold + (fun _ sivc acc -> + let pos = + Mark.get (StructField.get_info sivc.scope_input_name) + in + StructField.Map.add sivc.scope_input_name + (sivc.scope_input_typ, pos) + acc) + scope_sig_ctx.scope_sig_in_fields StructField.Map.empty + in + StructName.Map.add scope_sig_ctx.scope_sig_input_struct fields acc) + scope_sigs.scope_sigs acc) + sctx acc + in + let decl_ctx = + { + decl_ctx with + ctx_structs = + gather_module_in_structs decl_ctx.ctx_structs sctx.scope_sigs_modules; + } in let top_ctx = let toplevel_vars = @@ -1080,8 +1192,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = prgm.Scopelang.Ast.program_topdefs in { - structs = decl_ctx.ctx_structs; - enums = decl_ctx.ctx_enums; + decl_ctx; scope_name = None; scopes_parameters = sctx; scope_vars = ScopeVar.Map.empty; @@ -1109,16 +1220,28 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = | Scopelang.Dependency.Scope scope_name -> let scope = ScopeName.Map.find scope_name prgm.program_scopes in let scope_body, scope_in_struct = - translate_scope_decl ctx scope_name scope + translate_scope_decl ctx scope_name (Mark.remove scope) + in + let scope_var = + match + (ScopeName.Map.find scope_name sctx.scope_sigs) + .scope_sig_scope_ref + with + | Local_scope_ref v -> v + | External_scope_ref _ -> assert false in ( { ctx with - structs = - StructName.Map.union - (fun _ _ -> assert false) - ctx.structs scope_in_struct; + decl_ctx = + { + ctx.decl_ctx with + ctx_structs = + StructName.Map.union + (fun _ _ -> assert false) + ctx.decl_ctx.ctx_structs scope_in_struct; + }; }, - (ScopeName.Map.find scope_name sctx).scope_sig_scope_var, + scope_var, Bindlib.box_apply (fun body -> ScopeDef (scope_name, body)) scope_body ) @@ -1131,7 +1254,4 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = ctx ) in let items, ctx = translate_defs top_ctx defs_ordering in - { - code_items = Bindlib.unbox items; - decl_ctx = { decl_ctx with ctx_structs = ctx.structs }; - } + { code_items = Bindlib.unbox items; decl_ctx = ctx.decl_ctx } diff --git a/compiler/desugared/ast.ml b/compiler/desugared/ast.ml index 3738b35c..1ef669eb 100644 --- a/compiler/desugared/ast.ml +++ b/compiler/desugared/ast.ml @@ -227,6 +227,7 @@ type program = { program_scopes : scope ScopeName.Map.t; program_topdefs : (expr option * typ) TopdefName.Map.t; program_ctx : decl_ctx; + program_modules : program ModuleName.Map.t; } let rec locations_used e : LocationSet.t = @@ -247,11 +248,12 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDef.Map.t = (fun (loc, loc_pos) acc -> let usage = match loc with - | DesugaredScopeVar (v, st) -> Some (ScopeDef.Var (Mark.remove v, st)) - | SubScopeVar (_, sub_index, sub_var) -> + | DesugaredScopeVar { name; state } -> + Some (ScopeDef.Var (Mark.remove name, state)) + | SubScopeVar { alias; var; _ } -> Some (ScopeDef.SubScopeVar - (Mark.remove sub_index, Mark.remove sub_var, Mark.get sub_index)) + (Mark.remove alias, Mark.remove var, Mark.get alias)) | ToplevelVar _ -> None in match usage with diff --git a/compiler/desugared/ast.mli b/compiler/desugared/ast.mli index 6954fba0..bde89f85 100644 --- a/compiler/desugared/ast.mli +++ b/compiler/desugared/ast.mli @@ -116,6 +116,7 @@ type program = { program_scopes : scope ScopeName.Map.t; program_topdefs : (expr option * typ) TopdefName.Map.t; program_ctx : decl_ctx; + program_modules : program ModuleName.Map.t; } (** {1 Helpers} *) diff --git a/compiler/desugared/dependency.ml b/compiler/desugared/dependency.ml index 64755a52..6cc72798 100644 --- a/compiler/desugared/dependency.ml +++ b/compiler/desugared/dependency.ml @@ -261,9 +261,10 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = (fun used_var g -> let edge_from = match Mark.remove used_var with - | DesugaredScopeVar (v, s) -> Some (Vertex.Var (Mark.remove v, s)) - | SubScopeVar (_, subscope_name, _) -> - Some (Vertex.SubScope (Mark.remove subscope_name)) + | DesugaredScopeVar { name; state } -> + Some (Vertex.Var (Mark.remove name, state)) + | SubScopeVar { alias; _ } -> + Some (Vertex.SubScope (Mark.remove alias)) | ToplevelVar _ -> None (* we don't add this dependency because toplevel definitions are outside the scope *) diff --git a/compiler/desugared/disambiguate.ml b/compiler/desugared/disambiguate.ml index 9de4f466..1d70d1ad 100644 --- a/compiler/desugared/disambiguate.ml +++ b/compiler/desugared/disambiguate.ml @@ -62,11 +62,42 @@ let scope ctx env scope = { scope with scope_defs; scope_assertions } let program prg = + (* Caution: this environment building code is very similar to that in + scopelang/ast.ml. Any edits should probably be reflected. *) + let base_typing_env prg = + let env = Typing.Env.empty prg.program_ctx in + let env = + TopdefName.Map.fold + (fun name (_e, ty) env -> Typing.Env.add_toplevel_var name ty env) + prg.program_topdefs env + in + let env = + ScopeName.Map.fold + (fun scope_name scope env -> + let vars = + ScopeDef.Map.fold + (fun var def vars -> + match var with + | Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars + | SubScopeVar _ -> vars) + scope.scope_defs ScopeVar.Map.empty + in + Typing.Env.add_scope scope_name ~vars env) + prg.program_scopes env + in + env + in + let rec build_typing_env prg = + ModuleName.Map.fold + (fun modname prg -> + Typing.Env.add_module modname ~module_env:(build_typing_env prg)) + prg.program_modules (base_typing_env prg) + in let env = - TopdefName.Map.fold - (fun name (_e, ty) env -> Typing.Env.add_toplevel_var name ty env) - prg.program_topdefs - (Typing.Env.empty prg.program_ctx) + ModuleName.Map.fold + (fun modname prg -> + Typing.Env.add_module modname ~module_env:(build_typing_env prg)) + prg.program_modules (base_typing_env prg) in let program_topdefs = TopdefName.Map.map @@ -76,20 +107,6 @@ let program prg = | None, ty -> None, ty) prg.program_topdefs in - let env = - ScopeName.Map.fold - (fun scope_name scope env -> - let vars = - ScopeDef.Map.fold - (fun var def vars -> - match var with - | Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars - | SubScopeVar _ -> vars) - scope.scope_defs ScopeVar.Map.empty - in - Typing.Env.add_scope scope_name ~vars env) - prg.program_scopes env - in let program_scopes = ScopeName.Map.map (scope prg.program_ctx env) prg.program_scopes in diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index eab2d0a5..d62d2eb7 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -34,7 +34,7 @@ module Runtime = Runtime_ocaml.Runtime the operator suffixes for explicit typing. See {!modules: Shared_ast.Operator} for detail. *) -let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed = +let translate_binop : S.binop -> Pos.t -> Ast.expr boxed = fun op pos -> let op_expr op tys = Expr.eop op (List.map (Mark.add pos) tys) (Untyped { pos }) @@ -104,7 +104,7 @@ let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed = | S.Neq -> assert false (* desugared already *) | S.Concat -> op_expr Concat [TArray (TAny, pos); TArray (TAny, pos)] -let translate_unop (op : Surface.Ast.unop) pos : Ast.expr boxed = +let translate_unop (op : S.unop) pos : Ast.expr boxed = let op_expr op ty = Expr.eop op [Mark.add pos ty] (Untyped { pos }) in match op with | S.Not -> op_expr Not (TLit TBool) @@ -134,12 +134,12 @@ let raise_error_cons_not_found "The name of this constructor has not been defined before@ (it's probably \ a typographical error)." -let disambiguate_constructor +let rec disambiguate_constructor (ctxt : Name_resolution.context) - (constructor : (S.path * S.uident Mark.pos) Mark.pos list) + (constructor0 : (S.path * S.uident Mark.pos) Mark.pos list) (pos : Pos.t) : EnumName.t * EnumConstructor.t = let path, constructor = - match constructor with + match constructor0 with | [c] -> Mark.remove c | _ -> Message.raise_spanned_error pos @@ -147,7 +147,7 @@ let disambiguate_constructor in let possible_c_uids = try Ident.Map.find (Mark.remove constructor) ctxt.constructor_idmap - with Not_found -> raise_error_cons_not_found ctxt constructor + with Ident.Map.Not_found _ -> raise_error_cons_not_found ctxt constructor in match path with | [] -> @@ -160,19 +160,25 @@ let disambiguate_constructor possible_c_uids; EnumName.Map.choose possible_c_uids | [enum] -> ( + (* The path is fully qualified *) + let e_uid = Name_resolution.get_enum ctxt enum in try - (* The path is fully qualified *) - let e_uid = Name_resolution.get_enum ctxt enum in - try - let c_uid = EnumName.Map.find e_uid possible_c_uids in - e_uid, c_uid - with Not_found -> - Message.raise_spanned_error pos "Enum %s does not contain case %s" - (Mark.remove enum) (Mark.remove constructor) - with Not_found -> - Message.raise_spanned_error (Mark.get enum) - "Enum %s has not been defined before" (Mark.remove enum)) - | _ -> Message.raise_spanned_error pos "Qualified paths are not supported yet" + let c_uid = EnumName.Map.find e_uid possible_c_uids in + e_uid, c_uid + with EnumName.Map.Not_found _ -> + Message.raise_spanned_error pos "Enum %s does not contain case %s" + (Mark.remove enum) (Mark.remove constructor)) + | (modname, mpos) :: path -> ( + let modname = ModuleName.of_string modname in + match ModuleName.Map.find_opt modname ctxt.modules with + | None -> + Message.raise_spanned_error mpos "Module \"%a\" not found" + ModuleName.format modname + | Some ctxt -> + let constructor = + List.map (Mark.map (fun (_, c) -> path, c)) constructor0 + in + disambiguate_constructor ctxt constructor pos) let int100 = Runtime.integer_of_int 100 let rat100 = Runtime.decimal_of_integer int100 @@ -204,19 +210,22 @@ let rec translate_expr (scope : ScopeName.t option) (inside_definition_of : Ast.ScopeDef.t Mark.pos option) (ctxt : Name_resolution.context) - (expr : Surface.Ast.expression) : Ast.expr boxed = + (local_vars : Ast.expr Var.t Ident.Map.t) + (expr : S.expression) : Ast.expr boxed = let scope_vars = match scope with | None -> Ident.Map.empty | Some s -> (ScopeName.Map.find s ctxt.scopes).var_idmap in - let rec_helper = translate_expr scope inside_definition_of ctxt in + let rec_helper ?(local_vars = local_vars) e = + translate_expr scope inside_definition_of ctxt local_vars e + in let pos = Mark.get expr in let emark = Untyped { pos } in match Mark.remove expr with | Paren e -> rec_helper e | Binop - ( (Surface.Ast.And, _pos_op), + ( (S.And, _pos_op), ( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)), _pos_e1 ), e2 ) -> @@ -234,16 +243,15 @@ let rec translate_expr (Expr.elit (LBool false) emark) [tau] pos else - let ctxt, binding_var = - Name_resolution.add_def_local_var ctxt (Mark.remove binding) + let binding_var = Var.make (Mark.remove binding) in + let local_vars = + Ident.Map.add (Mark.remove binding) binding_var local_vars in - let e2 = translate_expr scope inside_definition_of ctxt e2 in + let e2 = rec_helper ~local_vars e2 in Expr.make_abs [| binding_var |] e2 [tau] pos) (EnumName.Map.find enum_uid ctxt.enums) in - Expr.ematch - (translate_expr scope inside_definition_of ctxt e1_sub) - enum_uid cases emark + Expr.ematch ~e:(rec_helper e1_sub) ~name:enum_uid ~cases emark | Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) -> check_formula op e1; check_formula op e2; @@ -311,7 +319,7 @@ let rec translate_expr | Ident ([], (x, pos)) -> ( (* first we check whether this is a local var, then we resort to scope-wide variables, then global variables *) - match Ident.Map.find_opt x ctxt.local_var_idmap with + match Ident.Map.find_opt x local_vars with | Some uid -> Expr.make_var uid emark (* the whole box thing is to accomodate for this case *) @@ -343,20 +351,21 @@ let rec translate_expr else (* Tricky: we have to retrieve in the list the previous state with respect to the state that we are defining. *) - let correct_state = ref None in - ignore - (List.fold_left - (fun previous_state state -> - if StateName.equal inside_def_state state then - correct_state := previous_state; - Some state) - None states); - !correct_state) + let rec find_prev_state = function + | [] -> None + | st0 :: st1 :: _ when StateName.equal inside_def_state st1 + -> + Some st0 + | _ :: states -> find_prev_state states + in + find_prev_state states) | _ -> (* we take the last state in the chain *) Some (List.hd (List.rev states))) in - Expr.elocation (DesugaredScopeVar ((uid, pos), x_state)) emark + Expr.elocation + (DesugaredScopeVar { name = uid, pos; state = x_state }) + emark | Some (SubScope _) (* Note: allowing access to a global variable with the same name as a subscope is disputable, but I see no good reason to forbid it either *) @@ -364,14 +373,20 @@ let rec translate_expr match Ident.Map.find_opt x ctxt.topdefs with | Some v -> Expr.elocation - (ToplevelVar (v, Mark.get (TopdefName.get_info v))) + (ToplevelVar { name = v, Mark.get (TopdefName.get_info v) }) emark | None -> Name_resolution.raise_unknown_identifier "for a local, scope-wide or global variable" (x, pos)))) - | Surface.Ast.Ident (path, x) -> - let path = List.map Mark.remove path in - Expr.eexternal (path, Mark.remove x) emark + | Ident (path, name) -> ( + let ctxt = Name_resolution.module_ctx ctxt path in + match Ident.Map.find_opt (Mark.remove name) ctxt.topdefs with + | Some v -> + Expr.elocation + (ToplevelVar { name = v, Mark.get (TopdefName.get_info v) }) + emark + | None -> + Name_resolution.raise_unknown_identifier "for an external variable" name) | Dotted (e, ((path, x), _ppos)) -> ( match path, Mark.remove e with | [], Ident ([], (y, _)) @@ -388,32 +403,39 @@ let rec translate_expr in Expr.elocation (SubScopeVar - (subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos))) + { + scope = subscope_real_uid; + alias = subscope_uid, pos; + var = subscope_var_uid, pos; + }) emark | _ -> (* In this case e.x is the struct field x access of expression e *) - let e = translate_expr scope inside_definition_of ctxt e in - let str = - match path with + let e = rec_helper e in + let rec get_str ctxt = function | [] -> None - | [c] -> ( - try Some (Name_resolution.get_struct ctxt c) - with Not_found -> - Message.raise_spanned_error (Mark.get c) - "Structure %s was not declared" (Mark.remove c)) - | _ -> - Message.raise_spanned_error pos - "Qualified paths are not supported yet" + | [c] -> Some (Name_resolution.get_struct ctxt c) + | (modname, mpos) :: path -> ( + let modname = ModuleName.of_string modname in + match ModuleName.Map.find_opt modname ctxt.modules with + | None -> + Message.raise_spanned_error mpos "Module \"%a\" not found" + ModuleName.format modname + | Some ctxt -> get_str ctxt path) in - Expr.edstructaccess e (Mark.remove x) str emark) + Expr.edstructaccess ~e ~field:(Mark.remove x) + ~name_opt:(get_str ctxt path) emark) | FunCall (f, args) -> Expr.eapp (rec_helper f) (List.map rec_helper args) emark - | ScopeCall ((([], sc_name), _), fields) -> + | ScopeCall (((path, id), _), fields) -> if scope = None then Message.raise_spanned_error pos "Scope calls are not allowed outside of a scope"; - let called_scope = Name_resolution.get_scope ctxt sc_name in - let scope_def = ScopeName.Map.find called_scope ctxt.scopes in + let called_scope, scope_def = + let ctxt = Name_resolution.module_ctx ctxt path in + let uid = Name_resolution.get_scope ctxt id in + uid, ScopeName.Map.find uid ctxt.scopes + in let in_struct = List.fold_left (fun acc (fld_id, e) -> @@ -444,18 +466,13 @@ let rec translate_expr acc) ScopeVar.Map.empty fields in - Expr.escopecall called_scope in_struct emark - | ScopeCall (((_, _sc_name), _), _fields) -> - Message.raise_spanned_error pos "Qualified paths are not supported yet" + Expr.escopecall ~scope:called_scope ~args:in_struct emark | LetIn (x, e1, e2) -> - let ctxt, v = Name_resolution.add_def_local_var ctxt (Mark.remove x) in + let v = Var.make (Mark.remove x) in + let local_vars = Ident.Map.add (Mark.remove x) v local_vars in let tau = TAny, Mark.get x in (* This type will be resolved in Scopelang.Desambiguation *) - let fn = - Expr.make_abs [| v |] - (translate_expr scope inside_definition_of ctxt e2) - [tau] pos - in + let fn = Expr.make_abs [| v |] (rec_helper ~local_vars e2) [tau] pos in Expr.eapp fn [rec_helper e1] emark | StructLit ((([], s_name), _), fields) -> let s_uid = @@ -473,7 +490,7 @@ let rec translate_expr try StructName.Map.find s_uid (Ident.Map.find (Mark.remove f_name) ctxt.field_idmap) - with Not_found -> + with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> Message.raise_spanned_error (Mark.get f_name) "This identifier should refer to a field of struct %s" (Mark.remove s_name) @@ -484,7 +501,7 @@ let rec translate_expr Message.raise_multispanned_error [None, Mark.get f_e; None, Expr.pos e_field] "The field %a has been defined twice:" StructField.format f_uid); - let f_e = translate_expr scope inside_definition_of ctxt f_e in + let f_e = rec_helper f_e in StructField.Map.add f_uid f_e s_fields) StructField.Map.empty fields in @@ -497,21 +514,21 @@ let rec translate_expr StructField.format expected_f) expected_s_fields; - Expr.estruct s_uid s_fields emark + Expr.estruct ~name:s_uid ~fields:s_fields emark | StructLit (((_, _s_name), _), _fields) -> Message.raise_spanned_error pos "Qualified paths are not supported yet" | EnumInject (((path, (constructor, pos_constructor)), _), payload) -> ( - let possible_c_uids = - try Ident.Map.find constructor ctxt.constructor_idmap - with Not_found -> + let get_possible_c_uids ctxt = + try Ident.Map.find constructor ctxt.Name_resolution.constructor_idmap + with Ident.Map.Not_found _ -> raise_error_cons_not_found ctxt (constructor, pos_constructor) in let mark_constructor = Untyped { pos = pos_constructor } in - match path with | [] -> + let possible_c_uids = get_possible_c_uids ctxt in if - (* No constructor name was specified *) + (* No enum name was specified *) EnumName.Map.cardinal possible_c_uids > 1 then Message.raise_spanned_error pos_constructor @@ -522,43 +539,42 @@ let rec translate_expr possible_c_uids else let e_uid, c_uid = EnumName.Map.choose possible_c_uids in - let payload = - Option.map (translate_expr scope inside_definition_of ctxt) payload - in + let payload = Option.map rec_helper payload in Expr.einj - (match payload with - | Some e' -> e' - | None -> Expr.elit LUnit mark_constructor) - c_uid e_uid emark - | [enum] -> ( - try - (* The path has been fully qualified *) - let e_uid = Name_resolution.get_enum ctxt enum in - try - let c_uid = EnumName.Map.find e_uid possible_c_uids in - let payload = - Option.map (translate_expr scope inside_definition_of ctxt) payload - in - Expr.einj + ~e: (match payload with | Some e' -> e' | None -> Expr.elit LUnit mark_constructor) - c_uid e_uid emark - with Not_found -> - Message.raise_spanned_error pos "Enum %s does not contain case %s" - (Mark.remove enum) constructor - with Not_found -> - Message.raise_spanned_error (Mark.get enum) - "Enum %s has not been defined before" (Mark.remove enum)) - | _ -> - Message.raise_spanned_error pos "Qualified paths are not supported yet") + ~cons:c_uid ~name:e_uid emark + | path_enum -> ( + let path, enum = + match List.rev path_enum with + | enum :: rpath -> List.rev rpath, enum + | _ -> assert false + in + let ctxt = Name_resolution.module_ctx ctxt path in + let possible_c_uids = get_possible_c_uids ctxt in + (* The path has been qualified *) + let e_uid = Name_resolution.get_enum ctxt enum in + try + let c_uid = EnumName.Map.find e_uid possible_c_uids in + let payload = Option.map rec_helper payload in + Expr.einj + ~e: + (match payload with + | Some e' -> e' + | None -> Expr.elit LUnit mark_constructor) + ~cons:c_uid ~name:e_uid emark + with EnumName.Map.Not_found _ -> + Message.raise_spanned_error pos "Enum %s does not contain case %s" + (Mark.remove enum) constructor)) | MatchWith (e1, (cases, _cases_pos)) -> - let e1 = translate_expr scope inside_definition_of ctxt e1 in + let e1 = rec_helper e1 in let cases_d, e_uid = disambiguate_match_and_build_expression scope inside_definition_of ctxt - cases + local_vars cases in - Expr.ematch e1 e_uid cases_d emark + Expr.ematch ~e:e1 ~name:e_uid ~cases:cases_d emark | TestMatchCase (e1, pattern) -> (match snd (Mark.remove pattern) with | None -> () @@ -579,19 +595,16 @@ let rec translate_expr [tau] pos) (EnumName.Map.find enum_uid ctxt.enums) in - Expr.ematch - (translate_expr scope inside_definition_of ctxt e1) - enum_uid cases emark + Expr.ematch ~e:(rec_helper e1) ~name:enum_uid ~cases emark | ArrayLit es -> Expr.earray (List.map rec_helper es) emark | CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) -> let collection = rec_helper collection in - let param, predicate = f in - let ctxt, param = - Name_resolution.add_def_local_var ctxt (Mark.remove param) - in + let param_name, predicate = f in + let param = Var.make (Mark.remove param_name) in + let local_vars = Ident.Map.add (Mark.remove param_name) param local_vars in let f_pred = Expr.make_abs [| param |] - (translate_expr scope inside_definition_of ctxt predicate) + (rec_helper ~local_vars predicate) [TAny, pos] pos in @@ -605,18 +618,17 @@ let rec translate_expr emark) [f_pred; collection] emark | CollectionOp - (S.AggregateArgExtremum { max; default; f = param, predicate }, collection) - -> + ( S.AggregateArgExtremum { max; default; f = param_name, predicate }, + collection ) -> let default = rec_helper default in let pos_dft = Expr.pos default in let collection = rec_helper collection in - let ctxt, param = - Name_resolution.add_def_local_var ctxt (Mark.remove param) - in + let param = Var.make (Mark.remove param_name) in + let local_vars = Ident.Map.add (Mark.remove param_name) param local_vars in let cmp_op = if max then Op.Gt else Op.Lt in let f_pred = Expr.make_abs [| param |] - (translate_expr scope inside_definition_of ctxt predicate) + (rec_helper ~local_vars predicate) [TAny, pos] pos in @@ -655,16 +667,15 @@ let rec translate_expr in let init = Expr.elit (LBool init) emark in let param0, predicate = predicate in - let ctxt, param = - Name_resolution.add_def_local_var ctxt (Mark.remove param0) - in + let param = Var.make (Mark.remove param0) in + let local_vars = Ident.Map.add (Mark.remove param0) param local_vars in let f = let acc_var = Var.make "acc" in let acc = Expr.make_var acc_var (Untyped { pos = Mark.get param0 }) in Expr.eabs (Expr.bind [| acc_var; param |] (Expr.eapp (translate_binop op pos) - [acc; translate_expr scope inside_definition_of ctxt predicate] + [acc; rec_helper ~local_vars predicate] emark)) [TAny, pos; TAny, pos] emark @@ -674,7 +685,7 @@ let rec translate_expr [f; init; collection] emark | CollectionOp (AggregateExtremum { max; default }, collection) -> let collection = rec_helper collection in - let default = translate_expr scope inside_definition_of ctxt default in + let default = rec_helper default in let op = translate_binop (if max then S.Gt KPoly else S.Lt KPoly) pos in let op_f = (* fun x1 x2 -> if op x1 x2 then x1 else x2 *) @@ -729,7 +740,7 @@ let rec translate_expr let acc_var = Var.make "acc" in let acc = Expr.make_var acc_var emark in let f_body = - let member = translate_expr scope inside_definition_of ctxt member in + let member = rec_helper member in Expr.eapp (Expr.eop Or [TLit TBool, pos; TLit TBool, pos] emark) [ @@ -763,13 +774,14 @@ and disambiguate_match_and_build_expression (scope : ScopeName.t option) (inside_definition_of : Ast.ScopeDef.t Mark.pos option) (ctxt : Name_resolution.context) - (cases : Surface.Ast.match_case Mark.pos list) : + (local_vars : Ast.expr Var.t Ident.Map.t) + (cases : S.match_case Mark.pos list) : Ast.expr boxed EnumConstructor.Map.t * EnumName.t = - let create_var = function - | None -> ctxt, Var.make "_" + let create_var local_vars = function + | None -> local_vars, Var.make "_" | Some param -> - let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in - ctxt, param_var + let param_var = Var.make param in + Ident.Map.add param param_var local_vars, param_var in let bind_case_body (c_uid : EnumConstructor.t) @@ -786,13 +798,11 @@ and disambiguate_match_and_build_expression in let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) = match case with - | Surface.Ast.MatchCase case -> - let constructor, binding = - Mark.remove case.Surface.Ast.match_case_pattern - in + | S.MatchCase case -> + let constructor, binding = Mark.remove case.S.match_case_pattern in let e_uid', c_uid = disambiguate_constructor ctxt constructor - (Mark.get case.Surface.Ast.match_case_pattern) + (Mark.get case.S.match_case_pattern) in let e_uid = match e_uid with @@ -801,7 +811,7 @@ and disambiguate_match_and_build_expression if e_uid = e_uid' then e_uid else Message.raise_spanned_error - (Mark.get case.Surface.Ast.match_case_pattern) + (Mark.get case.S.match_case_pattern) "This case matches a constructor of enumeration %a but previous \ case were matching constructors of enumeration %a" EnumName.format e_uid EnumName.format e_uid' @@ -813,17 +823,19 @@ and disambiguate_match_and_build_expression [None, Mark.get case.match_case_expr; None, Expr.pos e_case] "The constructor %a has been matched twice:" EnumConstructor.format c_uid); - let ctxt, param_var = create_var (Option.map Mark.remove binding) in + let local_vars, param_var = + create_var local_vars (Option.map Mark.remove binding) + in let case_body = - translate_expr scope inside_definition_of ctxt - case.Surface.Ast.match_case_expr + translate_expr scope inside_definition_of ctxt local_vars + case.S.match_case_expr in let e_binder = Expr.bind [| param_var |] case_body in let case_expr = bind_case_body c_uid e_uid ctxt case_body e_binder in ( EnumConstructor.Map.add c_uid case_expr cases_d, Some e_uid, curr_index + 1 ) - | Surface.Ast.WildCard match_case_expr -> ( + | S.WildCard match_case_expr -> ( let nb_cases = List.length cases in let raise_wildcard_not_last_case_err () = Message.raise_multispanned_error @@ -867,9 +879,10 @@ and disambiguate_match_and_build_expression ... | CaseN -> wildcard_payload *) (* Creates the wildcard payload *) - let ctxt, payload_var = create_var None in + let local_vars, payload_var = create_var local_vars None in let case_body = - translate_expr scope inside_definition_of ctxt match_case_expr + translate_expr scope inside_definition_of ctxt local_vars + match_case_expr in let e_binder = Expr.bind [| payload_var |] case_body in @@ -941,13 +954,13 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs = let process_rule_parameters ctxt (def_key : Ast.ScopeDef.t Mark.pos) - (def : Surface.Ast.definition) : - Name_resolution.context + (def : S.definition) : + Ast.expr Var.t Ident.Map.t * (Ast.expr Var.t Mark.pos * typ) list Mark.pos option = let decl_name, decl_pos = def_key in let declared_params = Name_resolution.get_params ctxt decl_name in match declared_params, def.S.definition_parameter with - | None, None -> ctxt, None + | None, None -> Ident.Map.empty, None | None, Some (_, pos) -> Message.raise_multispanned_error [ @@ -959,26 +972,27 @@ let process_rule_parameters Message.raise_multispanned_error [ Some "Arguments declared here", pos; - ( Some "Definition missing the arguments", - Mark.get def.Surface.Ast.definition_name ); + Some "Definition missing the arguments", Mark.get def.S.definition_name; ] "This definition for %a is missing the arguments" Ast.ScopeDef.format decl_name | Some (pdecl, pos_decl), Some (pdefs, pos_def) -> arglist_eq_check pos_decl pos_def (List.map fst pdecl) pdefs; - let ctxt, params = + let local_vars, params = List.fold_left_map - (fun ctxt ((lbl, pos), ty) -> - let ctxt, v = Name_resolution.add_def_local_var ctxt lbl in - ctxt, ((v, pos), ty)) - ctxt pdecl + (fun local_vars ((lbl, pos), ty) -> + let v = Var.make lbl in + let local_vars = Ident.Map.add lbl v local_vars in + local_vars, ((v, pos), ty)) + Ident.Map.empty pdecl in - ctxt, Some (params, pos_def) + local_vars, Some (params, pos_def) (** Translates a surface definition into condition into a desugared {!type: Ast.rule} *) let process_default (ctxt : Name_resolution.context) + (local_vars : Ast.expr Var.t Ident.Map.t) (scope : ScopeName.t) (def_key : Ast.ScopeDef.t Mark.pos) (rule_id : RuleName.t) @@ -986,15 +1000,16 @@ let process_default (precond : Ast.expr boxed option) (exception_situation : Ast.exception_situation) (label_situation : Ast.label_situation) - (just : Surface.Ast.expression option) - (cons : Surface.Ast.expression) : Ast.rule = + (just : S.expression option) + (cons : S.expression) : Ast.rule = let just = match just with - | Some just -> Some (translate_expr (Some scope) (Some def_key) ctxt just) + | Some just -> + Some (translate_expr (Some scope) (Some def_key) ctxt local_vars just) | None -> None in let just = merge_conditions precond just (Mark.get def_key) in - let cons = translate_expr (Some scope) (Some def_key) ctxt cons in + let cons = translate_expr (Some scope) (Some def_key) ctxt local_vars cons in { Ast.rule_just = just; rule_cons = cons; @@ -1011,7 +1026,7 @@ let process_def (scope_uid : ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program) - (def : Surface.Ast.definition) : Ast.program = + (def : S.definition) : Ast.program = let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in let scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in let def_key = @@ -1024,7 +1039,7 @@ let process_def Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts in (* We add to the name resolution context the name of the parameter variable *) - let new_ctxt, param_uids = + let local_vars, param_uids = process_rule_parameters ctxt (Mark.copy def.definition_name def_key) def in let scope_updated = @@ -1038,7 +1053,7 @@ let process_def | None -> Ast.Unlabeled in let exception_situation = - match def.Surface.Ast.definition_exception_to with + match def.S.definition_exception_to with | NotAnException -> Ast.BaseCase | UnlabeledException -> ( match scope_def_ctxt.default_exception_rulename with @@ -1054,7 +1069,7 @@ let process_def Ident.Map.find (Mark.remove label_str) scope_def_ctxt.label_idmap in ExceptionToLabel (label_id, Mark.get label_str) - with Not_found -> + with Ident.Map.Not_found _ -> Message.raise_spanned_error (Mark.get label_str) "Unknown label for the scope variable %a: \"%s\"" Ast.ScopeDef.format def_key (Mark.remove label_str)) @@ -1064,7 +1079,7 @@ let process_def scope_def with scope_def_rules = RuleName.Map.add rule_name - (process_default new_ctxt scope_uid + (process_default ctxt local_vars scope_uid (def_key, Mark.get def.definition_name) rule_name param_uids precond exception_situation label_situation def.definition_condition def.definition_expr) @@ -1082,14 +1097,14 @@ let process_def ScopeName.Map.add scope_uid scope_updated prgm.program_scopes; } -(** Translates a {!type: Surface.Ast.rule} from the surface language *) +(** Translates a {!type: S.rule} from the surface language *) let process_rule (precond : Ast.expr boxed option) (scope : ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program) - (rule : Surface.Ast.rule) : Ast.program = - let def = Surface.Ast.rule_to_def rule in + (rule : S.rule) : Ast.program = + let def = S.rule_to_def rule in process_def precond scope ctxt prgm def (** Translates assertions *) @@ -1098,17 +1113,17 @@ let process_assert (scope_uid : ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program) - (ass : Surface.Ast.assertion) : Ast.program = + (ass : S.assertion) : Ast.program = let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in let ass = - translate_expr (Some scope_uid) None ctxt - (match ass.Surface.Ast.assertion_condition with - | None -> ass.Surface.Ast.assertion_content + translate_expr (Some scope_uid) None ctxt Ident.Map.empty + (match ass.S.assertion_condition with + | None -> ass.S.assertion_content | Some cond -> - ( Surface.Ast.IfThenElse + ( S.IfThenElse ( cond, - ass.Surface.Ast.assertion_content, - Mark.copy cond (Surface.Ast.Literal (Surface.Ast.LBool true)) ), + ass.S.assertion_content, + Mark.copy cond (S.Literal (S.LBool true)) ), Mark.get cond )) in let assertion = @@ -1138,23 +1153,25 @@ let process_assert (** Translates a surface definition, rule or assertion *) let process_scope_use_item - (precond : Surface.Ast.expression option) + (precond : S.expression option) (scope : ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program) - (item : Surface.Ast.scope_use_item Mark.pos) : Ast.program = - let precond = Option.map (translate_expr (Some scope) None ctxt) precond in + (item : S.scope_use_item Mark.pos) : Ast.program = + let precond = + Option.map (translate_expr (Some scope) None ctxt Ident.Map.empty) precond + in match Mark.remove item with - | Surface.Ast.Rule rule -> process_rule precond scope ctxt prgm rule - | Surface.Ast.Definition def -> process_def precond scope ctxt prgm def - | Surface.Ast.Assertion ass -> process_assert precond scope ctxt prgm ass - | Surface.Ast.DateRounding (r, _) -> + | S.Rule rule -> process_rule precond scope ctxt prgm rule + | S.Definition def -> process_def precond scope ctxt prgm def + | S.Assertion ass -> process_assert precond scope ctxt prgm ass + | S.DateRounding (r, _) -> let scope_uid = scope in let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in let r = match r with - | Surface.Ast.Increasing -> Ast.Increasing - | Surface.Ast.Decreasing -> Ast.Decreasing + | S.Increasing -> Ast.Increasing + | S.Decreasing -> Ast.Decreasing in let new_scope = match @@ -1188,18 +1205,18 @@ let process_scope_use_item let check_unlabeled_exception (scope : ScopeName.t) (ctxt : Name_resolution.context) - (item : Surface.Ast.scope_use_item Mark.pos) : unit = + (item : S.scope_use_item Mark.pos) : unit = let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in match Mark.remove item with - | Surface.Ast.Rule _ | Surface.Ast.Definition _ -> ( + | S.Rule _ | S.Definition _ -> ( let def_key, exception_to = match Mark.remove item with - | Surface.Ast.Rule rule -> + | S.Rule rule -> ( Name_resolution.get_def_key (Mark.remove rule.rule_name) rule.rule_state scope ctxt (Mark.get rule.rule_name), rule.rule_exception_to ) - | Surface.Ast.Definition def -> + | S.Definition def -> ( Name_resolution.get_def_key (Mark.remove def.definition_name) def.definition_state scope ctxt @@ -1212,10 +1229,10 @@ let check_unlabeled_exception Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts in match exception_to with - | Surface.Ast.NotAnException | Surface.Ast.ExceptionToLabel _ -> () + | S.NotAnException | S.ExceptionToLabel _ -> () (* If this is an unlabeled exception, we check that it has a unique default definition *) - | Surface.Ast.UnlabeledException -> ( + | S.UnlabeledException -> ( match scope_def_ctxt.default_exception_rulename with | None -> Message.raise_spanned_error (Mark.get item) @@ -1233,7 +1250,7 @@ let check_unlabeled_exception let process_scope_use (ctxt : Name_resolution.context) (prgm : Ast.program) - (use : Surface.Ast.scope_use) : Ast.program = + (use : S.scope_use) : Ast.program = let scope_uid = Name_resolution.get_scope ctxt use.scope_use_name in (* Make sure the scope exists *) let prgm = @@ -1261,16 +1278,18 @@ let process_topdef let expr_opt = match def.S.topdef_expr, def.S.topdef_args with | None, _ -> None - | Some e, None -> Some (Expr.unbox_closed (translate_expr None None ctxt e)) + | Some e, None -> + Some (Expr.unbox_closed (translate_expr None None ctxt Ident.Map.empty e)) | Some e, Some (args, _) -> - let ctxt, args_tys = + let local_vars, args_tys = List.fold_left_map - (fun ctxt ((lbl, pos), ty) -> - let ctxt, v = Name_resolution.add_def_local_var ctxt lbl in - ctxt, ((v, pos), ty)) - ctxt args + (fun local_vars ((lbl, pos), ty) -> + let v = Var.make lbl in + let local_vars = Ident.Map.add lbl v local_vars in + local_vars, ((v, pos), ty)) + Ident.Map.empty args in - let body = translate_expr None None ctxt e in + let body = translate_expr None None ctxt local_vars e in let args, tys = List.split args_tys in let e = Expr.make_abs @@ -1303,16 +1322,16 @@ let process_topdef in { prgm with Ast.program_topdefs } -let attribute_to_io (attr : Surface.Ast.scope_decl_context_io) : Ast.io = +let attribute_to_io (attr : S.scope_decl_context_io) : Ast.io = { Ast.io_output = attr.scope_decl_context_io_output; Ast.io_input = Mark.map (fun io -> match io with - | Surface.Ast.Input -> Runtime.OnlyInput - | Surface.Ast.Internal -> Runtime.NoInput - | Surface.Ast.Context -> Runtime.Reentrant) + | S.Input -> Runtime.OnlyInput + | S.Internal -> Runtime.NoInput + | S.Context -> Runtime.Reentrant) attr.scope_decl_context_io_input; } @@ -1371,8 +1390,12 @@ let init_scope_defs in scope_def) | Name_resolution.SubScope (v0, subscope_uid) -> - let sub_scope_def = - ScopeName.Map.find subscope_uid ctxt.Name_resolution.scopes + let sub_scope_def = Name_resolution.get_scope_context ctxt subscope_uid in + let ctxt = + List.fold_left + (fun ctx m -> ModuleName.Map.find m ctx.Name_resolution.modules) + ctxt + (ScopeName.path subscope_uid) in Ident.Map.fold (fun _ v scope_def_map -> @@ -1399,11 +1422,10 @@ let init_scope_defs Ident.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty (** Main function of this module *) -let translate_program - (ctxt : Name_resolution.context) - (prgm : Surface.Ast.program) : Ast.program = - let empty_prgm = - let program_scopes = +let translate_program (ctxt : Name_resolution.context) (surface : S.program) : + Ast.program = + let desugared = + let get_program_scopes ctxt = ScopeName.Map.mapi (fun s_uid s_context -> let scope_vars = @@ -1412,8 +1434,10 @@ let translate_program match v with | Name_resolution.SubScope _ -> acc | Name_resolution.ScopeVar v -> ( - let v_sig = ScopeVar.Map.find v ctxt.var_typs in - match v_sig.var_sig_states_list with + let v_sig = + ScopeVar.Map.find v ctxt.Name_resolution.var_typs + in + match v_sig.Name_resolution.var_sig_states_list with | [] -> ScopeVar.Map.add v Ast.WholeVar acc | states -> ScopeVar.Map.add v (Ast.States states) acc)) s_context.Name_resolution.var_idmap ScopeVar.Map.empty @@ -1438,57 +1462,80 @@ let translate_program }) ctxt.Name_resolution.scopes in - let translate_type t = Name_resolution.process_type ctxt t in - { - Ast.program_ctx = - { - ctx_structs = ctxt.Name_resolution.structs; - ctx_enums = ctxt.Name_resolution.enums; - ctx_scopes = - Ident.Map.fold - (fun _ def acc -> - match def with - | Name_resolution.TScope (scope, scope_out_struct) -> - ScopeName.Map.add scope scope_out_struct acc - | _ -> acc) - ctxt.Name_resolution.typedefs ScopeName.Map.empty; - ctx_struct_fields = ctxt.Name_resolution.field_idmap; - ctx_modules = - List.fold_left - (fun map (path, def) -> - match def with - | Surface.Ast.Topdef { topdef_name; topdef_type; _ }, _pos -> - Qident.Map.add - (path, Mark.remove topdef_name) - (translate_type topdef_type) - map - | (ScopeDecl _ | StructDecl _ | EnumDecl _), _ (* as e *) -> - map (* assert false (\* TODO *\) *) - | ScopeUse _, _ -> assert false) - Qident.Map.empty prgm.Surface.Ast.program_interfaces; - }; - Ast.program_topdefs = TopdefName.Map.empty; - Ast.program_scopes; - } + let rec make_ctx ctxt = + let submodules = + ModuleName.Map.map make_ctx ctxt.Name_resolution.modules + in + { + Ast.program_ctx = + { + (* After name resolution, type definitions (structs and enums) are + exposed at toplevel for easier lookup *) + ctx_structs = + ModuleName.Map.fold + (fun _ prg acc -> + StructName.Map.union + (fun _ _ _ -> assert false) + acc prg.Ast.program_ctx.ctx_structs) + submodules ctxt.Name_resolution.structs; + ctx_enums = + ModuleName.Map.fold + (fun _ prg acc -> + EnumName.Map.union + (fun _ _ _ -> assert false) + acc prg.Ast.program_ctx.ctx_enums) + submodules ctxt.Name_resolution.enums; + ctx_scopes = + Ident.Map.fold + (fun _ def acc -> + match def with + | Name_resolution.TScope (scope, scope_info) -> + ScopeName.Map.add scope scope_info acc + | _ -> acc) + ctxt.Name_resolution.typedefs ScopeName.Map.empty; + ctx_struct_fields = ctxt.Name_resolution.field_idmap; + ctx_topdefs = ctxt.Name_resolution.topdef_types; + ctx_modules = + ModuleName.Map.map (fun s -> s.Ast.program_ctx) submodules; + }; + Ast.program_topdefs = TopdefName.Map.empty; + Ast.program_scopes = get_program_scopes ctxt; + Ast.program_modules = submodules; + } + in + make_ctx ctxt in - let rec processer_structure - (prgm : Ast.program) - (item : Surface.Ast.law_structure) : Ast.program = + let process_code_block ctxt prgm block = + List.fold_left + (fun prgm item -> + match Mark.remove item with + | S.ScopeUse use -> process_scope_use ctxt prgm use + | S.Topdef def -> process_topdef ctxt prgm def + | S.ScopeDecl _ | S.StructDecl _ | S.EnumDecl _ -> prgm) + prgm block + in + let rec process_structure (prgm : Ast.program) (item : S.law_structure) : + Ast.program = match item with - | LawHeading (_, children) -> + | S.LawHeading (_, children) -> List.fold_left - (fun prgm child -> processer_structure prgm child) + (fun prgm child -> process_structure prgm child) prgm children - | CodeBlock (block, _, _) -> - List.fold_left - (fun prgm item -> - match Mark.remove item with - | Surface.Ast.ScopeUse use -> process_scope_use ctxt prgm use - | Surface.Ast.Topdef def -> process_topdef ctxt prgm def - | Surface.Ast.ScopeDecl _ | Surface.Ast.StructDecl _ - | Surface.Ast.EnumDecl _ -> - prgm) - prgm block - | LawInclude _ | LawText _ -> prgm + | S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block + | S.LawInclude _ | S.LawText _ -> prgm in - List.fold_left processer_structure empty_prgm prgm.program_items + let desugared = + List.fold_left + (fun acc (id, intf) -> + let id = ModuleName.of_string id in + let modul = ModuleName.Map.find id acc.Ast.program_modules in + let modul = + process_code_block (ModuleName.Map.find id ctxt.modules) modul intf + in + { + acc with + program_modules = ModuleName.Map.add id modul acc.program_modules; + }) + desugared surface.S.program_modules + in + List.fold_left process_structure desugared surface.S.program_items diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index feb5ba7b..5258f124 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -136,7 +136,8 @@ let detect_unused_struct_fields (p : program) : unit = in StructName.Map.iter (fun s_name fields -> - if + if StructName.path s_name <> [] then () + else if (not (StructField.Map.is_empty fields)) && StructField.Map.for_all (fun field _ -> @@ -191,7 +192,8 @@ let detect_unused_enum_constructors (p : program) : unit = in EnumName.Map.iter (fun e_name constructors -> - if + if EnumName.path e_name <> [] then () + else if EnumConstructor.Map.for_all (fun cons _ -> not (EnumConstructor.Set.mem cons enum_constructors_used)) diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index ccee3c34..d469c6a8 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -65,13 +65,10 @@ type var_sig = { type typedef = | TStruct of StructName.t | TEnum of EnumName.t - | TScope of ScopeName.t * scope_out_struct - (** Implicitly defined output struct *) + | TScope of ScopeName.t * scope_info (** Implicitly defined output struct *) type context = { - local_var_idmap : Ast.expr Var.t Ident.Map.t; - (** Inside a definition, local variables can be introduced by functions - arguments or pattern matching *) + path : Uid.Path.t; typedefs : typedef Ident.Map.t; (** Gathers the names of the scopes, structs and enums *) field_idmap : StructField.t StructName.Map.t Ident.Map.t; @@ -82,11 +79,13 @@ type context = { between different enums *) scopes : scope_context ScopeName.Map.t; (** For each scope, its context *) topdefs : TopdefName.t Ident.Map.t; (** Global definitions *) + topdef_types : typ TopdefName.Map.t; structs : struct_context StructName.Map.t; (** For each struct, its context *) enums : enum_context EnumName.Map.t; (** For each enum, its context *) var_typs : var_sig ScopeVar.Map.t; (** The signatures of each scope variable declared *) + modules : context ModuleName.Map.t; } (** Main context used throughout {!module: Surface.Desugaring} *) @@ -114,12 +113,25 @@ let get_var_io (ctxt : context) (uid : ScopeVar.t) : Surface.Ast.scope_decl_context_io = (ScopeVar.Map.find uid ctxt.var_typs).var_sig_io +let get_scope_context (ctxt : context) (scope : ScopeName.t) : scope_context = + let rec remove_common_prefix curpath scpath = + match curpath, scpath with + | m1 :: cp, m2 :: sp when ModuleName.equal m1 m2 -> + remove_common_prefix cp sp + | _ -> scpath + in + let path = remove_common_prefix ctxt.path (ScopeName.path scope) in + let ctxt = + List.fold_left (fun ctx m -> ModuleName.Map.find m ctx.modules) ctxt path + in + ScopeName.Map.find scope ctxt.scopes + (** Get the variable uid inside the scope given in argument *) let get_var_uid (scope_uid : ScopeName.t) (ctxt : context) ((x, pos) : Ident.t Mark.pos) : ScopeVar.t = - let scope = ScopeName.Map.find scope_uid ctxt.scopes in + let scope = get_scope_context ctxt scope_uid in match Ident.Map.find_opt x scope.var_idmap with | Some (ScopeVar uid) -> uid | _ -> @@ -132,7 +144,7 @@ let get_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) ((y, pos) : Ident.t Mark.pos) : SubScopeName.t = - let scope = ScopeName.Map.find scope_uid ctxt.scopes in + let scope = get_scope_context ctxt scope_uid in match Ident.Map.find_opt y scope.var_idmap with | Some (SubScope (sub_uid, _sub_id)) -> sub_uid | _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos) @@ -141,7 +153,7 @@ let get_subscope_uid subscopes of [scope_uid]. *) let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : Ident.t) : bool = - let scope = ScopeName.Map.find scope_uid ctxt.scopes in + let scope = get_scope_context ctxt scope_uid in match Ident.Map.find_opt y scope.var_idmap with | Some (SubScope _) -> true | _ -> false @@ -149,7 +161,7 @@ let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : Ident.t) : (** Checks if the var_uid belongs to the scope scope_uid *) let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) : bool = - let scope = ScopeName.Map.find scope_uid ctxt.scopes in + let scope = get_scope_context ctxt scope_uid in Ident.Map.exists (fun _ -> function | ScopeVar var_uid -> ScopeVar.equal uid var_uid @@ -200,7 +212,7 @@ let get_enum ctxt id = Some "Scope defined at", Mark.get (ScopeName.get_info sid); ] "Expecting an enum, but found a scope" - | exception Not_found -> + | exception Ident.Map.Not_found _ -> Message.raise_spanned_error (Mark.get id) "No enum named %s found" (Mark.remove id) @@ -213,8 +225,8 @@ let get_struct ctxt id = None, Mark.get id; Some "Enum defined at", Mark.get (EnumName.get_info eid); ] - "Expecting an struct, but found an enum" - | exception Not_found -> + "Expecting a struct, but found an enum" + | exception Ident.Map.Not_found _ -> Message.raise_spanned_error (Mark.get id) "No struct named %s found" (Mark.remove id) @@ -235,10 +247,21 @@ let get_scope ctxt id = Some "Structure defined at", Mark.get (StructName.get_info sid); ] "Expecting an scope, but found a structure" - | exception Not_found -> + | exception Ident.Map.Not_found _ -> Message.raise_spanned_error (Mark.get id) "No scope named %s found" (Mark.remove id) +let rec module_ctx ctxt path = + match path with + | [] -> ctxt + | (modname, mpos) :: path -> ( + let modname = ModuleName.of_string modname in + match ModuleName.Map.find_opt modname ctxt.modules with + | None -> + Message.raise_spanned_error mpos "Module \"%a\" not found" + ModuleName.format modname + | Some ctxt -> module_ctx ctxt path) + (** {1 Declarations pass} *) (** Process a subscope declaration *) @@ -247,9 +270,9 @@ let process_subscope_decl (ctxt : context) (decl : Surface.Ast.scope_decl_context_scope) : context = let name, name_pos = decl.scope_decl_context_scope_name in - let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in - let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in - match Ident.Map.find_opt subscope scope_ctxt.var_idmap with + let (path, subscope), s_pos = decl.scope_decl_context_scope_sub_scope in + let scope_ctxt = get_scope_context ctxt scope in + match Ident.Map.find_opt (Mark.remove subscope) scope_ctxt.var_idmap with | Some use -> let info = match use with @@ -258,11 +281,12 @@ let process_subscope_decl in Message.raise_multispanned_error [Some "first use", Mark.get info; Some "second use", s_pos] - "Subscope name @{\"%s\"@} already used" subscope + "Subscope name @{\"%s\"@} already used" (Mark.remove subscope) | None -> let sub_scope_uid = SubScopeName.fresh (name, name_pos) in let original_subscope_uid = - get_scope ctxt decl.scope_decl_context_scope_sub_scope + let ctxt = module_ctx ctxt path in + get_scope ctxt subscope in let scope_ctxt = { @@ -314,9 +338,16 @@ let rec process_base_typ "Unknown type @{\"%s\"@}, not a struct or enum previously \ declared" ident) - | Surface.Ast.Named (_path, (_ident, _pos)) -> - Message.raise_spanned_error typ_pos - "Qualified paths are not supported yet") + | Surface.Ast.Named ((modul, mpos) :: path, id) -> ( + let modul = ModuleName.of_string modul in + match ModuleName.Map.find_opt modul ctxt.modules with + | None -> + Message.raise_spanned_error mpos + "This refers to module %a, which was not found" ModuleName.format + modul + | Some mod_ctxt -> + process_base_typ mod_ctxt + Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos))) (** Process a type (function or not) *) let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ @@ -336,7 +367,7 @@ let process_data_decl let data_typ = process_type ctxt decl.scope_decl_context_item_typ in let is_cond = is_type_cond decl.scope_decl_context_item_typ in let name, pos = decl.scope_decl_context_item_name in - let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in + let scope_ctxt = get_scope_context ctxt scope in match Ident.Map.find_opt name scope_ctxt.var_idmap with | Some use -> let info = @@ -405,18 +436,6 @@ let process_data_decl ctxt.var_typs; } -(** Adds a binding to the context *) -let add_def_local_var (ctxt : context) (name : Ident.t) : - context * Ast.expr Var.t = - let local_var_uid = Var.make name in - let ctxt = - { - ctxt with - local_var_idmap = Ident.Map.add name local_var_uid ctxt.local_var_idmap; - } - in - ctxt, local_var_uid - (** Process a struct declaration *) let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) : context = @@ -505,6 +524,18 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context }) ctxt edecl.enum_decl_cases +let process_topdef ctxt def = + let uid = + Ident.Map.find (Mark.remove def.Surface.Ast.topdef_name) ctxt.topdefs + in + { + ctxt with + topdef_types = + TopdefName.Map.add uid + (process_type ctxt def.Surface.Ast.topdef_type) + ctxt.topdef_types; + } + (** Process an item declaration *) let process_item_decl (scope : ScopeName.t) @@ -565,7 +596,7 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) : } in let out_struct_fields = - let sco = ScopeName.Map.find scope_uid ctxt.scopes in + let sco = get_scope_context ctxt scope_uid in let str = get_struct ctxt decl.scope_decl_name in Ident.Map.fold (fun id var svmap -> @@ -577,15 +608,17 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) : StructName.Map.find str (Ident.Map.find id ctxt.field_idmap) in ScopeVar.Map.add v field svmap - with Not_found -> svmap)) + with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> svmap)) sco.var_idmap ScopeVar.Map.empty in let typedefs = Ident.Map.update (Mark.remove decl.scope_decl_name) (function - | Some (TScope (scope, { out_struct_name; _ })) -> - Some (TScope (scope, { out_struct_name; out_struct_fields })) + | Some (TScope (scope, { in_struct_name; out_struct_name; _ })) -> + Some + (TScope + (scope, { in_struct_name; out_struct_name; out_struct_fields })) | _ -> assert false) ctxt.typedefs in @@ -616,8 +649,9 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : (fun use -> raise_already_defined_error (typedef_info use) name pos "scope") (Ident.Map.find_opt name ctxt.typedefs); - let scope_uid = ScopeName.fresh (name, pos) in - let out_struct_uid = StructName.fresh (name, pos) in + let scope_uid = ScopeName.fresh ctxt.path (name, pos) in + let in_struct_name = StructName.fresh ctxt.path (name ^ "_in", pos) in + let out_struct_name = StructName.fresh ctxt.path (name, pos) in { ctxt with typedefs = @@ -625,7 +659,8 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : (TScope ( scope_uid, { - out_struct_name = out_struct_uid; + in_struct_name; + out_struct_name; out_struct_fields = ScopeVar.Map.empty; } )) ctxt.typedefs; @@ -644,7 +679,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : (fun use -> raise_already_defined_error (typedef_info use) name pos "struct") (Ident.Map.find_opt name ctxt.typedefs); - let s_uid = StructName.fresh sdecl.struct_decl_name in + let s_uid = StructName.fresh ctxt.path sdecl.struct_decl_name in { ctxt with typedefs = @@ -658,7 +693,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : (fun use -> raise_already_defined_error (typedef_info use) name pos "enum") (Ident.Map.find_opt name ctxt.typedefs); - let e_uid = EnumName.fresh edecl.enum_decl_name in + let e_uid = EnumName.fresh ctxt.path edecl.enum_decl_name in { ctxt with typedefs = @@ -674,7 +709,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : raise_already_defined_error (TopdefName.get_info use) name pos "toplevel definition") (Ident.Map.find_opt name ctxt.topdefs); - let uid = TopdefName.fresh def.topdef_name in + let uid = TopdefName.fresh ctxt.path def.topdef_name in { ctxt with topdefs = Ident.Map.add name uid ctxt.topdefs } (** Process a code item that is a declaration *) @@ -685,29 +720,27 @@ let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : | StructDecl sdecl -> process_struct_decl ctxt sdecl | EnumDecl edecl -> process_enum_decl ctxt edecl | ScopeUse _ -> ctxt - | Topdef _ -> ctxt + | Topdef def -> process_topdef ctxt def (** Process a code block *) let process_code_block + (process_item : context -> Surface.Ast.code_item Mark.pos -> context) (ctxt : context) - (block : Surface.Ast.code_block) - (process_item : context -> Surface.Ast.code_item Mark.pos -> context) : - context = + (block : Surface.Ast.code_block) : context = List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block (** Process a law structure, only considering the code blocks *) let rec process_law_structure + (process_item : context -> Surface.Ast.code_item Mark.pos -> context) (ctxt : context) - (s : Surface.Ast.law_structure) - (process_item : context -> Surface.Ast.code_item Mark.pos -> context) : - context = + (s : Surface.Ast.law_structure) : context = match s with | Surface.Ast.LawHeading (_, children) -> List.fold_left - (fun ctxt child -> process_law_structure ctxt child process_item) + (fun ctxt child -> process_law_structure process_item ctxt child) ctxt children | Surface.Ast.CodeBlock (block, _, _) -> - process_code_block ctxt block process_item + process_code_block process_item ctxt block | Surface.Ast.LawInclude _ | Surface.Ast.LawText _ -> ctxt (** {1 Scope uses pass} *) @@ -730,7 +763,7 @@ let get_def_key try Some (Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap) - with Not_found -> + with Ident.Map.Not_found _ -> Message.raise_multispanned_error [ None, Mark.get state; @@ -906,34 +939,62 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : (** {1 API} *) +let empty_ctxt = + { + path = []; + typedefs = Ident.Map.empty; + scopes = ScopeName.Map.empty; + topdefs = Ident.Map.empty; + topdef_types = TopdefName.Map.empty; + var_typs = ScopeVar.Map.empty; + structs = StructName.Map.empty; + field_idmap = Ident.Map.empty; + enums = EnumName.Map.empty; + constructor_idmap = Ident.Map.empty; + modules = ModuleName.Map.empty; + } + +let import_module modules (name, intf) = + let mname = ModuleName.of_string name in + let ctxt = { empty_ctxt with modules; path = [mname] } in + let ctxt = List.fold_left process_name_item ctxt intf in + let ctxt = List.fold_left process_decl_item ctxt intf in + let ctxt = { ctxt with modules = empty_ctxt.modules } in + (* No submodules at the moment, a module may use the ones loaded before it, + but doesn't reexport them *) + ModuleName.Map.add mname ctxt modules + (** Derive the context from metadata, in one pass over the declarations *) let form_context (prgm : Surface.Ast.program) : context = - let empty_ctxt = - { - local_var_idmap = Ident.Map.empty; - typedefs = Ident.Map.empty; - scopes = ScopeName.Map.empty; - topdefs = Ident.Map.empty; - var_typs = ScopeVar.Map.empty; - structs = StructName.Map.empty; - field_idmap = Ident.Map.empty; - enums = EnumName.Map.empty; - constructor_idmap = Ident.Map.empty; - } + let modules = + List.fold_left import_module ModuleName.Map.empty prgm.program_modules + in + let ctxt = { empty_ctxt with modules } in + let rec gather_var_sigs acc modules = + (* Scope vars from imported modules need to be accessible directly for + definitions through submodules *) + ModuleName.Map.fold + (fun _modname mctx acc -> + let acc = gather_var_sigs acc mctx.modules in + ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.var_typs) + modules acc + in + let ctxt = + { ctxt with var_typs = gather_var_sigs ScopeVar.Map.empty ctxt.modules } in let ctxt = List.fold_left - (fun ctxt item -> process_law_structure ctxt item process_name_item) - empty_ctxt prgm.program_items - in - let ctxt = - List.fold_left - (fun ctxt item -> process_law_structure ctxt item process_decl_item) + (process_law_structure process_name_item) ctxt prgm.program_items in let ctxt = List.fold_left - (fun ctxt item -> process_law_structure ctxt item process_use_item) + (process_law_structure process_decl_item) + ctxt prgm.program_items + in + let ctxt = + List.fold_left + (process_law_structure process_use_item) ctxt prgm.program_items in ctxt diff --git a/compiler/desugared/name_resolution.mli b/compiler/desugared/name_resolution.mli index bfb011b5..86cc6c21 100644 --- a/compiler/desugared/name_resolution.mli +++ b/compiler/desugared/name_resolution.mli @@ -65,13 +65,11 @@ type var_sig = { type typedef = | TStruct of StructName.t | TEnum of EnumName.t - | TScope of ScopeName.t * scope_out_struct - (** Implicitly defined output struct *) + | TScope of ScopeName.t * scope_info (** Implicitly defined output struct *) type context = { - local_var_idmap : Ast.expr Var.t Ident.Map.t; - (** Inside a definition, local variables can be introduced by functions - arguments or pattern matching *) + path : ModuleName.t list; + (** The current path being processed. Used for generating the Uids. *) typedefs : typedef Ident.Map.t; (** Gathers the names of the scopes, structs and enums *) field_idmap : StructField.t StructName.Map.t Ident.Map.t; @@ -82,11 +80,14 @@ type context = { between different enums *) scopes : scope_context ScopeName.Map.t; (** For each scope, its context *) topdefs : TopdefName.t Ident.Map.t; (** Global definitions *) + topdef_types : typ TopdefName.Map.t; + (** Types associated with the global definitions *) structs : struct_context StructName.Map.t; (** For each struct, its context *) enums : enum_context EnumName.Map.t; (** For each enum, its context *) var_typs : var_sig ScopeVar.Map.t; (** The signatures of each scope variable declared *) + modules : context ModuleName.Map.t; } (** Main context used throughout {!module: Desugared.From_surface} *) @@ -106,6 +107,10 @@ val get_var_typ : context -> ScopeVar.t -> typ val is_var_cond : context -> ScopeVar.t -> bool val get_var_io : context -> ScopeVar.t -> Surface.Ast.scope_decl_context_io +val get_scope_context : context -> ScopeName.t -> scope_context +(** Get the corresponding scope context from the context, looking up into nested + submodules as necessary, following the path information in the scope name *) + val get_var_uid : ScopeName.t -> context -> Ident.t Mark.pos -> ScopeVar.t (** Get the variable uid inside the scope given in argument *) @@ -131,9 +136,6 @@ val get_params : val is_def_cond : context -> Ast.ScopeDef.t -> bool val is_type_cond : Surface.Ast.typ -> bool -val add_def_local_var : context -> Ident.t -> context * Ast.expr Var.t -(** Adds a binding to the context *) - val get_def_key : Surface.Ast.scope_var -> Surface.Ast.lident Mark.pos option -> @@ -155,6 +157,10 @@ val get_scope : context -> Ident.t Mark.pos -> ScopeName.t (** Find a scope definition from the typedefs, failing if there is none or it has a different kind *) +val module_ctx : context -> Surface.Ast.path -> context +(** Returns the context corresponding to the given module path; raises a user + error if the module is not found *) + val process_type : context -> Surface.Ast.typ -> typ (** Convert a surface base type to an AST type *) diff --git a/compiler/driver.ml b/compiler/driver.ml index 73a3f961..d90c22a6 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -42,30 +42,35 @@ let get_lang options file = @{%s@}, and @{--language@} was not specified" filename) -let load_module_interfaces prg options link_modules = - List.fold_left - (fun prg f -> +let load_module_interfaces options link_modules = + List.map + (fun f -> let lang = get_lang options (FileName f) in let modname = modname_of_file f in - Surface.Parser_driver.add_interface (FileName f) lang [modname] prg) - prg link_modules + let intf = Surface.Parser_driver.load_interface (FileName f) lang in + modname, intf) + link_modules module Passes = struct (* Each pass takes only its cli options, then calls upon its dependent passes (forwarding their options as needed) *) - let surface options : Surface.Ast.program * Cli.backend_lang = - Message.emit_debug "Reading files..."; + let surface options ~link_modules : Surface.Ast.program * Cli.backend_lang = + Message.emit_debug "- SURFACE -"; let language = get_lang options options.input_file in let prg = Surface.Parser_driver.parse_top_level_file options.input_file language in - Surface.Fill_positions.fill_pos_with_legislative_info prg, language + let prg = Surface.Fill_positions.fill_pos_with_legislative_info prg in + let prg = + { prg with program_modules = load_module_interfaces options link_modules } + in + prg, language let desugared options ~link_modules : Desugared.Ast.program * Desugared.Name_resolution.context = - let prg, _ = surface options in - let prg = load_module_interfaces prg options link_modules in + let prg, _ = surface options ~link_modules in + Message.emit_debug "- DESUGARED -"; Message.emit_debug "Name resolution..."; let ctx = Desugared.Name_resolution.form_context prg in (* let scope_uid = get_scope_uid options backend ctx in @@ -87,8 +92,8 @@ module Passes = struct * Desugared.Name_resolution.context * Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t = - Message.emit_debug "Collecting rules..."; let prg, ctx = desugared options ~link_modules in + Message.emit_debug "- SCOPELANG -"; let exceptions_graphs = Scopelang.From_desugared.build_exceptions_graph prg in @@ -102,11 +107,12 @@ module Passes = struct * Desugared.Name_resolution.context * Scopelang.Dependency.TVertex.t list = let prg, ctx, _ = scopelang options ~link_modules in - Message.emit_debug "Typechecking..."; + Message.emit_debug "- DCALC -"; let type_ordering = Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs prg.program_ctx.ctx_enums in + Message.emit_debug "Typechecking..."; let prg = Scopelang.Ast.type_program prg in Message.emit_debug "Translating to default calculus..."; let prg = Dcalc.From_scopelang.translate_program prg in @@ -147,7 +153,7 @@ module Passes = struct let prg, ctx, type_ordering = dcalc options ~link_modules ~optimize ~check_invariants in - Message.emit_debug "Compiling program into lambda calculus..."; + Message.emit_debug "- LCALC -"; let avoid_exceptions = avoid_exceptions || closure_conversion in let optimize = optimize || closure_conversion in (* --closure_conversion implies --avoid_exceptions and --optimize *) @@ -198,7 +204,7 @@ module Passes = struct lcalc options ~link_modules ~optimize ~check_invariants ~avoid_exceptions ~closure_conversion in - Message.emit_debug "Compiling program into statement calculus..."; + Message.emit_debug "- SCALC -"; Scalc.From_lcalc.translate_program prg, ctx, type_ordering end @@ -261,6 +267,12 @@ module Commands = struct SubScopeName.format subscope_var_name ScopeName.format scope_uid | Some second_part -> ( match + let ctxt = + Desugared.Name_resolution.module_ctx ctxt + (List.map + (fun m -> ModuleName.to_string m, Pos.no_pos) + (ScopeName.path subscope_name)) + in Ident.Map.find_opt second_part (ScopeName.Map.find subscope_name ctxt.scopes).var_idmap with @@ -299,7 +311,7 @@ module Commands = struct ~output_file ?ext () let makefile options output = - let prg, _ = Passes.surface options in + let prg, _ = Passes.surface options ~link_modules:[] in let backend_extensions_list = [".tex"] in let source_file = match options.Cli.input_file with @@ -330,7 +342,7 @@ module Commands = struct Term.(const makefile $ Cli.Flags.Global.options $ Cli.Flags.output) let html options output print_only_law wrap_weaved_output = - let prg, language = Passes.surface options in + let prg, language = Passes.surface options ~link_modules:[] in Message.emit_debug "Weaving literate program into HTML"; let output_file, with_output = get_output_format options ~ext:".html" output @@ -358,7 +370,7 @@ module Commands = struct $ Cli.Flags.wrap_weaved_output) let latex options output print_only_law wrap_weaved_output = - let prg, language = Passes.surface options in + let prg, language = Passes.surface options ~link_modules:[] in Message.emit_debug "Weaving literate program into LaTeX"; let output_file, with_output = get_output_format options ~ext:".tex" output @@ -559,10 +571,10 @@ module Commands = struct results let interpret_dcalc options link_modules optimize check_invariants ex_scope = - Interpreter.load_runtime_modules link_modules; let prg, ctx, _ = Passes.dcalc options ~link_modules ~optimize ~check_invariants in + Interpreter.load_runtime_modules link_modules; print_interpretation_results options Interpreter.interpret_program_dcalc prg (get_scope_uid ctx ex_scope) @@ -887,6 +899,7 @@ let main () = | Some opts, _ -> opts.Cli.plugins_dirs | None, _ -> [] in + Message.emit_debug "- INIT -"; List.iter (fun d -> if d = "" then () diff --git a/compiler/driver.mli b/compiler/driver.mli index b5e9c2b1..a66134cf 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -25,7 +25,10 @@ val main : unit -> unit Each pass takes only its cli options, then calls upon its dependent passes (forwarding their options as needed) *) module Passes : sig - val surface : Cli.options -> Surface.Ast.program * Cli.backend_lang + val surface : + Cli.options -> + link_modules:string list -> + Surface.Ast.program * Cli.backend_lang val desugared : Cli.options -> diff --git a/compiler/lcalc/ast.ml b/compiler/lcalc/ast.ml index 98c1e90b..d4457546 100644 --- a/compiler/lcalc/ast.ml +++ b/compiler/lcalc/ast.ml @@ -23,10 +23,11 @@ type 'm program = 'm expr Shared_ast.program module OptionMonad = struct let return ~(mark : 'a mark) e = - Expr.einj e Expr.some_constr Expr.option_enum mark + Expr.einj ~e ~cons:Expr.some_constr ~name:Expr.option_enum mark let empty ~(mark : 'a mark) = - Expr.einj (Expr.elit LUnit mark) Expr.none_constr Expr.option_enum mark + Expr.einj ~e:(Expr.elit LUnit mark) ~cons:Expr.none_constr + ~name:Expr.option_enum mark let bind_var ~(mark : 'a mark) f x arg = let cases = @@ -36,8 +37,8 @@ module OptionMonad = struct let x = Var.make "_" in Expr.eabs (Expr.bind [| x |] - (Expr.einj (Expr.evar x mark) Expr.none_constr Expr.option_enum - mark)) + (Expr.einj ~e:(Expr.evar x mark) ~cons:Expr.none_constr + ~name:Expr.option_enum mark)) [TLit TUnit, Expr.mark_pos mark] mark ); (* | None x -> None x *) @@ -46,7 +47,7 @@ module OptionMonad = struct (*| Some x -> f (where f contains x as a free variable) *); ] in - Expr.ematch arg Expr.option_enum cases mark + Expr.ematch ~e:arg ~name:Expr.option_enum ~cases mark let bind ~(mark : 'a mark) ~(var_name : string) f arg = let x = Var.make var_name in @@ -86,8 +87,8 @@ module OptionMonad = struct ListLabels.fold_left2 xs args ~f:(bind_var ~mark) ~init: (Expr.einj - (Expr.eapp f (List.map (fun v -> Expr.evar v mark) xs) mark) - Expr.some_constr Expr.option_enum mark) + ~e:(Expr.eapp f (List.map (fun v -> Expr.evar v mark) xs) mark) + ~cons:Expr.some_constr ~name:Expr.option_enum mark) let map_var ~(mark : 'a mark) f x arg = mmap_mvar f [x] [arg] ~mark @@ -120,6 +121,6 @@ module OptionMonad = struct Expr.some_constr, Expr.fun_id ~var_name mark (* | Some x -> x*); ] in - if toplevel then Expr.ematch arg Expr.option_enum cases mark - else return ~mark (Expr.ematch arg Expr.option_enum cases mark) + if toplevel then Expr.ematch ~e:arg ~name:Expr.option_enum ~cases mark + else return ~mark (Expr.ematch ~e:arg ~name:Expr.option_enum ~cases mark) end diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index 4fd9d95f..e12cfcd3 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -70,7 +70,7 @@ let rec transform_closures_expr : cases (free_vars, EnumConstructor.Map.empty) in - free_vars, Expr.ematch new_e name new_cases m + free_vars, Expr.ematch ~e:new_e ~name ~cases:new_cases m | EApp { f = EAbs { binder; tys }, e1_pos; args } -> (* let-binding, we should not close these *) let vars, body = Bindlib.unmbind binder in @@ -394,7 +394,7 @@ let rec hoist_closures_expr : cases (collected_closures, EnumConstructor.Map.empty) in - collected_closures, Expr.ematch new_e name new_cases m + collected_closures, Expr.ematch ~e:new_e ~name ~cases:new_cases m | EApp { f = EAbs { binder; tys }, e1_pos; args } -> (* let-binding, we should not close these *) let vars, body = Bindlib.unmbind binder in @@ -552,7 +552,7 @@ let rec hoist_closures_code_item_list (fun next_code_items closure -> Cons ( Topdef - ( TopdefName.fresh + ( TopdefName.fresh [] ( Bindlib.name_of hoisted_closure.name, Expr.mark_pos closure_mark ), hoisted_closure.ty, diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 6eeb34e5..7af28c30 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -113,7 +113,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr if (Var.Map.find x ctx.ctx_vars).info_pure then Ast.OptionMonad.return (Expr.evar (trans_var ctx x) m) ~mark else Expr.evar (trans_var ctx x) m - | EExternal eref -> Expr.eexternal eref mark + | EExternal _ as e -> Expr.map ~f:(trans ctx) (e, m) | EApp { f = EVar v, _; args = [(ELit LUnit, _)] } -> (* Invariant: as users cannot write thunks, it can only come from prior compilation passes. Hence we can safely remove those. *) @@ -169,7 +169,11 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr Ast.OptionMonad.return ~mark (Expr.eapp (Expr.evar (trans_var ctx scope) mark) - [Expr.estruct name (StructField.Map.map (trans ctx) fields) mark] + [ + Expr.estruct ~name + ~fields:(StructField.Map.map (trans ctx) fields) + mark; + ] mark) | EApp { f = (EVar ff, _) as f; args } when not (Var.Map.find ff ctx.ctx_vars).is_scope -> @@ -395,7 +399,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr in Ast.OptionMonad.bind_cont ~var_name:(context_or_same_var ctx e) - (fun e -> Expr.ematch (Expr.evar e m) name cases m) + (fun e -> Expr.ematch ~e:(Expr.evar e m) ~name ~cases m) (trans ctx e) ~mark | EArray args -> Ast.OptionMonad.mbind_cont ~mark ~var_name:ctx.ctx_context_name @@ -418,7 +422,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr xs) ~f:StructField.Map.add ~init:StructField.Map.empty in - Ast.OptionMonad.return ~mark (Expr.estruct name fields mark)) + Ast.OptionMonad.return ~mark (Expr.estruct ~name ~fields mark)) (List.map (trans ctx) fields) ~mark | EIfThenElse { cond; etrue; efalse } -> @@ -433,12 +437,12 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr ~var_name:(context_or_same_var ctx e) (fun e -> Ast.OptionMonad.return ~mark - (Expr.einj (Expr.evar e mark) cons name mark)) + (Expr.einj ~e:(Expr.evar e mark) ~cons ~name mark)) (trans ctx e) ~mark | EStructAccess { name; e; field } -> Ast.OptionMonad.bind_cont ~var_name:(context_or_same_var ctx e) - (fun e -> Expr.estructaccess (Expr.evar e mark) field name mark) + (fun e -> Expr.estructaccess ~e:(Expr.evar e mark) ~field ~name mark) (trans ctx e) ~mark | ETuple args -> Ast.OptionMonad.mbind_cont ~var_name:ctx.ctx_context_name @@ -653,8 +657,8 @@ and trans_scope_body_expr ctx s : Bindlib.box_apply (fun e -> Result e) (Expr.Box.lift - @@ Expr.estruct name - (StructField.Map.map (trans ctx) fields) + @@ Expr.estruct ~name + ~fields:(StructField.Map.map (trans ctx) fields) (Mark.get e)) | _ -> assert false end diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index c6290e2c..a7bc61aa 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -19,22 +19,6 @@ open Shared_ast open Ast module D = Dcalc.Ast -let find_struct (s : StructName.t) (ctx : decl_ctx) : typ StructField.Map.t = - try StructName.Map.find s ctx.ctx_structs - with Not_found -> - let s_name, pos = StructName.get_info s in - Message.raise_spanned_error pos - "Internal Error: Structure %s was not found in the current environment." - s_name - -let find_enum (en : EnumName.t) (ctx : decl_ctx) : typ EnumConstructor.Map.t = - try EnumName.Map.find en ctx.ctx_enums - with Not_found -> - let en_name, pos = EnumName.get_info en in - Message.raise_spanned_error pos - "Internal Error: Enumeration %s was not found in the current environment." - en_name - let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit = match Mark.remove l with | LBool b -> Print.lit fmt (LBool b) @@ -159,11 +143,7 @@ let format_to_module_name | `Ename v -> Format.asprintf "%a" EnumName.format v | `Sname v -> Format.asprintf "%a" StructName.format v) |> String.to_ascii - |> String.to_snake_case |> avoid_keywords - |> String.split_on_char '_' - |> List.map String.capitalize_ascii - |> String.concat "" |> Format.fprintf fmt "%s" let format_struct_field_name @@ -233,10 +213,8 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit = | TAny -> Format.fprintf fmt "_" | TClosureEnv -> failwith "unimplemented!" -let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit = - let lowercase_name = - String.to_snake_case (String.to_ascii (Bindlib.name_of v)) - in +let format_var_str (fmt : Format.formatter) (v : string) : unit = + let lowercase_name = String.to_snake_case (String.to_ascii v) in let lowercase_name = Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_") @@ -245,11 +223,15 @@ let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit = let lowercase_name = String.to_ascii lowercase_name in if List.mem lowercase_name ["handle_default"; "handle_default_opt"] - || String.begins_with_uppercase (Bindlib.name_of v) + (* O_O *) + || String.begins_with_uppercase v then Format.pp_print_string fmt lowercase_name else if lowercase_name = "_" then Format.pp_print_string fmt lowercase_name else Format.fprintf fmt "%s_" lowercase_name +let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit = + format_var_str fmt (Bindlib.name_of v) + let needs_parens (e : 'm expr) : bool = match Mark.remove e with | EApp { f = EAbs _, _; _ } @@ -288,7 +270,26 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : in match Mark.remove e with | EVar v -> Format.fprintf fmt "%a" format_var v - | EExternal qid -> Qident.format fmt qid + | EExternal { name } -> ( + (* FIXME: this is wrong in general !! We assume the idents exposed by the + module depend only on the original name, while they actually get through + Bindlib and may have been renamed. A correct implem could use the runtime + registration used by the interpreter, but that would be distasteful and + incur a penalty ; or we would need to reproduce the same structure as in + the original module to ensure that bindlib performs the exact same + renamings ; or finally we could normalise the names at generation time + (either at toplevel or in a dedicated submodule ?) *) + let path = + match Mark.remove name with + | External_value name -> TopdefName.path name + | External_scope name -> ScopeName.path name + in + Uid.Path.format fmt path; + match Mark.remove name with + | External_value name -> + format_var_str fmt (Mark.remove (TopdefName.get_info name)) + | External_scope name -> + format_var_str fmt (Mark.remove (ScopeName.get_info name))) | ETuple es -> Format.fprintf fmt "@[(%a)@]" (Format.pp_print_list @@ -471,7 +472,7 @@ let format_struct_embedding StructName.format struct_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n") - (fun _fmt (struct_field, struct_field_type) -> + (fun fmt (struct_field, struct_field_type) -> Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructField.format struct_field typ_embedding_name struct_field_type format_struct_field_name @@ -493,7 +494,7 @@ let format_enum_embedding EnumName.format enum_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (enum_cons, enum_cons_type) -> + (fun fmt (enum_cons, enum_cons_type) -> Format.fprintf fmt "@[| %a x ->@ (\"%a\", %a x)@]" format_enum_cons_name enum_cons EnumConstructor.format enum_cons typ_embedding_name enum_cons_type)) @@ -516,7 +517,7 @@ let format_ctx format_to_module_name (`Sname struct_name) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") - (fun _fmt (struct_field, struct_field_type) -> + (fun fmt (struct_field, struct_field_type) -> Format.fprintf fmt "@[%a:@ %a@]" format_struct_field_name (None, struct_field) format_typ struct_field_type)) (StructField.Map.bindings struct_fields); @@ -529,7 +530,7 @@ let format_ctx format_to_module_name (`Ename enum_name) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (enum_cons, enum_cons_type) -> + (fun fmt (enum_cons, enum_cons_type) -> Format.fprintf fmt "@[| %a@ of@ %a@]" format_enum_cons_name enum_cons format_typ enum_cons_type)) (EnumConstructor.Map.bindings enum_cons); @@ -555,9 +556,13 @@ let format_ctx (fun struct_or_enum -> match struct_or_enum with | Scopelang.Dependency.TVertex.Struct s -> - Format.fprintf fmt "%a@\n" format_struct_decl (s, find_struct s ctx) + let def = StructName.Map.find s ctx.ctx_structs in + if StructName.path s = [] then + Format.fprintf fmt "%a@\n" format_struct_decl (s, def) | Scopelang.Dependency.TVertex.Enum e -> - Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx)) + let def = EnumName.Map.find e ctx.ctx_enums in + if EnumName.path e = [] then + Format.fprintf fmt "%a@\n" format_enum_decl (e, def)) (type_ordering @ scope_structs) let rename_vars e = @@ -594,7 +599,7 @@ let format_code_items | Topdef (name, typ, e) -> Format.fprintf fmt "@\n@\n@[let %a : %a =@\n%a@]" format_var var format_typ typ (format_expr ctx) e; - String.Map.add (Mark.remove (TopdefName.get_info name)) var bnd + String.Map.add (Format.asprintf "%a" TopdefName.format name) var bnd | ScopeDef (name, body) -> let scope_input_var, scope_body_expr = Bindlib.unbind body.scope_body_expr @@ -605,7 +610,7 @@ let format_code_items (`Sname body.scope_body_output_struct) (format_scope_body_expr ctx) scope_body_expr; - String.Map.add (Mark.remove (ScopeName.get_info name)) var bnd) + String.Map.add (Format.asprintf "%a" ScopeName.format name) var bnd) ~init:String.Map.empty code_items let format_scope_exec @@ -614,7 +619,7 @@ let format_scope_exec (bnd : 'm Ast.expr Var.t String.Map.t) scope_name scope_body = - let scope_name_str = Mark.remove (ScopeName.get_info scope_name) in + let scope_name_str = Format.asprintf "%a" ScopeName.format scope_name in let scope_var = String.Map.find scope_name_str bnd in let scope_input = StructName.Map.find scope_body.scope_body_input_struct ctx.ctx_structs diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index f695a0f3..618813ed 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -19,8 +19,6 @@ open Shared_ast (** Formats a lambda calculus program into a valid OCaml program *) val avoid_keywords : string -> string -val find_struct : StructName.t -> decl_ctx -> typ StructField.Map.t -val find_enum : EnumName.t -> decl_ctx -> typ EnumConstructor.Map.t val typ_needs_parens : typ -> bool (* val needs_parens : 'm expr -> bool *) diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index 52f7c390..062ee90d 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -145,54 +145,54 @@ module To_jsoo = struct To_ocaml.format_to_module_name fmt (`Sname struct_name) in let fmt_to_jsoo fmt _ = - Format.fprintf fmt "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun fmt (struct_field, struct_field_type) -> - match Mark.remove struct_field_type with - | TArrow (t1, t2) -> - let args_names = - ListLabels.mapi t1 ~f:(fun i _ -> - "function_input" ^ string_of_int i) - in - Format.fprintf fmt - "@[method %a =@ Js.wrap_meth_callback@ @[(@,\ - fun _ %a ->@ %a (%a.%a %a))@]@]" - format_struct_field_name_camel_case struct_field - (Format.pp_print_list (fun fmt (arg_i, ti) -> - Format.fprintf fmt "(%s: %a)" arg_i format_typ ti)) - (List.combine args_names t1) - format_typ_to_jsoo t2 fmt_struct_name () - format_struct_field_name (None, struct_field) - (Format.pp_print_list (fun fmt (i, ti) -> - Format.fprintf fmt "@[(%a@ %a)@]" - format_typ_of_jsoo ti Format.pp_print_string i)) - (List.combine args_names t1) - | _ -> - Format.fprintf fmt "@[val %a =@ %a %a.%a@]" - format_struct_field_name_camel_case struct_field - format_typ_to_jsoo struct_field_type fmt_struct_name () - format_struct_field_name (None, struct_field))) + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") + (fun fmt (struct_field, struct_field_type) -> + match Mark.remove struct_field_type with + | TArrow (t1, t2) -> + let args_names = + ListLabels.mapi t1 ~f:(fun i _ -> + "function_input" ^ string_of_int i) + in + Format.fprintf fmt + "@[method %a =@ Js.wrap_meth_callback@ @[(@,\ + fun _ %a ->@ %a (%a.%a %a))@]@]" + format_struct_field_name_camel_case struct_field + (Format.pp_print_list (fun fmt (arg_i, ti) -> + Format.fprintf fmt "(%s: %a)" arg_i format_typ ti)) + (List.combine args_names t1) + format_typ_to_jsoo t2 fmt_struct_name () + format_struct_field_name (None, struct_field) + (Format.pp_print_list (fun fmt (i, ti) -> + Format.fprintf fmt "@[(%a@ %a)@]" format_typ_of_jsoo + ti Format.pp_print_string i)) + (List.combine args_names t1) + | _ -> + Format.fprintf fmt "@[val %a =@ %a %a.%a@]" + format_struct_field_name_camel_case struct_field + format_typ_to_jsoo struct_field_type fmt_struct_name () + format_struct_field_name (None, struct_field)) + fmt (StructField.Map.bindings struct_fields) in let fmt_of_jsoo fmt _ = - Format.fprintf fmt "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n") - (fun fmt (struct_field, struct_field_type) -> - match Mark.remove struct_field_type with - | TArrow _ -> - Format.fprintf fmt - "%a = failwith \"The function '%a' translation isn't yet \ - supported...\"" - format_struct_field_name (None, struct_field) - format_struct_field_name (None, struct_field) - | _ -> - Format.fprintf fmt - "@[%a =@ @[%a@ @[%a@,##.%a@]@]@]" - format_struct_field_name (None, struct_field) - format_typ_of_jsoo struct_field_type fmt_struct_name () - format_struct_field_name_camel_case struct_field)) + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n") + (fun fmt (struct_field, struct_field_type) -> + match Mark.remove struct_field_type with + | TArrow _ -> + Format.fprintf fmt + "%a = failwith \"The function '%a' translation isn't yet \ + supported...\"" + format_struct_field_name (None, struct_field) + format_struct_field_name (None, struct_field) + | _ -> + Format.fprintf fmt + "@[%a =@ @[%a@ @[%a@,##.%a@]@]@]" + format_struct_field_name (None, struct_field) format_typ_of_jsoo + struct_field_type fmt_struct_name () + format_struct_field_name_camel_case struct_field) + fmt (StructField.Map.bindings struct_fields) in let fmt_conv_funs fmt _ = @@ -233,7 +233,7 @@ module To_jsoo = struct let format_enum_decl fmt (enum_name, (enum_cons : typ EnumConstructor.Map.t)) = let fmt_enum_name fmt _ = format_enum_name fmt enum_name in - let fmt_module_enum_name fmt _ = + let fmt_module_enum_name fmt () = To_ocaml.format_to_module_name fmt (`Ename enum_name) in let fmt_to_jsoo fmt _ = @@ -332,9 +332,11 @@ module To_jsoo = struct (fun struct_or_enum -> match struct_or_enum with | Scopelang.Dependency.TVertex.Struct s -> - Format.fprintf fmt "%a@\n" format_struct_decl (s, find_struct s ctx) + Format.fprintf fmt "%a@\n" format_struct_decl + (s, StructName.Map.find s ctx.ctx_structs) | Scopelang.Dependency.TVertex.Enum e -> - Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx)) + Format.fprintf fmt "%a@\n" format_enum_decl + (e, EnumName.Map.find e ctx.ctx_enums)) (type_ordering @ scope_structs) let fmt_input_struct_name fmt (scope_body : 'a expr scope_body) = diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index bf40036e..6fa22cf2 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -179,7 +179,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t (?) *) let env_elt = try Env.find v env - with Not_found -> + with Var.Map.Not_found _ -> error e0 "Variable %a undefined [@[%a@]]" Print.var_debug v Env.print env in @@ -689,7 +689,7 @@ let program_to_graph (G.add_vertex g v, var_vertices, env0), v | EVar var, _ -> ( try (g, var_vertices, env0), Var.Map.find var var_vertices - with Not_found -> ( + with Var.Map.Not_found _ -> ( try let child, env = (Env.find var env0).base in let m = Mark.get child in @@ -714,7 +714,7 @@ let program_to_graph else Var.Map.add var v var_vertices in (G.add_edge g v child_v, var_vertices, env), v - with Not_found -> + with Var.Map.Not_found _ -> Message.emit_warning "VAR NOT FOUND: %a" Print.var var; let v = G.V.create e in let g = G.add_vertex g v in diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 3cb5824d..aae3d97e 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -76,13 +76,14 @@ module To_json = struct (ctx : decl_ctx) (fmt : Format.formatter) (sname : StructName.t) = + let fields = StructName.Map.find sname ctx.ctx_structs in Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n") (fun fmt (field_name, field_type) -> Format.fprintf fmt "@[\"%a\": {@\n%a@]@\n}" format_struct_field_name_camel_case field_name fmt_type field_type) fmt - (StructField.Map.bindings (find_struct sname ctx)) + (StructField.Map.bindings fields) let fmt_definitions (ctx : decl_ctx) @@ -107,13 +108,13 @@ module To_json = struct | TArray t -> collect acc t | _ -> acc in - find_struct input_struct ctx + StructName.Map.find input_struct ctx.ctx_structs |> StructField.Map.values |> List.fold_left (fun acc field_typ -> collect acc field_typ) [] |> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t')) in let fmt_enum_properties fmt ename = - let enum_def = find_enum ename ctx in + let enum_def = EnumName.Map.find ename ctx.ctx_enums in Format.fprintf fmt "@[\"kind\": {@\n\ \"type\": \"string\",@\n\ diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index b9916515..68d6866a 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -75,7 +75,7 @@ let rec lazy_eval : (?) *) let v_env = try Env.find v env - with Not_found -> + with Var.Map.Not_found _ -> error e0 "Variable %a undefined [@[%a@]]" Print.var_debug v Env.print env in @@ -233,16 +233,17 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) : log "====================="; let m = Mark.get e in let application_arg = - Expr.estruct scope_arg_struct - (StructField.Map.map - (function - | TArrow (ty_in, ty_out), _ -> - Expr.make_abs - [| Var.make "_" |] - (Bindlib.box EEmptyError, Expr.with_ty m ty_out) - ty_in (Expr.mark_pos m) - | ty -> Expr.evar (Var.make "undefined_input") (Expr.with_ty m ty)) - (StructName.Map.find scope_arg_struct ctx.ctx_structs)) + Expr.estruct ~name:scope_arg_struct + ~fields: + (StructField.Map.map + (function + | TArrow (ty_in, ty_out), _ -> + Expr.make_abs + [| Var.make "_" |] + (Bindlib.box EEmptyError, Expr.with_ty m ty_out) + ty_in (Expr.mark_pos m) + | ty -> Expr.evar (Var.make "undefined_input") (Expr.with_ty m ty)) + (StructName.Map.find scope_arg_struct ctx.ctx_structs)) m in let e_app = Expr.eapp (Expr.box e) [application_arg] m in diff --git a/compiler/plugins/modules.ml b/compiler/plugins/modules.ml index 80ebf39f..58538cf8 100644 --- a/compiler/plugins/modules.ml +++ b/compiler/plugins/modules.ml @@ -84,24 +84,37 @@ let ocaml_libdir = "Could not locate the OCaml library directory, make sure OCaml or \ opam is installed"))) +let rec find_catala_project_root dir = + if Sys.file_exists File.(dir / "catala.opam") then Some dir + else + let dir' = Unix.realpath File.(dir / Filename.parent_dir_name) in + if dir' = dir then None else find_catala_project_root dir' + let runtime_dir = lazy - (match - List.find_map File.check_directory - [ - "_build/install/default/lib/catala/runtime_ocaml"; - (* Relative dir when running from catala source *) - File.(Lazy.force ocaml_libdir / "catala" / "runtime"); - ] - with - | Some dir -> - Message.emit_debug "Catala runtime libraries found at @{%s@}." dir; - dir - | None -> - Message.raise_error - "Could not locate the Catala runtime library.@ Make sure that either \ - catala is correctly installed,@ or you are running from the root of a \ - compiled source tree.") + (let d = + match find_catala_project_root (Sys.getcwd ()) with + | Some root -> + (* Relative dir when running from catala source *) + File.( + root + / "_build" + / "install" + / "default" + / "lib" + / "catala" + / "runtime_ocaml") + | None -> File.(Lazy.force ocaml_libdir / "catala" / "runtime") + in + match File.check_directory d with + | Some dir -> + Message.emit_debug "Catala runtime libraries found at @{%s@}." dir; + dir + | None -> + Message.raise_error + "@[Could not locate the Catala runtime library.@ Make sure that \ + either catala is correctly installed,@ or you are running from the \ + root of a compiled source tree.@]") let compile options link_modules optimize check_invariants = let modname = @@ -115,7 +128,7 @@ let compile options link_modules optimize check_invariants = gen_ocaml options link_modules optimize check_invariants (Some modname) None in let flags = ["-I"; Lazy.force runtime_dir] in - let shared_out = basename ^ ".cmxs" in + let shared_out = File.((Filename.dirname ml_file / basename) ^ ".cmxs") in Message.emit_debug "Compiling OCaml shared object file @{%s@}..." shared_out; run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags); diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 86f6506e..1b231006 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -35,9 +35,9 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr = | EVar v -> let local_var = try A.EVar (Var.Map.find v ctxt.var_dict) - with Not_found -> ( + with Var.Map.Not_found _ -> ( try A.EFunc (Var.Map.find v ctxt.func_dict) - with Not_found -> + with Var.Map.Not_found _ -> Message.raise_spanned_error (Expr.pos expr) "Var not found in lambda→scalc: %a@\nknown: @[%a@]@\n" Print.var_debug v diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 8e01b45a..9e8bece1 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -42,6 +42,7 @@ let rec format_expr | EVar v -> Format.fprintf fmt "%a" format_var_name v | EFunc v -> Format.fprintf fmt "%a" format_func_name v | EStruct (es, s) -> + let fields = StructName.Map.find s decl_ctx.ctx_structs in Format.fprintf fmt "@[%a@ %a%a%a@]" StructName.format s Print.punctuation "{" (Format.pp_print_list @@ -50,8 +51,7 @@ let rec format_expr Format.fprintf fmt "%a%a%a%a %a" Print.punctuation "\"" StructField.format struct_field Print.punctuation "\"" Print.punctuation ":" format_expr e)) - (List.combine es - (StructField.Map.bindings (StructName.Map.find s decl_ctx.ctx_structs))) + (List.combine es (StructField.Map.bindings fields)) Print.punctuation "}" | EArray es -> Format.fprintf fmt "@[%a%a%a@]" Print.punctuation "[" @@ -142,6 +142,7 @@ let rec format_statement (format_expr decl_ctx ~debug) (naked_expr, Mark.get stmt) | SSwitch (e_switch, enum, arms) -> + let cons = EnumName.Map.find enum decl_ctx.ctx_enums in Format.fprintf fmt "@[%a @[%a@]%a@]%a" Print.keyword "switch" (format_expr decl_ctx ~debug) e_switch Print.punctuation ":" @@ -153,10 +154,7 @@ let rec format_statement format_var_name payload_name Print.punctuation "→" (format_block decl_ctx ~debug) arm_block)) - (List.combine - (EnumConstructor.Map.bindings - (EnumName.Map.find enum decl_ctx.ctx_enums)) - arms) + (List.combine (EnumConstructor.Map.bindings cons) arms) and format_block (decl_ctx : decl_ctx) diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index bc3a1a67..43430f7e 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -274,14 +274,14 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : | EVar v -> format_var fmt v | EFunc f -> format_func_name fmt f | EStruct (es, s) -> + let fields = StructName.Map.find s ctx.ctx_structs in Format.fprintf fmt "%a(%a)" format_struct_name s (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (fun fmt (e, (struct_field, _)) -> Format.fprintf fmt "%a = %a" format_struct_field_name struct_field (format_expression ctx) e)) - (List.combine es - (StructField.Map.bindings (StructName.Map.find s ctx.ctx_structs))) + (List.combine es (StructField.Map.bindings fields)) | EStructFieldAccess (e1, field, _) -> Format.fprintf fmt "%a.%a" (format_expression ctx) e1 format_struct_field_name field @@ -426,11 +426,12 @@ let rec format_statement (format_block ctx) case_none format_var case_some_var format_var tmp_var (format_block ctx) case_some | SSwitch (e1, e_name, cases) -> + let cons_map = EnumName.Map.find e_name ctx.ctx_enums in let cases = List.map2 (fun (x, y) (cons, _) -> x, y, cons) cases - (EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums)) + (EnumConstructor.Map.bindings cons_map) in let tmp_var = VarName.fresh ("match_arg", Pos.no_pos) in Format.fprintf fmt "%a = %a@\n@[if %a@]" format_var tmp_var diff --git a/compiler/scopelang/ast.ml b/compiler/scopelang/ast.ml index 94382ab7..5d0edf16 100644 --- a/compiler/scopelang/ast.ml +++ b/compiler/scopelang/ast.ml @@ -47,13 +47,13 @@ type 'm scope_decl = { scope_decl_name : ScopeName.t; scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t; scope_decl_rules : 'm rule list; - scope_mark : 'm mark; scope_options : Desugared.Ast.catala_option Mark.pos list; } type 'm program = { - program_scopes : 'm scope_decl ScopeName.Map.t; + program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t; program_topdefs : ('m expr * typ) TopdefName.Map.t; + program_modules : nil program ModuleName.Map.t; program_ctx : decl_ctx; } @@ -70,46 +70,58 @@ let type_rule decl_ctx env = function Call (sc_name, ssc_name, Typed { pos; ty = Mark.add pos TAny }) let type_program (prg : 'm program) : typed program = - let typing_env = - TopdefName.Map.fold - (fun name (_, ty) -> Typing.Env.add_toplevel_var name ty) - prg.program_topdefs - (Typing.Env.empty prg.program_ctx) + (* Caution: this environment building code is very similar to that in + desugared/disambiguate.ml. Any edits should probably be reflected. *) + let base_typing_env prg = + let env = Typing.Env.empty prg.program_ctx in + let env = + TopdefName.Map.fold + (fun name ty env -> Typing.Env.add_toplevel_var name ty env) + prg.program_ctx.ctx_topdefs env + in + let env = + ScopeName.Map.fold + (fun scope_name scope_decl env -> + let vars = ScopeVar.Map.map fst (Mark.remove scope_decl).scope_sig in + Typing.Env.add_scope scope_name ~vars env) + prg.program_scopes env + in + env + in + let rec build_typing_env prg = + ModuleName.Map.fold + (fun modname prg -> + Typing.Env.add_module modname ~module_env:(build_typing_env prg)) + prg.program_modules (base_typing_env prg) + in + let env = + ModuleName.Map.fold + (fun modname prg -> + Typing.Env.add_module modname ~module_env:(build_typing_env prg)) + prg.program_modules (base_typing_env prg) in let program_topdefs = TopdefName.Map.map (fun (expr, typ) -> ( Expr.unbox - (Typing.expr prg.program_ctx ~leave_unresolved:false ~env:typing_env - ~typ expr), + (Typing.expr prg.program_ctx ~leave_unresolved:false ~env ~typ expr), typ )) prg.program_topdefs in - let typing_env = - ScopeName.Map.fold - (fun scope_name scope_decl -> - let vars = ScopeVar.Map.map fst scope_decl.scope_sig in - Typing.Env.add_scope scope_name ~vars) - prg.program_scopes typing_env - in let program_scopes = ScopeName.Map.map - (fun scope_decl -> - let typing_env = - ScopeVar.Map.fold - (fun svar (typ, _) env -> Typing.Env.add_scope_var svar typ env) - scope_decl.scope_sig typing_env - in - let scope_decl_rules = - List.map - (type_rule prg.program_ctx typing_env) - scope_decl.scope_decl_rules - in - let scope_mark = - let pos = Mark.get (ScopeName.get_info scope_decl.scope_decl_name) in - Typed { pos; ty = Mark.add pos TAny } - in - { scope_decl with scope_decl_rules; scope_mark }) + (Mark.map (fun scope_decl -> + let env = + ScopeVar.Map.fold + (fun svar (typ, _) env -> Typing.Env.add_scope_var svar typ env) + scope_decl.scope_sig env + in + let scope_decl_rules = + List.map + (type_rule prg.program_ctx env) + scope_decl.scope_decl_rules + in + { scope_decl with scope_decl_rules })) prg.program_scopes in { prg with program_topdefs; program_scopes } diff --git a/compiler/scopelang/ast.mli b/compiler/scopelang/ast.mli index 069c8b06..3628946f 100644 --- a/compiler/scopelang/ast.mli +++ b/compiler/scopelang/ast.mli @@ -40,13 +40,16 @@ type 'm scope_decl = { scope_decl_name : ScopeName.t; scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t; scope_decl_rules : 'm rule list; - scope_mark : 'm mark; scope_options : Desugared.Ast.catala_option Mark.pos list; } type 'm program = { - program_scopes : 'm scope_decl ScopeName.Map.t; + program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t; program_topdefs : ('m expr * typ) TopdefName.Map.t; + program_modules : nil program ModuleName.Map.t; + (* Using [nil] here ensure that program interfaces don't contain any + expressions. They won't contain any rules or topdefs, but will still have + the scope signatures needed to respect the call convention *) program_ctx : decl_ctx; } diff --git a/compiler/scopelang/dependency.ml b/compiler/scopelang/dependency.ml index dff5efe1..f1aac70a 100644 --- a/compiler/scopelang/dependency.ml +++ b/compiler/scopelang/dependency.ml @@ -82,9 +82,12 @@ let rec expr_used_defs e = e VMap.empty in match e with - | ELocation (ToplevelVar (v, pos)), _ -> VMap.singleton (Topdef v) pos + | ELocation (ToplevelVar { name = v, pos }), _ -> + if TopdefName.path v <> [] then VMap.empty + else VMap.singleton (Topdef v) pos | (EScopeCall { scope; _ }, m) as e -> - VMap.add (Scope scope) (Expr.mark_pos m) (recurse_subterms e) + if ScopeName.path scope <> [] then VMap.empty + else VMap.add (Scope scope) (Expr.mark_pos m) (recurse_subterms e) | EAbs { binder; _ }, _ -> let _, body = Bindlib.unmbind binder in expr_used_defs body @@ -96,7 +99,10 @@ let rule_used_defs = function walking through all exprs again *) expr_used_defs e | Ast.Call (subscope, subindex, _) -> - VMap.singleton (Scope subscope) (Mark.get (SubScopeName.get_info subindex)) + if ScopeName.path subscope = [] then + VMap.singleton (Scope subscope) + (Mark.get (SubScopeName.get_info subindex)) + else VMap.empty let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t = let g = SDependencies.empty in @@ -128,7 +134,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t = prgm.program_topdefs g in ScopeName.Map.fold - (fun scope_name scope g -> + (fun scope_name (scope, _) g -> List.fold_left (fun g rule -> let used_defs = rule_used_defs rule in diff --git a/compiler/scopelang/dependency.mli b/compiler/scopelang/dependency.mli index 970b7e2c..e37fd7ac 100644 --- a/compiler/scopelang/dependency.mli +++ b/compiler/scopelang/dependency.mli @@ -39,7 +39,7 @@ module TVertex : sig type t = Struct of StructName.t | Enum of EnumName.t val format : Format.formatter -> t -> unit - val get_info : t -> StructName.info + val get_info : t -> Uid.MarkedString.info include Graph.Sig.COMPARABLE with type t := t end diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index c8a44253..57713e3e 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -29,7 +29,8 @@ type target_scope_vars = type ctx = { decl_ctx : decl_ctx; scope_var_mapping : target_scope_vars ScopeVar.Map.t; - var_mapping : (Desugared.Ast.expr, untyped Ast.expr Var.t) Var.Map.t; + var_mapping : (D.expr, untyped Ast.expr Var.t) Var.Map.t; + modules : ctx ModuleName.Map.t; } let tag_with_log_entry @@ -42,8 +43,7 @@ let tag_with_log_entry [e] (Mark.get e) else e -let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : - untyped Ast.expr boxed = +let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed = let m = Mark.get e in match Mark.remove e with | EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m @@ -57,28 +57,43 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : ctx (Array.to_list vars) (Array.to_list new_vars) in Expr.eabs (Expr.bind new_vars (translate_expr ctx body)) tys m - | ELocation (SubScopeVar (s_name, ss_name, s_var)) -> + | ELocation (SubScopeVar { scope; alias; var }) -> (* When referring to a subscope variable in an expression, we are referring to the output, hence we take the last state. *) - let new_s_var = - match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with - | WholeVar new_s_var -> Mark.copy s_var new_s_var - | States states -> Mark.copy s_var (snd (List.hd (List.rev states))) + let ctx = + List.fold_left + (fun ctx m -> ModuleName.Map.find m ctx.modules) + ctx (ScopeName.path scope) in - Expr.elocation (SubScopeVar (s_name, ss_name, new_s_var)) m - | ELocation (DesugaredScopeVar (s_var, None)) -> + let var = + match ScopeVar.Map.find (Mark.remove var) ctx.scope_var_mapping with + | WholeVar new_s_var -> Mark.copy var new_s_var + | States states -> Mark.copy var (snd (List.hd (List.rev states))) + in + Expr.elocation (SubScopeVar { scope; alias; var }) m + | ELocation (DesugaredScopeVar { name; state = None }) -> Expr.elocation (ScopelangScopeVar - (match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with - | WholeVar new_s_var -> Mark.copy s_var new_s_var - | States _ -> failwith "should not happen")) + { + name = + (match + ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping + with + | WholeVar new_s_var -> Mark.copy name new_s_var + | States _ -> failwith "should not happen"); + }) m - | ELocation (DesugaredScopeVar (s_var, Some state)) -> + | ELocation (DesugaredScopeVar { name; state = Some state }) -> Expr.elocation (ScopelangScopeVar - (match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with - | WholeVar _ -> failwith "should not happen" - | States states -> Mark.copy s_var (List.assoc state states))) + { + name = + (match + ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping + with + | WholeVar _ -> failwith "should not happen" + | States states -> Mark.copy name (List.assoc state states)); + }) m | ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m | EDStructAccess { name_opt = None; _ } -> @@ -93,29 +108,30 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : try StructName.Map.find name (Ident.Map.find field ctx.decl_ctx.ctx_struct_fields) - with Not_found -> + with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> (* Should not happen after disambiguation *) Message.raise_spanned_error (Expr.mark_pos m) "Field @{\"%s\"@} does not belong to structure \ @{\"%a\"@}" field StructName.format name in - Expr.estructaccess e' field name m + Expr.estructaccess ~e:e' ~field ~name m | EScopeCall { scope; args } -> - Expr.escopecall scope - (ScopeVar.Map.fold - (fun v e args' -> - let v' = - match ScopeVar.Map.find v ctx.scope_var_mapping with - | WholeVar v' -> v' - | States ((_, v') :: _) -> - (* When there are multiple states, the input is always the first - one *) - v' - | States [] -> assert false - in - ScopeVar.Map.add v' (translate_expr ctx e) args') - args ScopeVar.Map.empty) + Expr.escopecall ~scope + ~args: + (ScopeVar.Map.fold + (fun v e args' -> + let v' = + match ScopeVar.Map.find v ctx.scope_var_mapping with + | WholeVar v' -> v' + | States ((_, v') :: _) -> + (* When there are multiple states, the input is always the + first one *) + v' + | States [] -> assert false + in + ScopeVar.Map.add v' (translate_expr ctx e) args') + args ScopeVar.Map.empty) m | EApp { f = EOp { op; tys }, m1; args } -> let args = List.map (translate_expr ctx) args in @@ -132,7 +148,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : | EOp _ -> assert false (* Only allowed within [EApp] *) | ( EStruct _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | ELit _ | EApp _ | EDefault _ | EIfThenElse _ | EArray _ | EEmptyError - | EErrorOnEmpty _ | EExternal _ ) as e -> + | EErrorOnEmpty _ ) as e -> Expr.map ~f:(translate_expr ctx) (e, m) (** {1 Rule tree construction} *) @@ -140,31 +156,29 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : (** Intermediate representation for the exception tree of rules for a particular scope definition. *) type rule_tree = - | Leaf of Desugared.Ast.rule list + | Leaf of D.rule list (** Rules defining a base case piecewise. List is non-empty. *) - | Node of rule_tree list * Desugared.Ast.rule list + | Node of rule_tree list * D.rule list (** [Node (exceptions, base_case)] is a list of exceptions to a non-empty list of rules defining a base case piecewise. *) (** Transforms a flat list of rules into a tree, taking into account the priorities declared between rules *) let def_to_exception_graph - (def_info : Desugared.Ast.ScopeDef.t) - (def : Desugared.Ast.rule RuleName.Map.t) : + (def_info : D.ScopeDef.t) + (def : D.rule RuleName.Map.t) : Desugared.Dependency.ExceptionsDependencies.t = let exc_graph = Desugared.Dependency.build_exceptions_graph def def_info in Desugared.Dependency.check_for_exception_cycle def exc_graph; exc_graph -let rule_to_exception_graph (scope : Desugared.Ast.scope) = function +let rule_to_exception_graph (scope : D.scope) = function | Desugared.Dependency.Vertex.Var (var, state) -> ( let scope_def = - Desugared.Ast.ScopeDef.Map.find - (Desugared.Ast.ScopeDef.Var (var, state)) - scope.scope_defs + D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs in let var_def = scope_def.D.scope_def_rules in - match Mark.remove scope_def.Desugared.Ast.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) -> (* If the variable is tagged as input, then it shall not be redefined. *) Message.raise_multispanned_error @@ -176,49 +190,43 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function (RuleName.Map.keys var_def)) "It is impossible to give a definition to a scope variable tagged as \ input." - | OnlyInput -> Desugared.Ast.ScopeDef.Map.empty + | OnlyInput -> D.ScopeDef.Map.empty (* we do not provide any definition for an input-only variable *) | _ -> - Desugared.Ast.ScopeDef.Map.singleton - (Desugared.Ast.ScopeDef.Var (var, state)) - (def_to_exception_graph - (Desugared.Ast.ScopeDef.Var (var, state)) - var_def)) + D.ScopeDef.Map.singleton + (D.ScopeDef.Var (var, state)) + (def_to_exception_graph (D.ScopeDef.Var (var, state)) var_def)) | Desugared.Dependency.Vertex.SubScope sub_scope_index -> (* Before calling the sub_scope, we need to include all the re-definitions of subscope parameters*) let sub_scope_vars_redefs_candidates = - Desugared.Ast.ScopeDef.Map.filter + D.ScopeDef.Map.filter (fun def_key scope_def -> match def_key with - | Desugared.Ast.ScopeDef.Var _ -> false - | Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_index', _, _) -> + | D.ScopeDef.Var _ -> false + | D.ScopeDef.SubScopeVar (sub_scope_index', _, _) -> sub_scope_index = sub_scope_index' (* We exclude subscope variables that have 0 re-definitions and are not visible in the input of the subscope *) && not - ((match - Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input - with + ((match Mark.remove scope_def.D.scope_def_io.io_input with | NoInput -> true | _ -> false) && RuleName.Map.is_empty scope_def.scope_def_rules)) scope.scope_defs in let sub_scope_vars_redefs = - Desugared.Ast.ScopeDef.Map.mapi + D.ScopeDef.Map.mapi (fun def_key scope_def -> - let def = scope_def.Desugared.Ast.scope_def_rules in + let def = scope_def.D.scope_def_rules in let is_cond = scope_def.scope_def_is_condition in match def_key with - | Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *) - | Desugared.Ast.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) -> + | D.ScopeDef.Var _ -> assert false (* should not happen *) + | D.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) -> (* This definition redefines a variable of the correct subscope. But we have to check that this redefinition is allowed with respect to the io parameters of that subscope variable. *) - (match - Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input - with + (match Mark.remove scope_def.D.scope_def_io.io_input with | NoInput -> Message.raise_multispanned_error (( Some "Incriminated subscope:", @@ -245,23 +253,21 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function was provided." | _ -> ()); let exc_graph = def_to_exception_graph def_key def in - let var_pos = Desugared.Ast.ScopeDef.get_position def_key in + let var_pos = D.ScopeDef.get_position def_key in exc_graph, sub_scope_var, var_pos) sub_scope_vars_redefs_candidates in List.fold_left (fun exc_graphs (new_exc_graph, subscope_var, var_pos) -> - Desugared.Ast.ScopeDef.Map.add - (Desugared.Ast.ScopeDef.SubScopeVar - (sub_scope_index, subscope_var, var_pos)) + D.ScopeDef.Map.add + (D.ScopeDef.SubScopeVar (sub_scope_index, subscope_var, var_pos)) new_exc_graph exc_graphs) - Desugared.Ast.ScopeDef.Map.empty - (Desugared.Ast.ScopeDef.Map.values sub_scope_vars_redefs) - | Assertion _ -> - Desugared.Ast.ScopeDef.Map.empty (* no exceptions for assertions *) + D.ScopeDef.Map.empty + (D.ScopeDef.Map.values sub_scope_vars_redefs) + | Assertion _ -> D.ScopeDef.Map.empty (* no exceptions for assertions *) -let scope_to_exception_graphs (scope : Desugared.Ast.scope) : - Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t = +let scope_to_exception_graphs (scope : D.scope) : + Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t = let scope_dependencies = Desugared.Dependency.build_scope_dependencies scope in @@ -272,25 +278,25 @@ let scope_to_exception_graphs (scope : Desugared.Ast.scope) : List.fold_left (fun exceptions_graphs scope_def_key -> let new_exceptions_graphs = rule_to_exception_graph scope scope_def_key in - Desugared.Ast.ScopeDef.Map.union + D.ScopeDef.Map.union (fun _ _ _ -> assert false (* there should not be key conflicts *)) new_exceptions_graphs exceptions_graphs) - Desugared.Ast.ScopeDef.Map.empty scope_ordering + D.ScopeDef.Map.empty scope_ordering -let build_exceptions_graph (pgrm : Desugared.Ast.program) : - Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t = +let build_exceptions_graph (pgrm : D.program) : + Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t = ScopeName.Map.fold (fun _ scope exceptions_graph -> let new_exceptions_graphs = scope_to_exception_graphs scope in - Desugared.Ast.ScopeDef.Map.union + D.ScopeDef.Map.union (fun _ _ _ -> assert false (* key conflicts should not happen*)) new_exceptions_graphs exceptions_graph) - pgrm.program_scopes Desugared.Ast.ScopeDef.Map.empty + pgrm.program_scopes D.ScopeDef.Map.empty (** Transforms a flat list of rules into a tree, taking into account the priorities declared between rules *) let def_map_to_tree - (def : Desugared.Ast.rule RuleName.Map.t) + (def : D.rule RuleName.Map.t) (exc_graph : Desugared.Dependency.ExceptionsDependencies.t) : rule_tree list = (* we start by the base cases: they are the vertices which have no @@ -328,7 +334,7 @@ let rec rule_tree_to_expr ~(is_reentrant_var : bool) (ctx : ctx) (def_pos : Pos.t) - (params : Desugared.Ast.expr Var.t list option) + (params : D.expr Var.t list option) (tree : rule_tree) : untyped Ast.expr boxed = let emark = Untyped { pos = def_pos } in let exceptions, base_rules = @@ -337,10 +343,8 @@ let rec rule_tree_to_expr (* because each rule has its own variables parameters and we want to convert the whole rule tree into a function, we need to perform some alpha-renaming of all the expressions *) - let substitute_parameter - (e : Desugared.Ast.expr boxed) - (rule : Desugared.Ast.rule) : Desugared.Ast.expr boxed = - match params, rule.Desugared.Ast.rule_parameter with + let substitute_parameter (e : D.expr boxed) (rule : D.rule) : D.expr boxed = + match params, rule.D.rule_parameter with | Some new_params, Some (old_params_with_types, _) -> let old_params, _ = List.split old_params_with_types in let old_params = Array.of_list (List.map Mark.remove old_params) in @@ -376,16 +380,12 @@ let rec rule_tree_to_expr ctx) in let base_just_list = - List.map - (fun rule -> substitute_parameter rule.Desugared.Ast.rule_just rule) - base_rules + List.map (fun rule -> substitute_parameter rule.D.rule_just rule) base_rules in let base_cons_list = - List.map - (fun rule -> substitute_parameter rule.Desugared.Ast.rule_cons rule) - base_rules + List.map (fun rule -> substitute_parameter rule.D.rule_cons rule) base_rules in - let translate_and_unbox_list (list : Desugared.Ast.expr boxed list) : + let translate_and_unbox_list (list : D.expr boxed list) : untyped Ast.expr boxed list = List.map (fun e -> @@ -419,7 +419,7 @@ let rec rule_tree_to_expr (Expr.elit (LBool true) emark) default_containing_base_cases emark in - match params, (List.hd base_rules).Desugared.Ast.rule_parameter with + match params, (List.hd base_rules).D.rule_parameter with | None, None -> default | Some new_params, Some (ls, _) -> let _, tys = List.split ls in @@ -449,34 +449,27 @@ let translate_def ~(is_cond : bool) ~(is_subscope_var : bool) (ctx : ctx) - (def_info : Desugared.Ast.ScopeDef.t) - (def : Desugared.Ast.rule RuleName.Map.t) + (def_info : D.ScopeDef.t) + (def : D.rule RuleName.Map.t) (params : (Uid.MarkedString.info * typ) list Mark.pos option) (typ : typ) - (io : Desugared.Ast.io) + (io : D.io) (exc_graph : Desugared.Dependency.ExceptionsDependencies.t) : untyped Ast.expr boxed = (* Here, we have to transform this list of rules into a default tree. *) let top_list = def_map_to_tree def exc_graph in let is_input = - match Mark.remove io.Desugared.Ast.io_input with - | OnlyInput -> true - | _ -> false + match Mark.remove io.D.io_input with OnlyInput -> true | _ -> false in let is_reentrant = - match Mark.remove io.Desugared.Ast.io_input with - | Reentrant -> true - | _ -> false + match Mark.remove io.D.io_input with Reentrant -> true | _ -> false in - let top_value : Desugared.Ast.rule option = + let top_value : D.rule option = if is_cond && ((not is_subscope_var) || (is_subscope_var && is_input)) then (* We add the bottom [false] value for conditions, only for the scope where the condition is declared. Except when the variable is an input, where we want the [false] to be added at each caller parent scope. *) - Some - (Desugared.Ast.always_false_rule - (Desugared.Ast.ScopeDef.get_position def_info) - params) + Some (D.always_false_rule (D.ScopeDef.get_position def_info) params) else None in if @@ -505,7 +498,7 @@ let translate_def will not be provided by the calee scope, it has to be placed in the caller. *) then - let m = Untyped { pos = Desugared.Ast.ScopeDef.get_position def_info } in + let m = Untyped { pos = D.ScopeDef.get_position def_info } in let empty_error = Expr.eemptyerror m in match params with | Some (ps, _) -> @@ -517,7 +510,7 @@ let translate_def | _ -> empty_error else rule_tree_to_expr ~toplevel:true ~is_reentrant_var:is_reentrant ctx - (Desugared.Ast.ScopeDef.get_position def_info) + (D.ScopeDef.get_position def_info) (Option.map (fun (ps, _) -> (List.map (fun (lbl, _) -> Var.make (Mark.remove lbl))) ps) @@ -526,7 +519,7 @@ let translate_def | [], None -> (* In this case, there are no rules to define the expression and no default value so we put an empty rule. *) - Leaf [Desugared.Ast.empty_rule (Mark.get typ) params] + Leaf [D.empty_rule (Mark.get typ) params] | [], Some top_value -> (* In this case, there are no rules to define the expression but a default value so we put it. *) @@ -536,36 +529,32 @@ let translate_def exceptions to the default value *) Node (top_list, [top_value]) | [top_tree], None -> top_tree - | _, None -> - Node (top_list, [Desugared.Ast.empty_rule (Mark.get typ) params])) + | _, None -> Node (top_list, [D.empty_rule (Mark.get typ) params])) let translate_rule ctx - (scope : Desugared.Ast.scope) + (scope : D.scope) (exc_graphs : - Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t) - = function + Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) = function | Desugared.Dependency.Vertex.Var (var, state) -> ( let scope_def = - Desugared.Ast.ScopeDef.Map.find - (Desugared.Ast.ScopeDef.Var (var, state)) - scope.scope_defs + D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs in let var_def = scope_def.D.scope_def_rules in let var_params = scope_def.D.scope_def_parameters in let var_typ = scope_def.D.scope_def_typ in let is_cond = scope_def.D.scope_def_is_condition in - match Mark.remove scope_def.Desugared.Ast.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) -> assert false (* error already raised *) | OnlyInput -> [] (* we do not provide any definition for an input-only variable *) | _ -> - let scope_def_key = Desugared.Ast.ScopeDef.Var (var, state) in + let scope_def_key = D.ScopeDef.Var (var, state) in let expr_def = translate_def ctx scope_def_key var_def var_params var_typ - scope_def.Desugared.Ast.scope_def_io - (Desugared.Ast.ScopeDef.Map.find scope_def_key exc_graphs) + scope_def.D.scope_def_io + (D.ScopeDef.Map.find scope_def_key exc_graphs) ~is_cond ~is_subscope_var:false in let scope_var = @@ -577,10 +566,10 @@ let translate_rule [ Ast.Definition ( ( ScopelangScopeVar - (scope_var, Mark.get (ScopeVar.get_info scope_var)), + { name = scope_var, Mark.get (ScopeVar.get_info scope_var) }, Mark.get (ScopeVar.get_info scope_var) ), var_typ, - scope_def.Desugared.Ast.scope_def_io, + scope_def.D.scope_def_io, Expr.unbox expr_def ); ]) | Desugared.Dependency.Vertex.SubScope sub_scope_index -> @@ -590,38 +579,34 @@ let translate_rule SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes in let sub_scope_vars_redefs_candidates = - Desugared.Ast.ScopeDef.Map.filter + D.ScopeDef.Map.filter (fun def_key scope_def -> match def_key with - | Desugared.Ast.ScopeDef.Var _ -> false - | Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_index', _, _) -> + | D.ScopeDef.Var _ -> false + | D.ScopeDef.SubScopeVar (sub_scope_index', _, _) -> sub_scope_index = sub_scope_index' (* We exclude subscope variables that have 0 re-definitions and are not visible in the input of the subscope *) && not - ((match - Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input - with + ((match Mark.remove scope_def.D.scope_def_io.io_input with | NoInput -> true | _ -> false) && RuleName.Map.is_empty scope_def.scope_def_rules)) scope.scope_defs in let sub_scope_vars_redefs = - Desugared.Ast.ScopeDef.Map.mapi + D.ScopeDef.Map.mapi (fun def_key scope_def -> - let def = scope_def.Desugared.Ast.scope_def_rules in + let def = scope_def.D.scope_def_rules in let def_typ = scope_def.scope_def_typ in let is_cond = scope_def.scope_def_is_condition in match def_key with - | Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *) - | Desugared.Ast.ScopeDef.SubScopeVar (_, sub_scope_var, var_pos) -> + | D.ScopeDef.Var _ -> assert false (* should not happen *) + | D.ScopeDef.SubScopeVar (_, sub_scope_var, var_pos) -> (* This definition redefines a variable of the correct subscope. But we have to check that this redefinition is allowed with respect to the io parameters of that subscope variable. *) - (match - Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input - with + (match Mark.remove scope_def.D.scope_def_io.io_input with | NoInput -> assert false (* error already raised *) | OnlyInput when RuleName.Map.is_empty def && not is_cond -> assert false (* error already raised *) @@ -630,8 +615,8 @@ let translate_rule redefinition to a proper Scopelang term. *) let expr_def = translate_def ctx def_key def scope_def.D.scope_def_parameters - def_typ scope_def.Desugared.Ast.scope_def_io - (Desugared.Ast.ScopeDef.Map.find def_key exc_graphs) + def_typ scope_def.D.scope_def_io + (D.ScopeDef.Map.find def_key exc_graphs) ~is_cond ~is_subscope_var:true in let subscop_real_name = @@ -639,25 +624,26 @@ let translate_rule in Ast.Definition ( ( SubScopeVar - ( subscop_real_name, - (sub_scope_index, var_pos), - match - ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping - with - | WholeVar v -> v, var_pos - | States states -> - (* When defining a sub-scope variable, we always define - its first state in the sub-scope. *) - snd (List.hd states), var_pos ), + { + scope = subscop_real_name; + alias = sub_scope_index, var_pos; + var = + (match + ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping + with + | WholeVar v -> v, var_pos + | States states -> + (* When defining a sub-scope variable, we always + define its first state in the sub-scope. *) + snd (List.hd states), var_pos); + }, var_pos ), def_typ, - scope_def.Desugared.Ast.scope_def_io, + scope_def.D.scope_def_io, Expr.unbox expr_def )) sub_scope_vars_redefs_candidates in - let sub_scope_vars_redefs = - Desugared.Ast.ScopeDef.Map.values sub_scope_vars_redefs - in + let sub_scope_vars_redefs = D.ScopeDef.Map.values sub_scope_vars_redefs in sub_scope_vars_redefs @ [ Ast.Call @@ -668,43 +654,21 @@ let translate_rule ] | Assertion a_name -> let assertion_expr = - Desugared.Ast.AssertionName.Map.find a_name scope.scope_assertions + D.AssertionName.Map.find a_name scope.scope_assertions in (* we unbox here because assertions do not have free variables (at this point Bindlib variables are only for fuhnction parameters)*) let assertion_expr = translate_expr ctx (Expr.unbox assertion_expr) in [Ast.Assertion (Expr.unbox assertion_expr)] -(** Translates a scope *) -let translate_scope - (ctx : ctx) - (scope : Desugared.Ast.scope) - (exc_graphs : - Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t) - : untyped Ast.scope_decl = - let scope_dependencies = - Desugared.Dependency.build_scope_dependencies scope - in - Desugared.Dependency.check_for_cycle scope scope_dependencies; - let scope_ordering = - Desugared.Dependency.correct_computation_ordering scope_dependencies - in - let scope_decl_rules = - List.fold_left - (fun scope_decl_rules scope_def_key -> - let new_rules = translate_rule ctx scope exc_graphs scope_def_key in - scope_decl_rules @ new_rules) - [] scope_ordering - in +let translate_scope_interface ctx scope = let scope_sig = ScopeVar.Map.fold - (fun var (states : Desugared.Ast.var_or_states) acc -> + (fun var (states : D.var_or_states) acc -> match states with | WholeVar -> let scope_def = - Desugared.Ast.ScopeDef.Map.find - (Desugared.Ast.ScopeDef.Var (var, None)) - scope.scope_defs + D.ScopeDef.Map.find (D.ScopeDef.Var (var, None)) scope.D.scope_defs in let typ = scope_def.scope_def_typ in ScopeVar.Map.add @@ -720,9 +684,9 @@ let translate_scope List.fold_left (fun acc (state : StateName.t) -> let scope_def = - Desugared.Ast.ScopeDef.Map.find - (Desugared.Ast.ScopeDef.Var (var, Some state)) - scope.scope_defs + D.ScopeDef.Map.find + (D.ScopeDef.Var (var, Some state)) + scope.D.scope_defs in ScopeVar.Map.add (match ScopeVar.Map.find var ctx.scope_var_mapping with @@ -734,36 +698,59 @@ let translate_scope scope.scope_vars ScopeVar.Map.empty in let pos = Mark.get (ScopeName.get_info scope.scope_uid) in - { - Ast.scope_decl_name = scope.scope_uid; - Ast.scope_decl_rules; - Ast.scope_sig; - Ast.scope_mark = Untyped { pos }; - Ast.scope_options = scope.scope_options; - } + Mark.add pos + { + Ast.scope_decl_name = scope.scope_uid; + Ast.scope_decl_rules = []; + Ast.scope_sig; + Ast.scope_options = scope.scope_options; + } + +let translate_scope + (ctx : ctx) + (exc_graphs : + Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) + (scope : D.scope) : untyped Ast.scope_decl Mark.pos = + let scope_dependencies = + Desugared.Dependency.build_scope_dependencies scope + in + Desugared.Dependency.check_for_cycle scope scope_dependencies; + let scope_ordering = + Desugared.Dependency.correct_computation_ordering scope_dependencies + in + let scope_decl_rules = + List.fold_left + (fun scope_decl_rules scope_def_key -> + let new_rules = translate_rule ctx scope exc_graphs scope_def_key in + scope_decl_rules @ new_rules) + [] scope_ordering + in + Mark.map + (fun s -> { s with Ast.scope_decl_rules }) + (translate_scope_interface ctx scope) (** {1 API} *) let translate_program - (pgrm : Desugared.Ast.program) + (desugared : D.program) (exc_graphs : - Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t) - : untyped Ast.program = + Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) : + untyped Ast.program = (* First we give mappings to all the locations between Desugared and This involves creating a new Scopelang scope variable for every state of a Desugared variable. *) - let ctx = + let rec make_ctx desugared = + let modules = ModuleName.Map.map make_ctx desugared.D.program_modules in (* Todo: since we rename all scope vars at this point, it would be better to have different types for Desugared.ScopeVar.t and Scopelang.ScopeVar.t *) ScopeName.Map.fold (fun _scope scope_decl ctx -> ScopeVar.Map.fold - (fun scope_var (states : Desugared.Ast.var_or_states) ctx -> + (fun scope_var (states : D.var_or_states) ctx -> let var_name, var_pos = ScopeVar.get_info scope_var in let new_var = match states with - | Desugared.Ast.WholeVar -> - WholeVar (ScopeVar.fresh (var_name, var_pos)) + | D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos)) | States states -> let var_prefix = var_name ^ "_" in let state_var state = @@ -777,38 +764,78 @@ let translate_program scope_var_mapping = ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping; }) - scope_decl.Desugared.Ast.scope_vars ctx) - pgrm.Desugared.Ast.program_scopes + scope_decl.D.scope_vars ctx) + desugared.D.program_scopes { scope_var_mapping = ScopeVar.Map.empty; var_mapping = Var.Map.empty; - decl_ctx = pgrm.program_ctx; + decl_ctx = desugared.program_ctx; + modules; } in - let ctx_scopes = - ScopeName.Map.map - (fun out_str -> - let out_struct_fields = - ScopeVar.Map.fold - (fun var fld out_map -> - let var' = - match ScopeVar.Map.find var ctx.scope_var_mapping with - | WholeVar v -> v - | States l -> snd (List.hd (List.rev l)) - in - ScopeVar.Map.add var' fld out_map) - out_str.out_struct_fields ScopeVar.Map.empty - in - { out_str with out_struct_fields }) - pgrm.Desugared.Ast.program_ctx.ctx_scopes + let ctx = make_ctx desugared in + let rec gather_scope_vars acc modules = + ModuleName.Map.fold + (fun _modname mctx acc -> + let acc = gather_scope_vars acc mctx.modules in + ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.scope_var_mapping) + modules acc in - let program_scopes = - ScopeName.Map.fold - (fun scope_name scope new_program_scopes -> - let new_program_scope = translate_scope ctx scope exc_graphs in - ScopeName.Map.add scope_name new_program_scope new_program_scopes) - pgrm.program_scopes ScopeName.Map.empty + let ctx = + { + ctx with + scope_var_mapping = gather_scope_vars ctx.scope_var_mapping ctx.modules; + } in + let rec process_decl_ctx ctx decl_ctx = + let ctx_scopes = + ScopeName.Map.map + (fun out_str -> + let out_struct_fields = + ScopeVar.Map.fold + (fun var fld out_map -> + let var' = + match ScopeVar.Map.find var ctx.scope_var_mapping with + | WholeVar v -> v + | States l -> snd (List.hd (List.rev l)) + in + ScopeVar.Map.add var' fld out_map) + out_str.out_struct_fields ScopeVar.Map.empty + in + { out_str with out_struct_fields }) + decl_ctx.ctx_scopes + in + { + decl_ctx with + ctx_modules = + ModuleName.Map.mapi + (fun modname decl_ctx -> + let ctx = ModuleName.Map.find modname ctx.modules in + process_decl_ctx ctx decl_ctx) + decl_ctx.ctx_modules; + ctx_scopes; + } + in + let rec process_modules program_ctx desugared = + ModuleName.Map.mapi + (fun modname m_desugared -> + let ctx = ModuleName.Map.find modname ctx.modules in + { + Ast.program_topdefs = TopdefName.Map.empty; + program_scopes = + ScopeName.Map.map + (translate_scope_interface ctx) + m_desugared.D.program_scopes; + program_ctx = ModuleName.Map.find modname program_ctx.ctx_modules; + program_modules = + process_modules + (ModuleName.Map.find modname program_ctx.ctx_modules) + m_desugared; + }) + desugared.D.program_modules + in + let program_ctx = process_decl_ctx ctx desugared.D.program_ctx in + let program_modules = process_modules program_ctx desugared in let program_topdefs = TopdefName.Map.mapi (fun id -> function @@ -816,10 +843,16 @@ let translate_program | None, (_, pos) -> Message.raise_spanned_error pos "No definition found for %a" TopdefName.format id) - pgrm.program_topdefs + desugared.program_topdefs + in + let program_scopes = + ScopeName.Map.map + (translate_scope ctx exc_graphs) + desugared.D.program_scopes in { Ast.program_topdefs; - program_scopes; - program_ctx = { pgrm.program_ctx with ctx_scopes }; + Ast.program_scopes; + Ast.program_ctx; + Ast.program_modules; } diff --git a/compiler/scopelang/print.ml b/compiler/scopelang/print.ml index 90bd3973..6c6e3daa 100644 --- a/compiler/scopelang/print.ml +++ b/compiler/scopelang/print.ml @@ -48,7 +48,7 @@ let enum (Print.typ ctx) typ)) (EnumConstructor.Map.bindings cases) -let scope ?debug ctx fmt (name, decl) = +let scope ?debug ctx fmt (name, (decl, _pos)) = Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@]@\n@[ %a@]" Print.keyword "let" Print.keyword "scope" ScopeName.format name (Format.pp_print_list ~pp_sep:Format.pp_print_space @@ -78,7 +78,7 @@ let scope ?debug ctx fmt (name, decl) = (fun fmt e -> match Mark.remove loc with | SubScopeVar _ | ToplevelVar _ -> Print.expr () fmt e - | ScopelangScopeVar v -> ( + | ScopelangScopeVar { name = v } -> ( match Mark.remove (snd (ScopeVar.Map.find (Mark.remove v) decl.scope_sig)) diff --git a/compiler/scopelang/print.mli b/compiler/scopelang/print.mli index 4ec2f4fe..eb1767ea 100644 --- a/compiler/scopelang/print.mli +++ b/compiler/scopelang/print.mli @@ -14,11 +14,13 @@ License for the specific language governing permissions and limitations under the License. *) +open Catala_utils + val scope : ?debug:bool (** [true] for debug printing *) -> Shared_ast.decl_ctx -> Format.formatter -> - Shared_ast.ScopeName.t * 'm Ast.scope_decl -> + Shared_ast.ScopeName.t * 'm Ast.scope_decl Mark.pos -> unit val program : diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 26471432..ce0b84a2 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -22,11 +22,12 @@ open Catala_utils module Runtime = Runtime_ocaml.Runtime -module ScopeName = Uid.Gen () -module TopdefName = Uid.Gen () -module StructName = Uid.Gen () +module ModuleName = Uid.Module +module ScopeName = Uid.Gen_qualified () +module TopdefName = Uid.Gen_qualified () +module StructName = Uid.Gen_qualified () module StructField = Uid.Gen () -module EnumName = Uid.Gen () +module EnumName = Uid.Gen_qualified () module EnumConstructor = Uid.Gen () (** Only used by surface *) @@ -312,6 +313,10 @@ type untyped = { pos : Pos.t } [@@caml.unboxed] type typed = { pos : Pos.t; ty : typ } type 'a custom = { pos : Pos.t; custom : 'a } +(** Using empty markings will ensure terms can't be constructed: used for + example in interfaces to ensure that they don't contain any expressions *) +type nil = | + (** The generic type of AST markings. Using a GADT allows functions to be polymorphic in the marking, but still do transformations on types when appropriate. The [Custom] case can be used within passes that need to store @@ -339,19 +344,32 @@ type lit = | LDate of date | LDuration of duration +(** External references are resolved to strings that point to functions or + constants in the end, but we need to keep different references for typing *) +type external_ref = + | External_value of TopdefName.t + | External_scope of ScopeName.t + (** Locations are handled differently in [desugared] and [scopelang] *) type 'a glocation = - | DesugaredScopeVar : - ScopeVar.t Mark.pos * StateName.t option + | DesugaredScopeVar : { + name : ScopeVar.t Mark.pos; + state : StateName.t option; + } -> < scopeVarStates : yes ; .. > glocation - | ScopelangScopeVar : - ScopeVar.t Mark.pos + | ScopelangScopeVar : { + name : ScopeVar.t Mark.pos; + } -> < scopeVarSimpl : yes ; .. > glocation - | SubScopeVar : - ScopeName.t * SubScopeName.t Mark.pos * ScopeVar.t Mark.pos + | SubScopeVar : { + scope : ScopeName.t; + alias : SubScopeName.t Mark.pos; + var : ScopeVar.t Mark.pos; + } -> < explicitScopes : yes ; .. > glocation - | ToplevelVar : - TopdefName.t Mark.pos + | ToplevelVar : { + name : TopdefName.t Mark.pos; + } -> < explicitScopes : yes ; .. > glocation type ('a, 'm) gexpr = (('a, 'm) naked_gexpr, 'm) marked @@ -392,7 +410,6 @@ and ('a, 'b, 'm) base_gexpr = -> ('a, (< .. > as 'b), 'm) base_gexpr | EArray : ('a, 'm) gexpr list -> ('a, < .. >, 'm) base_gexpr | EVar : ('a, 'm) naked_gexpr Bindlib.var -> ('a, _, 'm) base_gexpr - | EExternal : Qident.t -> ('a, < .. >, 't) base_gexpr | EAbs : { binder : (('a, 'a, 'm) base_gexpr, ('a, 'm) gexpr) Bindlib.mbinder; tys : typ list; @@ -450,6 +467,10 @@ and ('a, 'b, 'm) base_gexpr = -> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr (** Resolved struct/enums, after [desugared] *) (* Lambda-like *) + | EExternal : { + name : external_ref Mark.pos; + } + -> ('a, < explicitScopes : no ; .. >, 't) base_gexpr | EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr (* Default terms *) | EDefault : { @@ -565,7 +586,8 @@ type 'e code_item_list = type struct_ctx = typ StructField.Map.t StructName.Map.t type enum_ctx = typ EnumConstructor.Map.t EnumName.Map.t -type scope_out_struct = { +type scope_info = { + in_struct_name : StructName.t; out_struct_name : StructName.t; out_struct_fields : StructField.t ScopeVar.Map.t; } @@ -575,8 +597,9 @@ type decl_ctx = { ctx_structs : struct_ctx; ctx_struct_fields : StructField.t StructName.Map.t Ident.Map.t; (** needed for disambiguation (desugared -> scope) *) - ctx_scopes : scope_out_struct ScopeName.Map.t; - ctx_modules : typ Qident.Map.t; + ctx_scopes : scope_info ScopeName.Map.t; + ctx_topdefs : typ TopdefName.Map.t; + ctx_modules : decl_ctx ModuleName.Map.t; } type 'e program = { decl_ctx : decl_ctx; code_items : 'e code_item_list } diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 59067d74..51490cbb 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -109,7 +109,7 @@ let subst binder vars = Bindlib.msubst binder (Array.of_list (List.map Mark.remove vars)) let evar v mark = Mark.add mark (Bindlib.box_var v) -let eexternal eref mark = Mark.add mark (Bindlib.box (EExternal eref)) +let eexternal ~name mark = Mark.add mark (Bindlib.box (EExternal { name })) let etuple args = Box.appn args @@ fun args -> ETuple args let etupleaccess e index size = @@ -146,28 +146,28 @@ let ecustom obj targs tret mark = let elocation loc = Box.app0 @@ ELocation loc -let estruct name (fields : ('a, 't) boxed_gexpr StructField.Map.t) mark = +let estruct ~name ~(fields : ('a, 't) boxed_gexpr StructField.Map.t) mark = Mark.add mark @@ Bindlib.box_apply (fun fields -> EStruct { name; fields }) (Box.lift_struct (StructField.Map.map Box.lift fields)) -let edstructaccess e field name_opt = - Box.app1 e @@ fun e -> EDStructAccess { name_opt; e; field } +let edstructaccess ~name_opt ~field ~e = + Box.app1 e @@ fun e -> EDStructAccess { name_opt; field; e } -let estructaccess e field name = - Box.app1 e @@ fun e -> EStructAccess { name; e; field } +let estructaccess ~name ~field ~e = + Box.app1 e @@ fun e -> EStructAccess { name; field; e } -let einj e cons name = Box.app1 e @@ fun e -> EInj { name; e; cons } +let einj ~name ~cons ~e = Box.app1 e @@ fun e -> EInj { name; cons; e } -let ematch e name cases mark = +let ematch ~name ~e ~cases mark = Mark.add mark @@ Bindlib.box_apply2 (fun e cases -> EMatch { name; e; cases }) (Box.lift e) (Box.lift_enum (EnumConstructor.Map.map Box.lift cases)) -let escopecall scope args mark = +let escopecall ~scope ~args mark = Mark.add mark @@ Bindlib.box_apply (fun args -> EScopeCall { scope; args }) @@ -250,7 +250,7 @@ let maybe_ty (type m) ?(typ = TAny) (m : m mark) : typ = (* - Predefined types (option) - *) -let option_enum = EnumName.fresh ("eoption", Pos.no_pos) +let option_enum = EnumName.fresh [] ("eoption", Pos.no_pos) let none_constr = EnumConstructor.fresh ("ENone", Pos.no_pos) let some_constr = EnumConstructor.fresh ("ESome", Pos.no_pos) @@ -272,7 +272,7 @@ let map | EOp { op; tys } -> eop op tys m | EArray args -> earray (List.map f args) m | EVar v -> evar (Var.translate v) m - | EExternal eref -> eexternal eref m + | EExternal { name } -> eexternal ~name m | EAbs { binder; tys } -> let vars, body = Bindlib.unmbind binder in let body = f body in @@ -282,7 +282,7 @@ let map eifthenelse (f cond) (f etrue) (f efalse) m | ETuple args -> etuple (List.map f args) m | ETupleAccess { e; index; size } -> etupleaccess (f e) index size m - | EInj { e; name; cons } -> einj (f e) cons name m + | EInj { name; cons; e } -> einj ~name ~cons ~e:(f e) m | EAssert e1 -> eassert (f e1) m | EDefault { excepts; just; cons } -> edefault (List.map f excepts) (f just) (f cons) m @@ -293,16 +293,16 @@ let map | ELocation loc -> elocation loc m | EStruct { name; fields } -> let fields = StructField.Map.map f fields in - estruct name fields m - | EDStructAccess { e; field; name_opt } -> - edstructaccess (f e) field name_opt m - | EStructAccess { e; field; name } -> estructaccess (f e) field name m - | EMatch { e; name; cases } -> + estruct ~name ~fields m + | EDStructAccess { name_opt; field; e } -> + edstructaccess ~name_opt ~field ~e:(f e) m + | EStructAccess { name; field; e } -> estructaccess ~name ~field ~e:(f e) m + | EMatch { name; e; cases } -> let cases = EnumConstructor.Map.map f cases in - ematch (f e) name cases m + ematch ~name ~e:(f e) ~cases m | EScopeCall { scope; args } -> - let fields = ScopeVar.Map.map f args in - escopecall scope fields m + let args = ScopeVar.Map.map f args in + escopecall ~scope ~args m | ECustom { obj; targs; tret } -> ecustom obj targs tret m let rec map_top_down ~f e = map ~f:(map_top_down ~f) (f e) @@ -369,7 +369,7 @@ let map_gather let acc, args = lfoldmap args in acc, earray args m | EVar v -> acc, evar (Var.translate v) m - | EExternal eref -> acc, eexternal eref m + | EExternal { name } -> acc, eexternal ~name m | EAbs { binder; tys } -> let vars, body = Bindlib.unmbind binder in let acc, body = f body in @@ -386,9 +386,9 @@ let map_gather | ETupleAccess { e; index; size } -> let acc, e = f e in acc, etupleaccess e index size m - | EInj { e; name; cons } -> + | EInj { name; cons; e } -> let acc, e = f e in - acc, einj e cons name m + acc, einj ~name ~cons ~e m | EAssert e -> let acc, e = f e in acc, eassert e m @@ -416,14 +416,14 @@ let map_gather fields (acc, StructField.Map.empty) in - acc, estruct name fields m - | EDStructAccess { e; field; name_opt } -> + acc, estruct ~name ~fields m + | EDStructAccess { name_opt; field; e } -> let acc, e = f e in - acc, edstructaccess e field name_opt m - | EStructAccess { e; field; name } -> + acc, edstructaccess ~name_opt ~field ~e m + | EStructAccess { name; field; e } -> let acc, e = f e in - acc, estructaccess e field name m - | EMatch { e; name; cases } -> + acc, estructaccess ~name ~field ~e m + | EMatch { name; e; cases } -> let acc, e = f e in let acc, cases = EnumConstructor.Map.fold @@ -433,7 +433,7 @@ let map_gather cases (acc, EnumConstructor.Map.empty) in - acc, ematch e name cases m + acc, ematch ~name ~e ~cases m | EScopeCall { scope; args } -> let acc, args = ScopeVar.Map.fold @@ -442,7 +442,7 @@ let map_gather join acc acc1, ScopeVar.Map.add var e args) args (acc, ScopeVar.Map.empty) in - acc, escopecall scope args m + acc, escopecall ~scope ~args m | ECustom { obj; targs; tret } -> acc, ecustom obj targs tret m (* - *) @@ -520,20 +520,25 @@ let compare_location (x : a glocation Mark.pos) (y : a glocation Mark.pos) = match Mark.remove x, Mark.remove y with - | DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, None) - | DesugaredScopeVar (vx, Some _), DesugaredScopeVar (vy, None) - | DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, Some _) -> + | ( DesugaredScopeVar { name = vx; state = None }, + DesugaredScopeVar { name = vy; state = None } ) + | ( DesugaredScopeVar { name = vx; state = Some _ }, + DesugaredScopeVar { name = vy; state = None } ) + | ( DesugaredScopeVar { name = vx; state = None }, + DesugaredScopeVar { name = vy; state = Some _ } ) -> ScopeVar.compare (Mark.remove vx) (Mark.remove vy) - | DesugaredScopeVar ((x, _), Some sx), DesugaredScopeVar ((y, _), Some sy) -> + | ( DesugaredScopeVar { name = x, _; state = Some sx }, + DesugaredScopeVar { name = y, _; state = Some sy } ) -> let cmp = ScopeVar.compare x y in if cmp = 0 then StateName.compare sx sy else cmp - | ScopelangScopeVar (vx, _), ScopelangScopeVar (vy, _) -> + | ScopelangScopeVar { name = vx, _ }, ScopelangScopeVar { name = vy, _ } -> ScopeVar.compare vx vy - | ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)), - SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) -> + | ( SubScopeVar { alias = xsubindex, _; var = xsubvar, _; _ }, + SubScopeVar { alias = ysubindex, _; var = ysubvar, _; _ } ) -> let c = SubScopeName.compare xsubindex ysubindex in if c = 0 then ScopeVar.compare xsubvar ysubvar else c - | ToplevelVar (vx, _), ToplevelVar (vy, _) -> TopdefName.compare vx vy + | ToplevelVar { name = vx, _ }, ToplevelVar { name = vy, _ } -> + TopdefName.compare vx vy | DesugaredScopeVar _, _ -> -1 | _, DesugaredScopeVar _ -> 1 | ScopelangScopeVar _, _ -> -1 @@ -547,17 +552,32 @@ let equal_location a b = compare_location a b = 0 let equal_except ex1 ex2 = ex1 = ex2 let compare_except ex1 ex2 = Stdlib.compare ex1 ex2 +let equal_external_ref ref1 ref2 = + match ref1, ref2 with + | External_value v1, External_value v2 -> TopdefName.equal v1 v2 + | External_scope s1, External_scope s2 -> ScopeName.equal s1 s2 + | (External_value _ | External_scope _), _ -> false + +let compare_external_ref ref1 ref2 = + match ref1, ref2 with + | External_value v1, External_value v2 -> TopdefName.compare v1 v2 + | External_scope s1, External_scope s2 -> ScopeName.compare s1 s2 + | External_value _, _ -> -1 + | _, External_value _ -> 1 + | External_scope _, _ -> . + | _, External_scope _ -> . + (* weird indentation; see https://github.com/ocaml-ppx/ocamlformat/issues/2143 *) let rec equal_list : 'a. ('a, 't) gexpr list -> ('a, 't) gexpr list -> bool = - fun es1 es2 -> - try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + fun es1 es2 -> List.equal equal es1 es2 and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = fun e1 e2 -> match Mark.remove e1, Mark.remove e2 with | EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2 - | EExternal eref1, EExternal eref2 -> Qident.equal eref1 eref2 + | EExternal { name = n1 }, EExternal { name = n2 } -> + Mark.equal equal_external_ref n1 n2 | ETuple es1, ETuple es2 -> equal_list es1 es2 | ( ETupleAccess { e = e1; index = id1; size = s1 }, ETupleAccess { e = e2; index = id2; size = s2 } ) -> @@ -635,8 +655,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = List.compare compare a1 a2 | EVar v1, EVar v2 -> Bindlib.compare_vars v1 v2 - | EExternal eref1, EExternal eref2 -> - Qident.compare eref1 eref2 + | EExternal { name = n1 }, EExternal { name = n2 } -> + Mark.compare compare_external_ref n1 n2 | EAbs {binder=binder1; tys=typs1}, EAbs {binder=binder2; tys=typs2} -> List.compare Type.compare typs1 typs2 @@< fun () -> @@ -649,8 +669,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = compare e1 e2 | ELocation l1, ELocation l2 -> compare_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2) - | EStruct {name=name1; fields=field_map1}, - EStruct {name=name2; fields=field_map2} -> + | EStruct {name=name1; fields=field_map1 }, + EStruct {name=name2; fields=field_map2 } -> StructName.compare name1 name2 @@< fun () -> StructField.Map.compare compare field_map1 field_map2 | EDStructAccess {e=e1; field=field_name1; name_opt=struct_name1}, @@ -658,13 +678,13 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = compare e1 e2 @@< fun () -> Ident.compare field_name1 field_name2 @@< fun () -> Option.compare StructName.compare struct_name1 struct_name2 - | EStructAccess {e=e1; field=field_name1; name=struct_name1}, - EStructAccess {e=e2; field=field_name2; name=struct_name2} -> + | EStructAccess {e=e1; field=field_name1; name=struct_name1 }, + EStructAccess {e=e2; field=field_name2; name=struct_name2 } -> compare e1 e2 @@< fun () -> StructField.compare field_name1 field_name2 @@< fun () -> StructName.compare struct_name1 struct_name2 - | EMatch {e=e1; name=name1; cases=emap1}, - EMatch {e=e2; name=name2; cases=emap2} -> + | EMatch {e=e1; name=name1; cases=emap1 }, + EMatch {e=e2; name=name2; cases=emap2 } -> EnumName.compare name1 name2 @@< fun () -> compare e1 e2 @@< fun () -> EnumConstructor.Map.compare compare emap1 emap2 @@ -679,8 +699,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = Int.compare s1 s2 @@< fun () -> Int.compare n1 n2 @@< fun () -> compare e1 e2 - | EInj {e=e1; name=name1; cons=cons1}, - EInj {e=e2; name=name2; cons=cons2} -> + | EInj {e=e1; name=name1; cons=cons1 }, + EInj {e=e2; name=name2; cons=cons2 } -> EnumName.compare name1 name2 @@< fun () -> EnumConstructor.compare cons1 cons2 @@< fun () -> compare e1 e2 @@ -783,7 +803,7 @@ module DefaultBindlibCtxRename = struct let get_suffix : string -> int -> ctxt -> int * ctxt = fun name suffix ctxt -> - let n = try String.Map.find name ctxt with Not_found -> -1 in + let n = try String.Map.find name ctxt with String.Map.Not_found _ -> -1 in let suffix = if suffix > n then suffix else n + 1 in suffix, String.Map.add name suffix ctxt @@ -803,7 +823,7 @@ module DefaultBindlibCtxRename = struct try let n = String.Map.find prefix ctxt in if suffix <= n then ctxt else String.Map.add prefix suffix ctxt - with Not_found -> String.Map.add prefix suffix ctxt + with String.Map.Not_found _ -> String.Map.add prefix suffix ctxt end let rename_vars diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index 0f90eeb0..b485d396 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -36,7 +36,11 @@ val rebox : ('a any, 'm) gexpr -> ('a, 'm) boxed_gexpr (** Rebuild the whole term, re-binding all variables and exposing free variables *) val evar : ('a, 'm) gexpr Var.t -> 'm mark -> ('a, 'm) boxed_gexpr -val eexternal : Qident.t -> 'm mark -> ('a any, 'm) boxed_gexpr + +val eexternal : + name:external_ref Mark.pos -> + 'm mark -> + (< explicitScopes : no ; .. >, 'm) boxed_gexpr val bind : ('a, 'm) gexpr Var.t array -> @@ -108,42 +112,42 @@ val eraise : except -> 'm mark -> (< exceptions : yes ; .. >, 'm) boxed_gexpr val elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr val estruct : - StructName.t -> - ('a, 'm) boxed_gexpr StructField.Map.t -> + name:StructName.t -> + fields:('a, 'm) boxed_gexpr StructField.Map.t -> 'm mark -> ('a any, 'm) boxed_gexpr val edstructaccess : - ('a, 'm) boxed_gexpr -> - Ident.t -> - StructName.t option -> + name_opt:StructName.t option -> + field:Ident.t -> + e:('a, 'm) boxed_gexpr -> 'm mark -> ((< syntacticNames : yes ; .. > as 'a), 'm) boxed_gexpr val estructaccess : - ('a, 'm) boxed_gexpr -> - StructField.t -> - StructName.t -> + name:StructName.t -> + field:StructField.t -> + e:('a, 'm) boxed_gexpr -> 'm mark -> ((< resolvedNames : yes ; .. > as 'a), 'm) boxed_gexpr val einj : - ('a, 'm) boxed_gexpr -> - EnumConstructor.t -> - EnumName.t -> + name:EnumName.t -> + cons:EnumConstructor.t -> + e:('a, 'm) boxed_gexpr -> 'm mark -> ('a any, 'm) boxed_gexpr val ematch : - ('a, 'm) boxed_gexpr -> - EnumName.t -> - ('a, 'm) boxed_gexpr EnumConstructor.Map.t -> + name:EnumName.t -> + e:('a, 'm) boxed_gexpr -> + cases:('a, 'm) boxed_gexpr EnumConstructor.Map.t -> 'm mark -> ('a any, 'm) boxed_gexpr val escopecall : - ScopeName.t -> - ('a, 'm) boxed_gexpr ScopeVar.Map.t -> + scope:ScopeName.t -> + args:('a, 'm) boxed_gexpr ScopeVar.Map.t -> 'm mark -> ((< explicitScopes : yes ; .. > as 'a), 'm) boxed_gexpr diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 8d16ad10..89aa8bfa 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -458,9 +458,10 @@ let rec runtime_to_val : (* we only use non-constant constructors of arity 1, which allows us to always use the tag directly (ordered as declared in the constr map), and the field 0 *) + let cons_map = EnumName.Map.find name ctx.ctx_enums in let cons, ty = List.nth - (EnumConstructor.Map.bindings (EnumName.Map.find name ctx.ctx_enums)) + (EnumConstructor.Map.bindings cons_map) (Obj.tag o - Obj.first_non_constant_constructor_tag) in let e = runtime_to_val eval_expr ctx m ty (Obj.field o 0) in @@ -504,6 +505,7 @@ and val_to_runtime : |> Obj.repr | TEnum name1, EInj { name; cons; e } -> assert (EnumName.equal name name1); + let cons_map = EnumName.Map.find name ctx.ctx_enums in let rec find_tag n = function | [] -> assert false | (c, ty) :: _ when EnumConstructor.equal c cons -> n, ty @@ -511,7 +513,7 @@ and val_to_runtime : in let tag, ty = find_tag Obj.first_non_constant_constructor_tag - (EnumConstructor.Map.bindings (EnumName.Map.find name ctx.ctx_enums)) + (EnumConstructor.Map.bindings cons_map) in let o = Obj.with_tag tag (Obj.repr (Some ())) in Obj.set_field o 0 (val_to_runtime eval_expr ctx ty e); @@ -546,14 +548,37 @@ let rec evaluate_expr : Message.raise_spanned_error pos "free variable found at evaluation (should not happen if term was \ well-typed)" - | EExternal qid -> ( - match Qident.Map.find_opt qid ctx.ctx_modules with - | None -> - Message.raise_spanned_error pos "Reference to %a could not be resolved" - Qident.format qid - | Some ty -> - let o = Runtime.lookup_value qid in - runtime_to_val evaluate_expr ctx m ty o) + | EExternal { name } -> + let path = + match Mark.remove name with + | External_value td -> TopdefName.path td + | External_scope s -> ScopeName.path s + in + let ty = + try + let ctx = Program.module_ctx ctx path in + match Mark.remove name with + | External_value name -> TopdefName.Map.find name ctx.ctx_topdefs + | External_scope name -> + let scope_info = ScopeName.Map.find name ctx.ctx_scopes in + ( TArrow + ( [TStruct scope_info.in_struct_name, pos], + (TStruct scope_info.out_struct_name, pos) ), + pos ) + with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ -> + Message.raise_spanned_error pos "Reference to %a could not be resolved" + Print.external_ref name + in + let runtime_path = + ( List.map ModuleName.to_string path, + match Mark.remove name with + | External_value name -> Mark.remove (TopdefName.get_info name) + | External_scope name -> Mark.remove (ScopeName.get_info name) ) + (* we have the guarantee that the two cases won't collide because they + have different capitalisation rules inherited from the input *) + in + let o = Runtime.lookup_value runtime_path in + runtime_to_val evaluate_expr ctx m ty o | EApp { f = e1; args } -> ( let e1 = evaluate_expr ctx e1 in let args = List.map (evaluate_expr ctx) args in @@ -798,8 +823,8 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list (fun ty -> match Mark.remove ty with | TOption _ -> - (Expr.einj (Expr.elit LUnit mark_e) Expr.none_constr - Expr.option_enum mark_e + (Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr + ~name:Expr.option_enum mark_e : (_, _) boxed_gexpr) | _ -> Message.raise_spanned_error (Mark.get ty) @@ -812,7 +837,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list in let to_interpret = Expr.make_app (Expr.box e) - [Expr.estruct s_in application_term mark_e] + [Expr.estruct ~name:s_in ~fields:application_term mark_e] (Expr.pos e) in match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with @@ -863,7 +888,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list in let to_interpret = Expr.make_app (Expr.box e) - [Expr.estruct s_in application_term mark_e] + [Expr.estruct ~name:s_in ~fields:application_term mark_e] (Expr.pos e) in match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with @@ -888,5 +913,10 @@ let load_runtime_modules = function List.iter Dynlink.( fun m -> - loadfile (adapt_filename (Filename.remove_extension m ^ ".cmo"))) + try loadfile (adapt_filename (Filename.remove_extension m ^ ".cmo")) + with Dynlink.Error dl_err -> + Message.raise_error + "Could not load module %s, has it been suitably compiled?@;\ + <1 2>@[%a@]" m Format.pp_print_text + (Dynlink.error_message dl_err)) modules diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index 5f4808f2..d1ee6a6a 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -178,7 +178,7 @@ let rec optimize_expr : when false (* TODO: this case is buggy because of the box/unbox manipulation, it should be fixed before removing this [false] value*) - && n1 = n2 + && EnumName.equal n1 n2 && all_match_cases_map_to_same_constructor cases1 n1 -> (* iota-reduction when the matched expression is itself a match of the same enum mapping all constructors to themselves *) @@ -211,7 +211,7 @@ let rec optimize_expr : (* beta reduction when variables not used. *) Mark.remove (Bindlib.msubst binder (List.map fst args |> Array.of_list)) | EStructAccess { name; field; e = EStruct { name = name1; fields }, _ } - when name = name1 -> + when StructName.equal name name1 -> Mark.remove (StructField.Map.find field fields) | EDefault { excepts; just; cons } -> ( (* TODO: mechanically prove each of these optimizations correct *) @@ -347,15 +347,15 @@ let optimize_program (p : 'm program) : 'm program = let test_iota_reduction_1 () = let x = Var.make "x" in - let enumT = EnumName.fresh ("t", Pos.no_pos) in + let enumT = EnumName.fresh [] ("t", Pos.no_pos) in let consA = EnumConstructor.fresh ("A", Pos.no_pos) in let consB = EnumConstructor.fresh ("B", Pos.no_pos) in let consC = EnumConstructor.fresh ("C", Pos.no_pos) in let consD = EnumConstructor.fresh ("D", Pos.no_pos) in let nomark = Untyped { pos = Pos.no_pos } in - let injA = Expr.einj (Expr.evar x nomark) consA enumT nomark in - let injC = Expr.einj (Expr.evar x nomark) consC enumT nomark in - let injD = Expr.einj (Expr.evar x nomark) consD enumT nomark in + let injA = Expr.einj ~e:(Expr.evar x nomark) ~cons:consA ~name:enumT nomark in + let injC = Expr.einj ~e:(Expr.evar x nomark) ~cons:consC ~name:enumT nomark in + let injD = Expr.einj ~e:(Expr.evar x nomark) ~cons:consD ~name:enumT nomark in let cases : ('a, 't) boxed_gexpr EnumConstructor.Map.t = EnumConstructor.Map.of_list [ @@ -363,7 +363,7 @@ let test_iota_reduction_1 () = consB, Expr.eabs (Expr.bind [| x |] injD) [TAny, Pos.no_pos] nomark; ] in - let matchA = Expr.ematch injA enumT cases nomark in + let matchA = Expr.ematch ~e:injA ~name:enumT ~cases nomark in Alcotest.(check string) "same string" "before=match (A x)\n\ @@ -387,7 +387,7 @@ let cases_of_list l : ('a, 't) boxed_gexpr EnumConstructor.Map.t = (Untyped { pos = Pos.no_pos }) )) let test_iota_reduction_2 () = - let enumT = EnumName.fresh ("t", Pos.no_pos) in + let enumT = EnumName.fresh [] ("t", Pos.no_pos) in let consA = EnumConstructor.fresh ("A", Pos.no_pos) in let consB = EnumConstructor.fresh ("B", Pos.no_pos) in let consC = EnumConstructor.fresh ("C", Pos.no_pos) in @@ -397,10 +397,10 @@ let test_iota_reduction_2 () = let num n = Expr.elit (LInt (Runtime.integer_of_int n)) nomark in - let injAe e = Expr.einj e consA enumT nomark in - let injBe e = Expr.einj e consB enumT nomark in - let injCe e = Expr.einj e consC enumT nomark in - let injDe e = Expr.einj e consD enumT nomark in + let injAe e = Expr.einj ~e ~cons:consA ~name:enumT nomark in + let injBe e = Expr.einj ~e ~cons:consB ~name:enumT nomark in + let injCe e = Expr.einj ~e ~cons:consC ~name:enumT nomark in + let injDe e = Expr.einj ~e ~cons:consD ~name:enumT nomark in (* let injA x = injAe (Expr.evar x nomark) in *) let injB x = injBe (Expr.evar x nomark) in @@ -409,14 +409,17 @@ let test_iota_reduction_2 () = let matchA = Expr.ematch - (Expr.ematch (num 1) enumT - (cases_of_list - [ - (consB, fun x -> injBe (injB x)); (consA, fun _x -> injAe (num 20)); - ]) - nomark) - enumT - (cases_of_list [consA, injC; consB, injD]) + ~e: + (Expr.ematch ~e:(num 1) ~name:enumT + ~cases: + (cases_of_list + [ + (consB, fun x -> injBe (injB x)); + (consA, fun _x -> injAe (num 20)); + ]) + nomark) + ~name:enumT + ~cases:(cases_of_list [consA, injC; consB, injD]) nomark in Alcotest.(check string) diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index d199aa26..185ddad4 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -70,14 +70,23 @@ let tlit (fmt : Format.formatter) (l : typ_lit) : unit = | TDuration -> "duration" | TDate -> "date") +let module_name ppf m = Format.fprintf ppf "@{%a@}" ModuleName.format m + +let path ppf p = + Format.pp_print_list + ~pp_sep:(fun _ () -> ()) + (fun ppf m -> + Format.fprintf ppf "%a@{.@}" module_name (Mark.remove m)) + ppf p + let location (type a) (fmt : Format.formatter) (l : a glocation) : unit = match l with - | DesugaredScopeVar (v, _st) -> ScopeVar.format fmt (Mark.remove v) - | ScopelangScopeVar v -> ScopeVar.format fmt (Mark.remove v) - | SubScopeVar (_, subindex, subvar) -> + | DesugaredScopeVar { name; _ } -> ScopeVar.format fmt (Mark.remove name) + | ScopelangScopeVar { name; _ } -> ScopeVar.format fmt (Mark.remove name) + | SubScopeVar { alias = subindex; var = subvar; _ } -> Format.fprintf fmt "%a.%a" SubScopeName.format (Mark.remove subindex) ScopeVar.format (Mark.remove subvar) - | ToplevelVar v -> TopdefName.format fmt (Mark.remove v) + | ToplevelVar { name } -> TopdefName.format fmt (Mark.remove name) let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit = Format.fprintf fmt "@{%a@}" EnumConstructor.format c @@ -85,6 +94,11 @@ let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit = let struct_field (fmt : Format.formatter) (c : StructField.t) : unit = Format.fprintf fmt "@{%a@}" StructField.format c +let external_ref fmt er = + match Mark.remove er with + | External_value v -> TopdefName.format fmt v + | External_scope s -> ScopeName.format fmt s + let rec typ_gen (ctx : decl_ctx option) ~(colors : Ocolor_types.color4 list) @@ -137,14 +151,14 @@ let rec typ_gen match ctx with | None -> Format.fprintf fmt "@[%a@]" EnumName.format e | Some ctx -> + let def = EnumName.Map.find e ctx.ctx_enums in Format.fprintf fmt "@[%a%a%a%a@]" EnumName.format e punctuation "[" (EnumConstructor.Map.format_bindings ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|") (fun fmt pp_case mty -> Format.fprintf fmt "%t%a@ %a" pp_case punctuation ":" (typ ~colors) mty)) - (EnumName.Map.find e ctx.ctx_enums) - punctuation "]") + def punctuation "]") | TOption t -> Format.fprintf fmt "@[%a@ %a@]" base_type "eoption" (typ ~colors) t | TArrow ([t1], t2) -> @@ -499,7 +513,7 @@ module ExprGen (C : EXPR_PARAM) = struct else match Mark.remove e with | EVar v -> var fmt v - | EExternal eref -> Qident.format fmt eref + | EExternal { name } -> external_ref fmt name | ETuple es -> Format.fprintf fmt "@[%a%a%a@]" (pp_color_string (List.hd colors)) diff --git a/compiler/shared_ast/print.mli b/compiler/shared_ast/print.mli index 595e1794..cbab2799 100644 --- a/compiler/shared_ast/print.mli +++ b/compiler/shared_ast/print.mli @@ -42,7 +42,10 @@ val operator_to_string : 'a operator -> string val uid_list : Format.formatter -> Uid.MarkedString.info list -> unit val enum_constructor : Format.formatter -> EnumConstructor.t -> unit val tlit : Format.formatter -> typ_lit -> unit +val module_name : Format.formatter -> ModuleName.t -> unit +val path : Format.formatter -> ModuleName.t Mark.pos list -> unit val location : Format.formatter -> 'a glocation -> unit +val external_ref : Format.formatter -> external_ref Mark.pos -> unit val typ : decl_ctx -> Format.formatter -> typ -> unit val lit : Format.formatter -> lit -> unit val operator : ?debug:bool -> Format.formatter -> 'a operator -> unit diff --git a/compiler/shared_ast/program.ml b/compiler/shared_ast/program.ml index c05f6798..b0c3ec6f 100644 --- a/compiler/shared_ast/program.ml +++ b/compiler/shared_ast/program.ml @@ -34,9 +34,13 @@ let empty_ctx = ctx_structs = StructName.Map.empty; ctx_struct_fields = Ident.Map.empty; ctx_scopes = ScopeName.Map.empty; - ctx_modules = Qident.Map.empty; + ctx_topdefs = TopdefName.Map.empty; + ctx_modules = ModuleName.Map.empty; } +let module_ctx ctx path = + List.fold_left (fun ctx m -> ModuleName.Map.find m ctx.ctx_modules) ctx path + let get_scope_body { code_items; _ } scope = match Scope.fold_left ~init:None diff --git a/compiler/shared_ast/program.mli b/compiler/shared_ast/program.mli index d1c8b704..58a8f55b 100644 --- a/compiler/shared_ast/program.mli +++ b/compiler/shared_ast/program.mli @@ -15,12 +15,17 @@ License for the specific language governing permissions and limitations under the License. *) +open Catala_utils open Definitions (** {2 Program declaration context helpers} *) val empty_ctx : decl_ctx +val module_ctx : decl_ctx -> Uid.Path.t -> decl_ctx +(** Follows a path to get the corresponding context for type and value + declarations. *) + (** {2 Transformations} *) val map_exprs : @@ -47,3 +52,4 @@ val to_expr : ((_ any, _) gexpr as 'e) program -> ScopeName.t -> 'e boxed val equal : (('a any, _) gexpr as 'e) program -> (('a any, _) gexpr as 'e) program -> bool +(** Warning / todo: only compares program scopes at the moment *) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 0da04c7a..7bc9e6f1 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -125,13 +125,12 @@ let rec format_typ "(" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ") - (fun fmt t -> - Format.fprintf fmt "%a" (format_typ ~colors:(List.tl colors)) t)) + (fun fmt t -> format_typ fmt ~colors:(List.tl colors) t)) ts (pp_color_string (List.hd colors)) ")" - | TStruct s -> Format.fprintf fmt "%a" A.StructName.format s - | TEnum e -> Format.fprintf fmt "%a" A.EnumName.format e + | TStruct s -> A.StructName.format fmt s + | TEnum e -> A.EnumName.format fmt e | TOption t -> Format.fprintf fmt "@[option %a@]" (format_typ_with_parens ~colors:(List.tl colors)) @@ -313,6 +312,7 @@ module Env = struct scope_vars : A.typ A.ScopeVar.Map.t; scopes : A.typ A.ScopeVar.Map.t A.ScopeName.Map.t; toplevel_vars : A.typ A.TopdefName.Map.t; + modules : 'e t A.ModuleName.Map.t; } let empty (decl_ctx : A.decl_ctx) = @@ -321,16 +321,17 @@ module Env = struct { structs = A.StructName.Map.map - (A.StructField.Map.map ast_to_typ) + (fun ty -> A.StructField.Map.map ast_to_typ ty) decl_ctx.ctx_structs; enums = A.EnumName.Map.map - (A.EnumConstructor.Map.map ast_to_typ) + (fun ty -> A.EnumConstructor.Map.map ast_to_typ ty) decl_ctx.ctx_enums; vars = Var.Map.empty; scope_vars = A.ScopeVar.Map.empty; scopes = A.ScopeName.Map.empty; toplevel_vars = A.TopdefName.Map.empty; + modules = A.ModuleName.Map.empty; } let get t v = Var.Map.find_opt v t.vars @@ -341,6 +342,9 @@ module Env = struct Option.bind (A.ScopeName.Map.find_opt scope t.scopes) (fun vmap -> A.ScopeVar.Map.find_opt var vmap) + let module_env path env = + List.fold_left (fun env m -> A.ModuleName.Map.find m env.modules) env path + let add v tau t = { t with vars = Var.Map.add v tau t.vars } let add_var v typ t = add v (ast_to_typ typ) t @@ -353,6 +357,9 @@ module Env = struct let add_toplevel_var v typ t = { t with toplevel_vars = A.TopdefName.Map.add v typ t.toplevel_vars } + let add_module modname ~module_env t = + { t with modules = A.ModuleName.Map.add modname module_env t.modules } + let open_scope scope_name t = let scope_vars = A.ScopeVar.Map.union @@ -361,6 +368,26 @@ module Env = struct (A.ScopeName.Map.find scope_name t.scopes) in { t with scope_vars } + + let rec dump ppf env = + let pp_sep = Format.pp_print_space in + Format.pp_open_vbox ppf 0; + (* Format.fprintf ppf "structs: @[%a@]@," + * (A.StructName.Map.format_keys ~pp_sep) env.structs; + * Format.fprintf ppf "enums: @[%a@]@," + * (A.EnumName.Map.format_keys ~pp_sep) env.enums; + * Format.fprintf ppf "vars: @[%a@]@," + * (Var.Map.format_keys ~pp_sep) env.vars; *) + Format.fprintf ppf "scopes: @[%a@]@," + (A.ScopeName.Map.format_keys ~pp_sep) + env.scopes; + Format.fprintf ppf "topdefs: @[%a@]@," + (A.TopdefName.Map.format_keys ~pp_sep) + env.toplevel_vars; + Format.fprintf ppf "@[modules:@ %a@]" + (A.ModuleName.Map.format dump) + env.modules; + Format.pp_close_box ppf () end let add_pos e ty = Mark.add (Expr.pos e) ty @@ -414,11 +441,14 @@ and typecheck_expr_top_down : | A.ELocation loc -> let ty_opt = match loc with - | DesugaredScopeVar (v, _) | ScopelangScopeVar v -> - Env.get_scope_var env (Mark.remove v) - | SubScopeVar (scope, _, v) -> - Env.get_subscope_out_var env scope (Mark.remove v) - | ToplevelVar v -> Env.get_toplevel_var env (Mark.remove v) + | DesugaredScopeVar { name; _ } | ScopelangScopeVar { name } -> + Env.get_scope_var env (Mark.remove name) + | SubScopeVar { scope; var; _ } -> + let env = Env.module_env (A.ScopeName.path scope) env in + Env.get_subscope_out_var env scope (Mark.remove var) + | ToplevelVar { name } -> + let env = Env.module_env (A.TopdefName.path (Mark.remove name)) env in + Env.get_toplevel_var env (Mark.remove name) in let ty = match ty_opt with @@ -463,14 +493,14 @@ and typecheck_expr_top_down : "Mismatching field definitions for structure %a" A.StructName.format name in - let fields' = + let fields = A.StructField.Map.mapi (fun f_name f_e -> let f_ty = A.StructField.Map.find f_name str in typecheck_expr_top_down ~leave_unresolved ctx env f_ty f_e) fields in - Expr.estruct name fields' mark + Expr.estruct ~name ~fields mark | A.EDStructAccess { e = e_struct; name_opt; field } -> let t_struct = match name_opt with @@ -495,14 +525,14 @@ and typecheck_expr_top_down : let fld_ty = let str = try A.StructName.Map.find name env.structs - with Not_found -> + with A.StructName.Map.Not_found _ -> Message.raise_spanned_error pos_e "No structure %a found" A.StructName.format name in let field = let candidate_structs = try A.Ident.Map.find field ctx.ctx_struct_fields - with Not_found -> + with A.Ident.Map.Not_found _ -> Message.raise_spanned_error (Expr.mark_pos context_mark) "Field @{\"%s\"@} does not belong to structure \ @@ -510,7 +540,7 @@ and typecheck_expr_top_down : field A.StructName.format name in try A.StructName.Map.find name candidate_structs - with Not_found -> + with A.StructName.Map.Not_found _ -> Message.raise_spanned_error (Expr.mark_pos context_mark) "@[Field @{\"%s\"@}@ does not belong to@ structure \ @@ -526,17 +556,17 @@ and typecheck_expr_top_down : A.StructField.Map.find field str in let mark = mark_with_tau_and_unify fld_ty in - Expr.edstructaccess e_struct' field (Some name) mark + Expr.edstructaccess ~e:e_struct' ~name_opt:(Some name) ~field mark | A.EStructAccess { e = e_struct; name; field } -> let fld_ty = let str = try A.StructName.Map.find name env.structs - with Not_found -> + with A.StructName.Map.Not_found _ -> Message.raise_spanned_error pos_e "No structure %a found" A.StructName.format name in try A.StructField.Map.find field str - with Not_found -> + with A.StructField.Map.Not_found _ -> Message.raise_multispanned_error [ None, pos_e; @@ -551,7 +581,7 @@ and typecheck_expr_top_down : typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TStruct name)) e_struct in - Expr.estructaccess e_struct' field name mark + Expr.estructaccess ~e:e_struct' ~field ~name mark | A.EInj { name; cons; e = e_enum } when Definitions.EnumName.equal name Expr.option_enum -> if Definitions.EnumConstructor.equal cons Expr.some_constr then @@ -560,7 +590,7 @@ and typecheck_expr_top_down : let e_enum' = typecheck_expr_top_down ~leave_unresolved ctx env cell_type e_enum in - Expr.einj e_enum' cons name mark + Expr.einj ~name ~cons ~e:e_enum' mark else (* None constructor *) let cell_type = unionfind (TAny (Any.fresh ())) in @@ -569,7 +599,7 @@ and typecheck_expr_top_down : typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TLit TUnit)) e_enum in - Expr.einj e_enum' cons name mark + Expr.einj ~name ~cons ~e:e_enum' mark | A.EInj { name; cons; e = e_enum } -> let mark = mark_with_tau_and_unify (unionfind (TEnum name)) in let e_enum' = @@ -577,7 +607,7 @@ and typecheck_expr_top_down : (A.EnumConstructor.Map.find cons (A.EnumName.Map.find name env.enums)) e_enum in - Expr.einj e_enum' cons name mark + Expr.einj ~e:e_enum' ~cons ~name mark | A.EMatch { e = e1; name; cases } when Definitions.EnumName.equal name Expr.option_enum -> let cell_type = unionfind ~pos:e1 (TAny (Any.fresh ())) in @@ -591,7 +621,7 @@ and typecheck_expr_top_down : let t_ret = unionfind ~pos:e (TAny (Any.fresh ())) in let mark = mark_with_tau_and_unify t_ret in let e1' = typecheck_expr_top_down ~leave_unresolved ctx env t_arg e1 in - let cases' = + let cases = A.EnumConstructor.Map.merge (fun _ e e_ty -> match e, e_ty with @@ -603,8 +633,7 @@ and typecheck_expr_top_down : | _ -> assert false) cases cases_ty in - - Expr.ematch e1' name cases' mark + Expr.ematch ~e:e1' ~name ~cases mark | A.EMatch { e = e1; name; cases } -> let cases_ty = A.EnumName.Map.find name ctx.A.ctx_enums in let t_ret = unionfind ~pos:e1 (TAny (Any.fresh ())) in @@ -613,7 +642,7 @@ and typecheck_expr_top_down : typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TEnum name)) e1 in - let cases' = + let cases = A.EnumConstructor.Map.mapi (fun c_name e -> let c_ty = A.EnumConstructor.Map.find c_name cases_ty in @@ -624,13 +653,18 @@ and typecheck_expr_top_down : typecheck_expr_top_down ~leave_unresolved ctx env e_ty e) cases in - Expr.ematch e1' name cases' mark + Expr.ematch ~e:e1' ~name ~cases mark | A.EScopeCall { scope; args } -> + let path = A.ScopeName.path scope in let scope_out_struct = + let ctx = Program.module_ctx ctx path in (A.ScopeName.Map.find scope ctx.ctx_scopes).out_struct_name in let mark = mark_with_tau_and_unify (unionfind (TStruct scope_out_struct)) in - let vars = A.ScopeName.Map.find scope env.scopes in + let vars = + let env = Env.module_env path env in + A.ScopeName.Map.find scope env.scopes + in let args' = A.ScopeVar.Map.mapi (fun name -> @@ -638,7 +672,7 @@ and typecheck_expr_top_down : (ast_to_typ (A.ScopeVar.Map.find name vars))) args in - Expr.escopecall scope args' mark + Expr.escopecall ~scope ~args:args' mark | A.ERaise ex -> Expr.eraise ex context_mark | A.ECatch { body; exn; handler } -> let body' = typecheck_expr_top_down ~leave_unresolved ctx env tau body in @@ -655,16 +689,36 @@ and typecheck_expr_top_down : "Variable %s not found in the current context" (Bindlib.name_of v) in Expr.evar (Var.translate v) (mark_with_tau_and_unify tau') - | A.EExternal eref -> + | A.EExternal { name } -> + let path = + match Mark.remove name with + | External_value td -> A.TopdefName.path td + | External_scope s -> A.ScopeName.path s + in + let ctx = Program.module_ctx ctx path in let ty = - try Qident.Map.find eref ctx.ctx_modules - with Not_found -> + let not_found pr x = Message.raise_spanned_error pos_e "Could not resolve the reference to %a.@ Make sure the corresponding \ module was properly loaded?" - Qident.format eref + pr x + in + match Mark.remove name with + | A.External_value name -> ( + try ast_to_typ (A.TopdefName.Map.find name ctx.ctx_topdefs) + with A.TopdefName.Map.Not_found _ -> + not_found A.TopdefName.format name) + | A.External_scope name -> ( + try + let scope_info = A.ScopeName.Map.find name ctx.ctx_scopes in + ast_to_typ + ( TArrow + ( [TStruct scope_info.in_struct_name, pos_e], + (TStruct scope_info.out_struct_name, pos_e) ), + pos_e ) + with A.ScopeName.Map.Not_found _ -> not_found A.ScopeName.format name) in - Expr.eexternal eref (mark_with_tau_and_unify (ast_to_typ ty)) + Expr.eexternal ~name (mark_with_tau_and_unify ty) | A.ELit lit -> Expr.elit lit (ty_mark (lit_type lit)) | A.ETuple es -> let tys = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) es in diff --git a/compiler/shared_ast/typing.mli b/compiler/shared_ast/typing.mli index c295b34d..1f51f74e 100644 --- a/compiler/shared_ast/typing.mli +++ b/compiler/shared_ast/typing.mli @@ -17,6 +17,7 @@ (** Typing for the default calculus. Because of the error terms, we perform type inference using the classical W algorithm with union-find unification. *) +open Catala_utils open Definitions module Env : sig @@ -27,7 +28,12 @@ module Env : sig val add_toplevel_var : TopdefName.t -> typ -> 'e t -> 'e t val add_scope_var : ScopeVar.t -> typ -> 'e t -> 'e t val add_scope : ScopeName.t -> vars:typ ScopeVar.Map.t -> 'e t -> 'e t + val add_module : ModuleName.t -> module_env:'e t -> 'e t -> 'e t + val module_env : Uid.Path.t -> 'e t -> 'e t val open_scope : ScopeName.t -> 'e t -> 'e t + + val dump : Format.formatter -> 'e t -> unit + (** For debug purposes *) end (** In the following functions, the [~leave_unresolved] labeled parameter diff --git a/compiler/shared_ast/var.ml b/compiler/shared_ast/var.ml index ebbd04a3..d74be626 100644 --- a/compiler/shared_ast/var.ml +++ b/compiler/shared_ast/var.ml @@ -88,7 +88,12 @@ end maps) *) module Map = struct open Generic - open Map.Make (Generic) + module M = Map.Make (Generic) + open M + + type k0 = M.key + + exception Not_found = M.Not_found type nonrec ('e, 'x) t = 'x t @@ -104,6 +109,7 @@ module Map = struct let fold f m acc = fold (fun v x acc -> f (get v) x acc) m acc let keys m = keys m |> List.map get let values m = values m + let format_keys ?pp_sep m = format_keys ?pp_sep m (* Add more as needed *) end diff --git a/compiler/shared_ast/var.mli b/compiler/shared_ast/var.mli index dbff7d86..0aa92bda 100644 --- a/compiler/shared_ast/var.mli +++ b/compiler/shared_ast/var.mli @@ -57,6 +57,9 @@ end Extend as needed *) module Map : sig type ('e, 'x) t + type k0 + + exception Not_found of k0 val empty : ('e, 'x) t val singleton : 'e var -> 'x -> ('e, 'x) t @@ -73,4 +76,10 @@ module Map : sig val fold : ('e var -> 'x -> 'acc -> 'acc) -> ('e, 'x) t -> 'acc -> 'acc val keys : ('e, 'x) t -> 'e var list val values : ('e, 'x) t -> 'x list + + val format_keys : + ?pp_sep:(Format.formatter -> unit -> unit) -> + Format.formatter -> + ('e, 'x) t -> + unit end diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index ea4b27d9..6bdc8e9f 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -251,7 +251,7 @@ and scope_decl_context_io = { and scope_decl_context_scope = { scope_decl_context_scope_name : lident Mark.pos; - scope_decl_context_scope_sub_scope : uident Mark.pos; + scope_decl_context_scope_sub_scope : (path * uident Mark.pos) Mark.pos; scope_decl_context_scope_attribute : scope_decl_context_io; } @@ -309,11 +309,14 @@ and law_structure = | LawText of (string[@opaque]) | CodeBlock of code_block * source_repr * bool (* Metadata if true *) +and interface = code_block +(** Invariant: an interface shall only contain [*Decl] elements, or [Topdef] + elements with [topdef_expr = None] *) + and program = { - program_interfaces : - ((Shared_ast.Qident.path[@opaque]) * code_item Mark.pos) list; program_items : law_structure list; program_source_files : (string[@opaque]) list; + program_modules : (uident * interface) list; } and source_file = law_structure list diff --git a/compiler/surface/parser.messages b/compiler/surface/parser.messages index f5a12ad9..03ef43c8 100644 --- a/compiler/surface/parser.messages +++ b/compiler/surface/parser.messages @@ -3957,45 +3957,11 @@ source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON CONTEXT LIDENT CONDITION expected the next definition in scope -source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON CONTEXT LIDENT CONDITION DEPENDS LIDENT CONTENT UIDENT DEFINED_AS -## -## Ends in an error in state: 344. -## -## scope_decl_item -> scope_decl_item_attribute lident CONDITION DEPENDS separated_nonempty_list(COMMA,var_content) . list(state) [ SCOPE OUTPUT LIDENT INTERNAL INPUT END_CODE DECLARATION CONTEXT ] -## -## The known suffix of the stack is as follows: -## scope_decl_item_attribute lident CONDITION DEPENDS separated_nonempty_list(COMMA,var_content) -## -## WARNING: This example involves spurious reductions. -## This implies that, although the LR(1) items shown above provide an -## accurate view of the past (what has been recognized so far), they -## may provide an INCOMPLETE view of the future (what was expected next). -## In state 21, spurious reduction of production quident -> UIDENT -## In state 30, spurious reduction of production primitive_typ -> quident -## In state 296, spurious reduction of production typ_data -> primitive_typ -## In state 307, spurious reduction of production separated_nonempty_list(COMMA,var_content) -> lident CONTENT typ_data -## - -expected the next definition in scope, or a comma followed by another argument declaration (', content ') - -source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON LIDENT SCOPE UIDENT YEAR -## -## Ends in an error in state: 347. -## -## nonempty_list(addpos(scope_decl_item)) -> scope_decl_item . [ SCOPE END_CODE DECLARATION ] -## nonempty_list(addpos(scope_decl_item)) -> scope_decl_item . nonempty_list(addpos(scope_decl_item)) [ SCOPE END_CODE DECLARATION ] -## -## The known suffix of the stack is as follows: -## scope_decl_item -## - -expected the next declaration for the scope - source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON LIDENT YEAR ## ## Ends in an error in state: 349. ## -## scope_decl_item -> lident . SCOPE UIDENT [ SCOPE OUTPUT LIDENT INTERNAL INPUT END_CODE DECLARATION CONTEXT ] +## scope_decl_item -> lident . SCOPE quident [ SCOPE OUTPUT LIDENT INTERNAL INPUT END_CODE DECLARATION CONTEXT ] ## ## The known suffix of the stack is as follows: ## lident @@ -4007,7 +3973,7 @@ source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON LIDENT SCOPE YEAR ## ## Ends in an error in state: 350. ## -## scope_decl_item -> lident SCOPE . UIDENT [ SCOPE OUTPUT LIDENT INTERNAL INPUT END_CODE DECLARATION CONTEXT ] +## scope_decl_item -> lident SCOPE . quident [ SCOPE OUTPUT LIDENT INTERNAL INPUT END_CODE DECLARATION CONTEXT ] ## ## The known suffix of the stack is as follows: ## lident SCOPE diff --git a/compiler/surface/parser.mly b/compiler/surface/parser.mly index c5b66851..1c23f443 100644 --- a/compiler/surface/parser.mly +++ b/compiler/surface/parser.mly @@ -574,7 +574,7 @@ let scope_decl_item := scope_decl_context_item_states = states; } } -| i = lident ; SCOPE ; c = uident ; { +| i = lident ; SCOPE ; c = addpos(quident) ; { ContextScope{ scope_decl_context_scope_name = i; scope_decl_context_scope_sub_scope = c; diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index db8bb25a..5e37c614 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -229,9 +229,9 @@ let rec parse_source_file (match input with Some input -> close_in input | None -> ()); let program = expand_includes source_file_name commands language in { - program_interfaces = []; program_items = program.Ast.program_items; program_source_files = source_file_name :: program.Ast.program_source_files; + program_modules = []; } (** Expands the include directives in a parsing result, thus parsing new source @@ -248,31 +248,32 @@ and expand_includes let sub_source = File.(source_dir / Mark.remove sub_source) in let includ_program = parse_source_file (FileName sub_source) language in { - program_interfaces = []; Ast.program_source_files = acc.Ast.program_source_files @ includ_program.program_source_files; Ast.program_items = acc.Ast.program_items @ includ_program.program_items; + Ast.program_modules = + acc.Ast.program_modules @ includ_program.program_modules; } | Ast.LawHeading (heading, commands') -> let { - Ast.program_interfaces = _; Ast.program_items = commands'; Ast.program_source_files = new_sources; + Ast.program_modules = new_modules; } = expand_includes source_file commands' language in { - Ast.program_interfaces = []; Ast.program_source_files = acc.Ast.program_source_files @ new_sources; Ast.program_items = acc.Ast.program_items @ [Ast.LawHeading (heading, commands')]; + Ast.program_modules = acc.Ast.program_modules @ new_modules; } | i -> { acc with Ast.program_items = acc.Ast.program_items @ [i] }) { - Ast.program_interfaces = []; Ast.program_source_files = []; Ast.program_items = []; + Ast.program_modules = []; } commands @@ -297,30 +298,16 @@ let get_interface program = in List.fold_left filter [] program.Ast.program_items -let qualify_interface path code_items = - List.map (fun item -> path, item) code_items - (** {1 API} *) -let add_interface source_file language path program = - let interface = - parse_source_file source_file language - |> get_interface - |> qualify_interface path - in - { - program with - Ast.program_interfaces = - List.append interface program.Ast.program_interfaces; - } +let load_interface source_file language = + parse_source_file source_file language |> get_interface let parse_top_level_file (source_file : Cli.input_file) (language : Cli.backend_lang) : Ast.program = let program = parse_source_file source_file language in - let interface = get_interface program in { program with Ast.program_items = law_struct_list_to_tree program.Ast.program_items; - Ast.program_interfaces = qualify_interface [] interface; } diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index f608e7bd..68d4dba3 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -19,13 +19,10 @@ open Catala_utils -val add_interface : - Cli.input_file -> - Cli.backend_lang -> - Shared_ast.Qident.path -> - Ast.program -> - Ast.program -(** Reads only declarations in metadata in the supplied input file, and add them - to the given program *) +val load_interface : Cli.input_file -> Cli.backend_lang -> Ast.interface +(** Reads only declarations in metadata in the supplied input file, and only + keeps type information *) val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program +(** Parses a catala file (handling file includes) and returns a program. Modules + in the program are returned empty, use [load_interface] to fill them. *) diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index 3a95e427..1aae7076 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -666,12 +666,8 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr = mk_struct. The accessors of this constructor correspond to the field accesses *) let accessors = List.hd (Datatype.get_accessors z3_struct) in - let idx_mappings = - List.combine - (StructField.Map.keys - (StructName.Map.find name ctx.ctx_decl.ctx_structs)) - accessors - in + let fields = StructName.Map.find name ctx.ctx_decl.ctx_structs in + let idx_mappings = List.combine (StructField.Map.keys fields) accessors in let _, accessor = List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings in @@ -685,13 +681,9 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr = let ctx, z3_enum = find_or_create_enum ctx name in let ctx, z3_arg = translate_expr ctx e in let ctrs = Datatype.get_constructors z3_enum in + let cons_map = EnumName.Map.find name ctx.ctx_decl.ctx_enums in (* This should always succeed if the expression is well-typed in dcalc *) - let idx_mappings = - List.combine - (EnumConstructor.Map.keys - (EnumName.Map.find name ctx.ctx_decl.ctx_enums)) - ctrs - in + let idx_mappings = List.combine (EnumConstructor.Map.keys cons_map) ctrs in let _, ctr = List.find (fun (cons1, _) -> EnumConstructor.equal cons cons1) diff --git a/examples/Makefile b/examples/Makefile index efcd1ed8..000b9c0a 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -9,16 +9,16 @@ CLERK=_build/default/build_system/clerk.exe --exe "_build/default/compiler/catal ################################ pass_all_tests: - @cd ..;OCAMLRUNPARAM= $(CLERK) examples + @cd ..; $(CLERK) examples reset_all_tests: CLERK_OPTS+=--reset reset_all_tests: - @cd ..;OCAMLRUNPARAM= $(CLERK) examples + @cd ..; $(CLERK) examples %.catala_en %.catala_fr %.catala_pl: .FORCE # Here we cd to the root of the Catala repository such that the paths \ # displayed in error messages start with `examples/` uniformly. - @cd ..;OCAMLRUNPARAM= $(CLERK) examples/$@ + @cd ..; $(CLERK) examples/$@ .FORCE: diff --git a/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en b/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en index dc2c2c27..d44968ed 100644 --- a/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en +++ b/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en @@ -35,13 +35,13 @@ You could have written : "condition", or "content" Error token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: +┌─⯈ test_nsw_social_housie.catala_en:11.21-11.26: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾ Last good token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.11-11.20: +┌─⯈ test_nsw_social_housie.catala_en:11.11-11.20: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ @@ -79,13 +79,13 @@ You could have written : "condition", or "content" Error token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: +┌─⯈ test_nsw_social_housie.catala_en:11.21-11.26: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾ Last good token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.11-11.20: +┌─⯈ test_nsw_social_housie.catala_en:11.11-11.20: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ @@ -123,13 +123,13 @@ You could have written : "condition", or "content" Error token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: +┌─⯈ test_nsw_social_housie.catala_en:11.21-11.26: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾ Last good token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.11-11.20: +┌─⯈ test_nsw_social_housie.catala_en:11.11-11.20: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ @@ -169,13 +169,13 @@ You could have written : "condition", or "content" Error token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: +┌─⯈ test_nsw_social_housie.catala_en:11.21-11.26: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾ Last good token: -┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.11-11.20: +┌─⯈ test_nsw_social_housie.catala_en:11.11-11.20: └──┐ 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ diff --git a/french_law/ocaml/api.ml b/french_law/ocaml/api.ml index 6d2bc75b..e25a66c4 100644 --- a/french_law/ocaml/api.ml +++ b/french_law/ocaml/api.ml @@ -30,17 +30,17 @@ let compute_allocations_familiales let result = AF.interface_allocations_familiales { - AF.InterfaceAllocationsFamilialesIn.i_date_courante_in = current_date; - AF.InterfaceAllocationsFamilialesIn.i_enfants_in = children; - AF.InterfaceAllocationsFamilialesIn.i_ressources_menage_in = + AF.InterfaceAllocationsFamiliales_in.i_date_courante_in = current_date; + AF.InterfaceAllocationsFamiliales_in.i_enfants_in = children; + AF.InterfaceAllocationsFamiliales_in.i_ressources_menage_in = money_of_units_int income; - AF.InterfaceAllocationsFamilialesIn.i_residence_in = residence; - AF.InterfaceAllocationsFamilialesIn + AF.InterfaceAllocationsFamiliales_in.i_residence_in = residence; + AF.InterfaceAllocationsFamiliales_in .i_personne_charge_effective_permanente_est_parent_in = is_parent; - AF.InterfaceAllocationsFamilialesIn + AF.InterfaceAllocationsFamiliales_in .i_personne_charge_effective_permanente_remplit_titre_I_in = fills_title_I; - AF.InterfaceAllocationsFamilialesIn + AF.InterfaceAllocationsFamiliales_in .i_avait_enfant_a_charge_avant_1er_janvier_2012_in = had_rights_open_before_2012; } diff --git a/french_law/ocaml/bench.ml b/french_law/ocaml/bench.ml index 8f7f92e1..78d7ec6d 100644 --- a/french_law/ocaml/bench.ml +++ b/french_law/ocaml/bench.ml @@ -116,7 +116,7 @@ let run_test_allocations_familiales () = | Runtime.AssertionFailed _ -> () let aides_logement_input : - Law_source.Aides_logement.CalculetteAidesAuLogementGardeAlterneeIn.t = + Law_source.Aides_logement.CalculetteAidesAuLogementGardeAlternee_in.t = { menage_in = { @@ -137,7 +137,7 @@ let aides_logement_input : false; logement_meuble_d842_2 = false; changement_logement_d842_4 = - Law_source.Aides_logement.ChangementLogementD8424 + Law_source.Aides_logement.ChangementLogementD842_4 .PasDeChangement (); loyer_principal = Runtime.money_of_units_int 450; diff --git a/tests/Makefile b/tests/Makefile index 5d020235..b15487c9 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -17,8 +17,8 @@ CLERK=_build/default/build_system/clerk.exe --exe "_build/default/compiler/catal @cd ..; $(CLERK) tests/$@ pass_all_tests: - @cd ..;OCAMLRUNPARAM= $(CLERK) tests + @cd ..; $(CLERK) tests reset_all_tests: CLERK_OPTS+=--reset reset_all_tests: - @cd ..;OCAMLRUNPARAM= $(CLERK) tests + @cd ..; $(CLERK) tests diff --git a/tests/test_arithmetic/bad/division_by_zero.catala_en b/tests/test_arithmetic/bad/division_by_zero.catala_en index c0c7352b..3acd5f90 100644 --- a/tests/test_arithmetic/bad/division_by_zero.catala_en +++ b/tests/test_arithmetic/bad/division_by_zero.catala_en @@ -37,7 +37,7 @@ $ catala Interpret -s Dec division by zero at runtime The division operator: -┌─⯈ tests/test_arithmetic/bad/division_by_zero.catala_en:20.23-20.30: +┌─⯈ division_by_zero.catala_en:20.23-20.30: └──┐ 20 │ definition i equals 1. / 0. │ ‾‾‾‾‾‾‾ @@ -45,7 +45,7 @@ The division operator: └─ with decimals The null denominator: -┌─⯈ tests/test_arithmetic/bad/division_by_zero.catala_en:20.28-20.30: +┌─⯈ division_by_zero.catala_en:20.28-20.30: └──┐ 20 │ definition i equals 1. / 0. │ ‾‾ @@ -60,7 +60,7 @@ $ catala Interpret -s Int division by zero at runtime The division operator: -┌─⯈ tests/test_arithmetic/bad/division_by_zero.catala_en:10.23-10.28: +┌─⯈ division_by_zero.catala_en:10.23-10.28: └──┐ 10 │ definition i equals 1 / 0 │ ‾‾‾‾‾ @@ -68,7 +68,7 @@ The division operator: └─ with integers The null denominator: -┌─⯈ tests/test_arithmetic/bad/division_by_zero.catala_en:10.27-10.28: +┌─⯈ division_by_zero.catala_en:10.27-10.28: └──┐ 10 │ definition i equals 1 / 0 │ ‾ @@ -83,7 +83,7 @@ $ catala Interpret -s Money division by zero at runtime The division operator: -┌─⯈ tests/test_arithmetic/bad/division_by_zero.catala_en:30.23-30.35: +┌─⯈ division_by_zero.catala_en:30.23-30.35: └──┐ 30 │ definition i equals $10.0 / $0.0 │ ‾‾‾‾‾‾‾‾‾‾‾‾ @@ -91,7 +91,7 @@ The division operator: └─ with money The null denominator: -┌─⯈ tests/test_arithmetic/bad/division_by_zero.catala_en:30.31-30.35: +┌─⯈ division_by_zero.catala_en:30.31-30.35: └──┐ 30 │ definition i equals $10.0 / $0.0 │ ‾‾‾‾ diff --git a/tests/test_arithmetic/bad/logical_prio.catala_en b/tests/test_arithmetic/bad/logical_prio.catala_en index 0eed46b8..555b3f04 100644 --- a/tests/test_arithmetic/bad/logical_prio.catala_en +++ b/tests/test_arithmetic/bad/logical_prio.catala_en @@ -11,12 +11,12 @@ $ catala typecheck [ERROR] Please add parentheses to explicit which of these operators should be applied first -┌─⯈ tests/test_arithmetic/bad/logical_prio.catala_en:6.28-6.31: +┌─⯈ logical_prio.catala_en:6.28-6.31: └─┐ 6 │ definition o equals true and (false and true and true) or false │ ‾‾‾ -┌─⯈ tests/test_arithmetic/bad/logical_prio.catala_en:6.58-6.60: +┌─⯈ logical_prio.catala_en:6.58-6.60: └─┐ 6 │ definition o equals true and (false and true and true) or false │ ‾‾ diff --git a/tests/test_array/bad/fold_error.catala_en b/tests/test_array/bad/fold_error.catala_en index c20c2aaf..fb5fda6f 100644 --- a/tests/test_array/bad/fold_error.catala_en +++ b/tests/test_array/bad/fold_error.catala_en @@ -16,21 +16,21 @@ $ catala Interpret -s A I don't know how to apply operator >= on types integer and money -┌─⯈ tests/test_array/bad/fold_error.catala_en:10.50-10.52: +┌─⯈ fold_error.catala_en:10.50-10.52: └──┐ 10 │ definition list_high_count equals number of (m >= $7) for m among list │ ‾‾ └─ Article Type integer coming from expression: -┌─⯈ tests/test_array/bad/fold_error.catala_en:5.35-5.42: +┌─⯈ fold_error.catala_en:5.35-5.42: └─┐ 5 │ context list content collection integer │ ‾‾‾‾‾‾‾ └─ Article Type money coming from expression: -┌─⯈ tests/test_array/bad/fold_error.catala_en:10.53-10.55: +┌─⯈ fold_error.catala_en:10.53-10.55: └──┐ 10 │ definition list_high_count equals number of (m >= $7) for m among list │ ‾‾ diff --git a/tests/test_bool/bad/bad_assert.catala_en b/tests/test_bool/bad/bad_assert.catala_en index 0aa92dbf..2751445e 100644 --- a/tests/test_bool/bad/bad_assert.catala_en +++ b/tests/test_bool/bad/bad_assert.catala_en @@ -18,21 +18,21 @@ Error during typechecking, incompatible types: └─⯈ bool Error coming from typechecking the following expression: -┌─⯈ tests/test_bool/bad/bad_assert.catala_en:9.13-9.14: +┌─⯈ bad_assert.catala_en:9.13-9.14: └─┐ 9 │ assertion x │ ‾ └─ Test Type integer coming from expression: -┌─⯈ tests/test_bool/bad/bad_assert.catala_en:5.20-5.27: +┌─⯈ bad_assert.catala_en:5.20-5.27: └─┐ 5 │ output x content integer │ ‾‾‾‾‾‾‾ └─ Test Type bool coming from expression: -┌─⯈ tests/test_bool/bad/bad_assert.catala_en:9.13-9.14: +┌─⯈ bad_assert.catala_en:9.13-9.14: └─┐ 9 │ assertion x │ ‾ diff --git a/tests/test_bool/bad/test_xor_with_int.catala_en b/tests/test_bool/bad/test_xor_with_int.catala_en index 2c516657..7787d24b 100644 --- a/tests/test_bool/bad/test_xor_with_int.catala_en +++ b/tests/test_bool/bad/test_xor_with_int.catala_en @@ -16,21 +16,21 @@ Error during typechecking, incompatible types: └─⯈ bool Error coming from typechecking the following expression: -┌─⯈ tests/test_bool/bad/test_xor_with_int.catala_en:8.30-8.32: +┌─⯈ test_xor_with_int.catala_en:8.30-8.32: └─┐ 8 │ definition test_var equals 10 xor 20 │ ‾‾ └─ 'xor' should be a boolean operator Type integer coming from expression: -┌─⯈ tests/test_bool/bad/test_xor_with_int.catala_en:8.30-8.32: +┌─⯈ test_xor_with_int.catala_en:8.30-8.32: └─┐ 8 │ definition test_var equals 10 xor 20 │ ‾‾ └─ 'xor' should be a boolean operator Type bool coming from expression: -┌─⯈ tests/test_bool/bad/test_xor_with_int.catala_en:8.33-8.36: +┌─⯈ test_xor_with_int.catala_en:8.33-8.36: └─┐ 8 │ definition test_var equals 10 xor 20 │ ‾‾‾ diff --git a/tests/test_date/bad/rounding_option_conflict.catala_en b/tests/test_date/bad/rounding_option_conflict.catala_en index 2fc1d085..f7f5e068 100644 --- a/tests/test_date/bad/rounding_option_conflict.catala_en +++ b/tests/test_date/bad/rounding_option_conflict.catala_en @@ -28,12 +28,12 @@ $ catala Interpret -s Test [ERROR] You cannot set multiple date rounding modes -┌─⯈ tests/test_date/bad/rounding_option_conflict.catala_en:10.14-10.24: +┌─⯈ rounding_option_conflict.catala_en:10.14-10.24: └──┐ 10 │ date round decreasing │ ‾‾‾‾‾‾‾‾‾‾ -┌─⯈ tests/test_date/bad/rounding_option_conflict.catala_en:12.14-12.24: +┌─⯈ rounding_option_conflict.catala_en:12.14-12.24: └──┐ 12 │ date round increasing │ ‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_date/bad/uncomparable_duration.catala_en b/tests/test_date/bad/uncomparable_duration.catala_en index 4fbed2e8..d7b10a3b 100644 --- a/tests/test_date/bad/uncomparable_duration.catala_en +++ b/tests/test_date/bad/uncomparable_duration.catala_en @@ -45,14 +45,14 @@ $ catala Interpret -s Ge [ERROR] Cannot compare together durations that cannot be converted to a precise number of days -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:40.23-40.30: +┌─⯈ uncomparable_duration.catala_en:40.23-40.30: └──┐ 40 │ definition d equals 1 month >= 2 day │ ‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `>=` operator -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:40.34-40.39: +┌─⯈ uncomparable_duration.catala_en:40.34-40.39: └──┐ 40 │ definition d equals 1 month >= 2 day │ ‾‾‾‾‾ @@ -66,14 +66,14 @@ $ catala Interpret -s Gt [ERROR] Cannot compare together durations that cannot be converted to a precise number of days -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:30.23-30.30: +┌─⯈ uncomparable_duration.catala_en:30.23-30.30: └──┐ 30 │ definition d equals 1 month > 2 day │ ‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:30.33-30.38: +┌─⯈ uncomparable_duration.catala_en:30.33-30.38: └──┐ 30 │ definition d equals 1 month > 2 day │ ‾‾‾‾‾ @@ -87,14 +87,14 @@ $ catala Interpret -s Le [ERROR] Cannot compare together durations that cannot be converted to a precise number of days -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:20.23-20.30: +┌─⯈ uncomparable_duration.catala_en:20.23-20.30: └──┐ 20 │ definition d equals 1 month <= 2 day │ ‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:20.34-20.39: +┌─⯈ uncomparable_duration.catala_en:20.34-20.39: └──┐ 20 │ definition d equals 1 month <= 2 day │ ‾‾‾‾‾ @@ -108,14 +108,14 @@ $ catala Interpret -s Lt [ERROR] Cannot compare together durations that cannot be converted to a precise number of days -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:10.23-10.30: +┌─⯈ uncomparable_duration.catala_en:10.23-10.30: └──┐ 10 │ definition d equals 1 month < 2 day │ ‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<` operator -┌─⯈ tests/test_date/bad/uncomparable_duration.catala_en:10.33-10.38: +┌─⯈ uncomparable_duration.catala_en:10.33-10.38: └──┐ 10 │ definition d equals 1 month < 2 day │ ‾‾‾‾‾ diff --git a/tests/test_default/bad/conflict.catala_en b/tests/test_default/bad/conflict.catala_en index 1a827d42..aebea13a 100644 --- a/tests/test_default/bad/conflict.catala_en +++ b/tests/test_default/bad/conflict.catala_en @@ -11,8 +11,8 @@ scope A: ```catala-test-inline $ catala Interpret -s A --message=gnu -tests/test_default/bad/conflict.catala_en:8.56-8.57: [ERROR] There is a conflict between multiple valid consequences for assigning the same variable. -tests/test_default/bad/conflict.catala_en:8.56-8.57: [ERROR] This consequence has a valid justification: -tests/test_default/bad/conflict.catala_en:9.56-9.57: [ERROR] This consequence has a valid justification: +conflict.catala_en:8.56-8.57: [ERROR] There is a conflict between multiple valid consequences for assigning the same variable. +conflict.catala_en:8.56-8.57: [ERROR] This consequence has a valid justification: +conflict.catala_en:9.56-9.57: [ERROR] This consequence has a valid justification: #return code 123# ``` diff --git a/tests/test_default/bad/empty.catala_en b/tests/test_default/bad/empty.catala_en index f25e7747..0a5181f7 100644 --- a/tests/test_default/bad/empty.catala_en +++ b/tests/test_default/bad/empty.catala_en @@ -13,7 +13,7 @@ scope A: $ catala Interpret -s A [WARNING] In scope "A", the variable "y" is declared but never defined; did you forget something? -┌─⯈ tests/test_default/bad/empty.catala_en:6.10-6.11: +┌─⯈ empty.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ @@ -21,7 +21,7 @@ $ catala Interpret -s A [ERROR] This variable evaluated to an empty term (no rule that defined it applied in this situation) -┌─⯈ tests/test_default/bad/empty.catala_en:6.10-6.11: +┌─⯈ empty.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_default/bad/empty_with_rules.catala_en b/tests/test_default/bad/empty_with_rules.catala_en index f8271e06..d4c682a4 100644 --- a/tests/test_default/bad/empty_with_rules.catala_en +++ b/tests/test_default/bad/empty_with_rules.catala_en @@ -17,7 +17,7 @@ $ catala Interpret -s A [ERROR] This variable evaluated to an empty term (no rule that defined it applied in this situation) -┌─⯈ tests/test_default/bad/empty_with_rules.catala_en:5.10-5.11: +┌─⯈ empty_with_rules.catala_en:5.10-5.11: └─┐ 5 │ output x content integer │ ‾ diff --git a/tests/test_default/bad/typing_or_logical_error.catala_en b/tests/test_default/bad/typing_or_logical_error.catala_en index b22a00ea..cc9e84ec 100644 --- a/tests/test_default/bad/typing_or_logical_error.catala_en +++ b/tests/test_default/bad/typing_or_logical_error.catala_en @@ -21,13 +21,13 @@ or "under condition", or "." Error token: -┌─⯈ tests/test_default/bad/typing_or_logical_error.catala_en:8.30-8.31: +┌─⯈ typing_or_logical_error.catala_en:8.30-8.31: └─┐ 8 │ definition wrong_definition = 1 │ ‾ Last good token: -┌─⯈ tests/test_default/bad/typing_or_logical_error.catala_en:8.13-8.29: +┌─⯈ typing_or_logical_error.catala_en:8.13-8.29: └─┐ 8 │ definition wrong_definition = 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_default/good/mutliple_definitions.catala_en b/tests/test_default/good/mutliple_definitions.catala_en index 23da3b31..d02122cc 100644 --- a/tests/test_default/good/mutliple_definitions.catala_en +++ b/tests/test_default/good/mutliple_definitions.catala_en @@ -13,12 +13,12 @@ scope A: $ catala Interpret -s A [WARNING] These definitions have identical justifications and consequences; is it a mistake? -┌─⯈ tests/test_default/good/mutliple_definitions.catala_en:9.3-9.15: +┌─⯈ mutliple_definitions.catala_en:9.3-9.15: └─┐ 9 │ definition w equals 3 │ ‾‾‾‾‾‾‾‾‾‾‾‾ -┌─⯈ tests/test_default/good/mutliple_definitions.catala_en:6.3-6.15: +┌─⯈ mutliple_definitions.catala_en:6.3-6.15: └─┐ 6 │ definition w equals 3 │ ‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/ambiguous_cases.catala_en b/tests/test_enum/bad/ambiguous_cases.catala_en index 1c7fb1a2..42b3efbb 100644 --- a/tests/test_enum/bad/ambiguous_cases.catala_en +++ b/tests/test_enum/bad/ambiguous_cases.catala_en @@ -19,7 +19,7 @@ $ catala Interpret -s A [ERROR] This constructor name is ambiguous, it can belong to E or F. Desambiguate it by prefixing it with the enum name. -┌─⯈ tests/test_enum/bad/ambiguous_cases.catala_en:14.23-14.28: +┌─⯈ ambiguous_cases.catala_en:14.23-14.28: └──┐ 14 │ definition e equals Case1 │ ‾‾‾‾‾ diff --git a/tests/test_enum/bad/ambiguous_wildcard.catala_en b/tests/test_enum/bad/ambiguous_wildcard.catala_en index 1b9c2ece..76a5b2da 100644 --- a/tests/test_enum/bad/ambiguous_wildcard.catala_en +++ b/tests/test_enum/bad/ambiguous_wildcard.catala_en @@ -20,7 +20,7 @@ $ catala Interpret -s A [ERROR] Couldn't infer the enumeration name from lonely wildcard (wildcard cannot be used as single match case) -┌─⯈ tests/test_enum/bad/ambiguous_wildcard.catala_en:15.5-15.21: +┌─⯈ ambiguous_wildcard.catala_en:15.5-15.21: └──┐ 15 │ -- anything : 31 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/duplicate_case.catala_en b/tests/test_enum/bad/duplicate_case.catala_en index 1e31355e..f846fe56 100644 --- a/tests/test_enum/bad/duplicate_case.catala_en +++ b/tests/test_enum/bad/duplicate_case.catala_en @@ -23,13 +23,13 @@ $ catala Interpret -s A [ERROR] The constructor Case3 has been matched twice: -┌─⯈ tests/test_enum/bad/duplicate_case.catala_en:18.16-18.20: +┌─⯈ duplicate_case.catala_en:18.16-18.20: └──┐ 18 │ -- Case3 : true │ ‾‾‾‾ └─ Article -┌─⯈ tests/test_enum/bad/duplicate_case.catala_en:17.16-17.21: +┌─⯈ duplicate_case.catala_en:17.16-17.21: └──┐ 17 │ -- Case3 : false │ ‾‾‾‾‾ diff --git a/tests/test_enum/bad/empty.catala_en b/tests/test_enum/bad/empty.catala_en index 94f07b78..7cb7841f 100644 --- a/tests/test_enum/bad/empty.catala_en +++ b/tests/test_enum/bad/empty.catala_en @@ -12,7 +12,7 @@ $ catala Typecheck [ERROR] The enum Foo does not have any cases; give it some for Catala to be able to accept it. -┌─⯈ tests/test_enum/bad/empty.catala_en:4.25-4.28: +┌─⯈ empty.catala_en:4.25-4.28: └─┐ 4 │ declaration enumeration Foo: │ ‾‾‾ diff --git a/tests/test_enum/bad/missing_case.catala_en b/tests/test_enum/bad/missing_case.catala_en index 301df1d3..9be61c2d 100644 --- a/tests/test_enum/bad/missing_case.catala_en +++ b/tests/test_enum/bad/missing_case.catala_en @@ -20,7 +20,7 @@ scope A: $ catala Interpret -s A [WARNING] The constructor "Case3" of enumeration "E" is never used; maybe it's unnecessary? -┌─⯈ tests/test_enum/bad/missing_case.catala_en:7.6-7.11: +┌─⯈ missing_case.catala_en:7.6-7.11: └─┐ 7 │ -- Case3 │ ‾‾‾‾‾ @@ -28,7 +28,7 @@ $ catala Interpret -s A [ERROR] The constructor Case3 of enum E is missing from this pattern matching -┌─⯈ tests/test_enum/bad/missing_case.catala_en:14.25-16.22: +┌─⯈ missing_case.catala_en:14.25-16.22: └──┐ 14 │ definition out equals match e with pattern │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/not_ending_wildcard.catala_en b/tests/test_enum/bad/not_ending_wildcard.catala_en index 2289b0d6..d0f233f6 100644 --- a/tests/test_enum/bad/not_ending_wildcard.catala_en +++ b/tests/test_enum/bad/not_ending_wildcard.catala_en @@ -42,7 +42,7 @@ $ catala Interpret -s First_case Wildcard must be the last match case Not ending wildcard: -┌─⯈ tests/test_enum/bad/not_ending_wildcard.catala_en:19.5-19.21: +┌─⯈ not_ending_wildcard.catala_en:19.5-19.21: └──┐ 19 │ -- anything : 31 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -50,7 +50,7 @@ Not ending wildcard: └─ Wildcard can't be the first case Next reachable case: -┌─⯈ tests/test_enum/bad/not_ending_wildcard.catala_en:20.5-20.18: +┌─⯈ not_ending_wildcard.catala_en:20.5-20.18: └──┐ 20 │ -- Case2 : 42 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -65,7 +65,7 @@ $ catala Interpret -s Middle_case Wildcard must be the last match case Not ending wildcard: -┌─⯈ tests/test_enum/bad/not_ending_wildcard.catala_en:19.5-19.21: +┌─⯈ not_ending_wildcard.catala_en:19.5-19.21: └──┐ 19 │ -- anything : 31 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -73,7 +73,7 @@ Not ending wildcard: └─ Wildcard can't be the first case Next reachable case: -┌─⯈ tests/test_enum/bad/not_ending_wildcard.catala_en:20.5-20.18: +┌─⯈ not_ending_wildcard.catala_en:20.5-20.18: └──┐ 20 │ -- Case2 : 42 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/quick_pattern_2.catala_en b/tests/test_enum/bad/quick_pattern_2.catala_en index 737a6184..712b826b 100644 --- a/tests/test_enum/bad/quick_pattern_2.catala_en +++ b/tests/test_enum/bad/quick_pattern_2.catala_en @@ -36,21 +36,21 @@ Error during typechecking, incompatible types: └─⯈ F Error coming from typechecking the following expression: -┌─⯈ tests/test_enum/bad/quick_pattern_2.catala_en:28.23-28.24: +┌─⯈ quick_pattern_2.catala_en:28.23-28.24: └──┐ 28 │ definition y equals x with pattern Case3 │ ‾ └─ Article Type E coming from expression: -┌─⯈ tests/test_enum/bad/quick_pattern_2.catala_en:17.21-17.22: +┌─⯈ quick_pattern_2.catala_en:17.21-17.22: └──┐ 17 │ context x content E │ ‾ └─ Article Type F coming from expression: -┌─⯈ tests/test_enum/bad/quick_pattern_2.catala_en:28.23-28.43: +┌─⯈ quick_pattern_2.catala_en:28.23-28.43: └──┐ 28 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/quick_pattern_3.catala_en b/tests/test_enum/bad/quick_pattern_3.catala_en index d7589c9b..d0910ca9 100644 --- a/tests/test_enum/bad/quick_pattern_3.catala_en +++ b/tests/test_enum/bad/quick_pattern_3.catala_en @@ -26,21 +26,21 @@ Error during typechecking, incompatible types: └─⯈ F Error coming from typechecking the following expression: -┌─⯈ tests/test_enum/bad/quick_pattern_3.catala_en:18.21-18.22: +┌─⯈ quick_pattern_3.catala_en:18.21-18.22: └──┐ 18 │ definition y equals x with pattern Case3 │ ‾ └─ Article Type E coming from expression: -┌─⯈ tests/test_enum/bad/quick_pattern_3.catala_en:13.19-13.20: +┌─⯈ quick_pattern_3.catala_en:13.19-13.20: └──┐ 13 │ context x content E │ ‾ └─ Article Type F coming from expression: -┌─⯈ tests/test_enum/bad/quick_pattern_3.catala_en:18.21-18.41: +┌─⯈ quick_pattern_3.catala_en:18.21-18.41: └──┐ 18 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/quick_pattern_4.catala_en b/tests/test_enum/bad/quick_pattern_4.catala_en index 9f4d3a1e..7df87aa8 100644 --- a/tests/test_enum/bad/quick_pattern_4.catala_en +++ b/tests/test_enum/bad/quick_pattern_4.catala_en @@ -25,21 +25,21 @@ Error during typechecking, incompatible types: └─⯈ F Error coming from typechecking the following expression: -┌─⯈ tests/test_enum/bad/quick_pattern_4.catala_en:17.21-17.22: +┌─⯈ quick_pattern_4.catala_en:17.21-17.22: └──┐ 17 │ definition y equals x with pattern Case3 │ ‾ └─ Test Type E coming from expression: -┌─⯈ tests/test_enum/bad/quick_pattern_4.catala_en:12.19-12.20: +┌─⯈ quick_pattern_4.catala_en:12.19-12.20: └──┐ 12 │ context x content E │ ‾ └─ Test Type F coming from expression: -┌─⯈ tests/test_enum/bad/quick_pattern_4.catala_en:17.21-17.41: +┌─⯈ quick_pattern_4.catala_en:17.21-17.41: └──┐ 17 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/quick_pattern_fail.catala_en b/tests/test_enum/bad/quick_pattern_fail.catala_en index 67f696b2..e02baf60 100644 --- a/tests/test_enum/bad/quick_pattern_fail.catala_en +++ b/tests/test_enum/bad/quick_pattern_fail.catala_en @@ -22,7 +22,7 @@ The name of this constructor has not been defined before (it's probably a typographical error). Here is your code : -┌─⯈ tests/test_enum/bad/quick_pattern_fail.catala_en:15.38-15.43: +┌─⯈ quick_pattern_fail.catala_en:15.38-15.43: └──┐ 15 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾ diff --git a/tests/test_enum/bad/too_many_cases.catala_en b/tests/test_enum/bad/too_many_cases.catala_en index b4ea2ec2..62b2372d 100644 --- a/tests/test_enum/bad/too_many_cases.catala_en +++ b/tests/test_enum/bad/too_many_cases.catala_en @@ -26,7 +26,7 @@ $ catala Interpret -s A [ERROR] This case matches a constructor of enumeration E but previous case were matching constructors of enumeration F -┌─⯈ tests/test_enum/bad/too_many_cases.catala_en:21.8-21.13: +┌─⯈ too_many_cases.catala_en:21.8-21.13: └──┐ 21 │ -- Case4 : true │ ‾‾‾‾‾ diff --git a/tests/test_enum/bad/useless_wildcard.catala_en b/tests/test_enum/bad/useless_wildcard.catala_en index 97e5ec9f..5c93be6f 100644 --- a/tests/test_enum/bad/useless_wildcard.catala_en +++ b/tests/test_enum/bad/useless_wildcard.catala_en @@ -21,7 +21,7 @@ scope A: $ catala Interpret -s A [WARNING] Unreachable match case, all constructors of the enumeration E are already specified -┌─⯈ tests/test_enum/bad/useless_wildcard.catala_en:17.5-17.21: +┌─⯈ useless_wildcard.catala_en:17.5-17.21: └──┐ 17 │ -- anything : 31 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_enum/bad/wrong_cons.catala_en b/tests/test_enum/bad/wrong_cons.catala_en index 323fc0cf..c46febfb 100644 --- a/tests/test_enum/bad/wrong_cons.catala_en +++ b/tests/test_enum/bad/wrong_cons.catala_en @@ -18,7 +18,7 @@ The name of this constructor has not been defined before (it's probably a typographical error). Here is your code : -┌─⯈ tests/test_enum/bad/wrong_cons.catala_en:11.23-11.28: +┌─⯈ wrong_cons.catala_en:11.23-11.28: └──┐ 11 │ definition e equals Case2 │ ‾‾‾‾‾ diff --git a/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en b/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en index db33ac1b..8d9e884d 100644 --- a/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en +++ b/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en @@ -19,7 +19,7 @@ $ catala Interpret -s A This exception can refer to several definitions. Try using labels to disambiguate Ambiguous exception -┌─⯈ tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en:12.3-13.15: +┌─⯈ ambiguous_unlabeled_exception.catala_en:12.3-13.15: └──┐ 12 │ exception │ ‾‾‾‾‾‾‾‾‾ @@ -28,14 +28,14 @@ Ambiguous exception └─ Test Candidate definition -┌─⯈ tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en:10.14-10.15: +┌─⯈ ambiguous_unlabeled_exception.catala_en:10.14-10.15: └──┐ 10 │ definition x equals 1 │ ‾ └─ Test Candidate definition -┌─⯈ tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en:8.14-8.15: +┌─⯈ ambiguous_unlabeled_exception.catala_en:8.14-8.15: └─┐ 8 │ definition x equals 0 │ ‾ diff --git a/tests/test_exception/bad/dangling_exception.catala_en b/tests/test_exception/bad/dangling_exception.catala_en index 1702e1ca..5a8cdd40 100644 --- a/tests/test_exception/bad/dangling_exception.catala_en +++ b/tests/test_exception/bad/dangling_exception.catala_en @@ -18,7 +18,7 @@ $ catala Interpret -s A [ERROR] Unknown label for the scope variable x: "base_y" -┌─⯈ tests/test_exception/bad/dangling_exception.catala_en:12.13-12.19: +┌─⯈ dangling_exception.catala_en:12.13-12.19: └──┐ 12 │ exception base_y │ ‾‾‾‾‾‾ diff --git a/tests/test_exception/bad/exceptions_cycle.catala_en b/tests/test_exception/bad/exceptions_cycle.catala_en index 6fe1f289..c6e2a6ea 100644 --- a/tests/test_exception/bad/exceptions_cycle.catala_en +++ b/tests/test_exception/bad/exceptions_cycle.catala_en @@ -23,7 +23,7 @@ $ catala Interpret -s A [ERROR] Exception cycle detected when defining x: each of these 3 exceptions applies over the previous one, and the first applies over the last -┌─⯈ tests/test_exception/bad/exceptions_cycle.catala_en:8.3-10.15: +┌─⯈ exceptions_cycle.catala_en:8.3-10.15: └──┐ 8 │ label base_x │ ‾‾‾‾‾‾‾‾‾‾‾‾ @@ -32,7 +32,7 @@ Exception cycle detected when defining x: each of these 3 exceptions applies ove 10 │ definition x equals 0 │ ‾‾‾‾‾‾‾‾‾‾‾‾ -┌─⯈ tests/test_exception/bad/exceptions_cycle.catala_en:12.3-14.15: +┌─⯈ exceptions_cycle.catala_en:12.3-14.15: └──┐ 12 │ label exception_x │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -41,7 +41,7 @@ Exception cycle detected when defining x: each of these 3 exceptions applies ove 14 │ definition x equals 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾ -┌─⯈ tests/test_exception/bad/exceptions_cycle.catala_en:16.3-18.15: +┌─⯈ exceptions_cycle.catala_en:16.3-18.15: └──┐ 16 │ label exception_exception_x │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_exception/bad/missing_unlabeled_definition.catala_en b/tests/test_exception/bad/missing_unlabeled_definition.catala_en index 809417b8..a491d56d 100644 --- a/tests/test_exception/bad/missing_unlabeled_definition.catala_en +++ b/tests/test_exception/bad/missing_unlabeled_definition.catala_en @@ -14,7 +14,7 @@ $ catala Interpret -s A [ERROR] This exception does not have a corresponding definition -┌─⯈ tests/test_exception/bad/missing_unlabeled_definition.catala_en:8.3-9.15: +┌─⯈ missing_unlabeled_definition.catala_en:8.3-9.15: └─┐ 8 │ exception │ ‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_exception/bad/one_ambiguous_exception.catala_en b/tests/test_exception/bad/one_ambiguous_exception.catala_en index 26e6b0d7..c9b0045f 100644 --- a/tests/test_exception/bad/one_ambiguous_exception.catala_en +++ b/tests/test_exception/bad/one_ambiguous_exception.catala_en @@ -25,7 +25,7 @@ $ catala Interpret -s A This exception can refer to several definitions. Try using labels to disambiguate Ambiguous exception -┌─⯈ tests/test_exception/bad/one_ambiguous_exception.catala_en:18.3-19.15: +┌─⯈ one_ambiguous_exception.catala_en:18.3-19.15: └──┐ 18 │ exception │ ‾‾‾‾‾‾‾‾‾ @@ -34,14 +34,14 @@ Ambiguous exception └─ Test Candidate definition -┌─⯈ tests/test_exception/bad/one_ambiguous_exception.catala_en:16.14-16.15: +┌─⯈ one_ambiguous_exception.catala_en:16.14-16.15: └──┐ 16 │ definition y equals 4 │ ‾ └─ Test Candidate definition -┌─⯈ tests/test_exception/bad/one_ambiguous_exception.catala_en:14.14-14.15: +┌─⯈ one_ambiguous_exception.catala_en:14.14-14.15: └──┐ 14 │ definition y equals 2 │ ‾ diff --git a/tests/test_exception/bad/self_exception.catala_en b/tests/test_exception/bad/self_exception.catala_en index 4f3237f0..d3bd9a58 100644 --- a/tests/test_exception/bad/self_exception.catala_en +++ b/tests/test_exception/bad/self_exception.catala_en @@ -15,7 +15,7 @@ $ catala Interpret -s A [ERROR] Cannot define rule as an exception to itself -┌─⯈ tests/test_exception/bad/self_exception.catala_en:9.13-9.19: +┌─⯈ self_exception.catala_en:9.13-9.19: └─┐ 9 │ exception base_y │ ‾‾‾‾‾‾ diff --git a/tests/test_exception/bad/two_exceptions.catala_en b/tests/test_exception/bad/two_exceptions.catala_en index 6ad1a93f..8efceda5 100644 --- a/tests/test_exception/bad/two_exceptions.catala_en +++ b/tests/test_exception/bad/two_exceptions.catala_en @@ -21,14 +21,14 @@ $ catala Interpret -s A There is a conflict between multiple valid consequences for assigning the same variable. This consequence has a valid justification: -┌─⯈ tests/test_exception/bad/two_exceptions.catala_en:12.23-12.24: +┌─⯈ two_exceptions.catala_en:12.23-12.24: └──┐ 12 │ definition x equals 1 │ ‾ └─ Test This consequence has a valid justification: -┌─⯈ tests/test_exception/bad/two_exceptions.catala_en:15.23-15.24: +┌─⯈ two_exceptions.catala_en:15.23-15.24: └──┐ 15 │ definition x equals 2 │ ‾ diff --git a/tests/test_exception/good/double_definition.catala_en b/tests/test_exception/good/double_definition.catala_en index e59c5016..f1f8ad35 100644 --- a/tests/test_exception/good/double_definition.catala_en +++ b/tests/test_exception/good/double_definition.catala_en @@ -14,13 +14,13 @@ scope Foo: $ catala Scopelang -s Foo [WARNING] These definitions have identical justifications and consequences; is it a mistake? -┌─⯈ tests/test_exception/good/double_definition.catala_en:9.3-9.15: +┌─⯈ double_definition.catala_en:9.3-9.15: └─┐ 9 │ definition x equals 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾ └─ Foo -┌─⯈ tests/test_exception/good/double_definition.catala_en:8.3-8.15: +┌─⯈ double_definition.catala_en:8.3-8.15: └─┐ 8 │ definition x equals 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾ @@ -39,13 +39,13 @@ Dcalc translation below. $ catala Dcalc -s Foo [WARNING] These definitions have identical justifications and consequences; is it a mistake? -┌─⯈ tests/test_exception/good/double_definition.catala_en:9.3-9.15: +┌─⯈ double_definition.catala_en:9.3-9.15: └─┐ 9 │ definition x equals 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾ └─ Foo -┌─⯈ tests/test_exception/good/double_definition.catala_en:8.3-8.15: +┌─⯈ double_definition.catala_en:8.3-8.15: └─┐ 8 │ definition x equals 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_exception/good/groups_of_exceptions.catala_en b/tests/test_exception/good/groups_of_exceptions.catala_en index 6084643e..323b2606 100644 --- a/tests/test_exception/good/groups_of_exceptions.catala_en +++ b/tests/test_exception/good/groups_of_exceptions.catala_en @@ -50,36 +50,36 @@ $ catala Exceptions -s Foo -v x Printing the tree of exceptions for the definitions of variable "x" of scope "Foo". [RESULT] Definitions with label "base": -┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:9.3-9.26: +┌─⯈ groups_of_exceptions.catala_en:9.3-9.26: └─┐ 9 │ label base definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:13.3-13.26: +┌─⯈ groups_of_exceptions.catala_en:13.3-13.26: └──┐ 13 │ label base definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test [RESULT] Definitions with label "intermediate": -┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:17.3-17.49: +┌─⯈ groups_of_exceptions.catala_en:17.3-17.49: └──┐ 17 │ label intermediate exception base definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:21.3-21.49: +┌─⯈ groups_of_exceptions.catala_en:21.3-21.49: └──┐ 21 │ label intermediate exception base definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test [RESULT] Definitions with label "exception_to_intermediate": -┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:25.3-25.38: +┌─⯈ groups_of_exceptions.catala_en:25.3-25.38: └──┐ 25 │ exception intermediate definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:29.3-29.38: +┌─⯈ groups_of_exceptions.catala_en:29.3-29.38: └──┐ 29 │ exception intermediate definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_func/bad/bad_func.catala_en b/tests/test_func/bad/bad_func.catala_en index 8df80939..669bc7b8 100644 --- a/tests/test_func/bad/bad_func.catala_en +++ b/tests/test_func/bad/bad_func.catala_en @@ -33,14 +33,14 @@ $ catala Interpret -s S There is a conflict between multiple valid consequences for assigning the same variable. This consequence has a valid justification: -┌─⯈ tests/test_func/bad/bad_func.catala_en:14.65-14.70: +┌─⯈ bad_func.catala_en:14.65-14.70: └──┐ 14 │ definition f of x under condition (x >= x) consequence equals x + x │ ‾‾‾‾‾ └─ Article This consequence has a valid justification: -┌─⯈ tests/test_func/bad/bad_func.catala_en:15.62-15.67: +┌─⯈ bad_func.catala_en:15.62-15.67: └──┐ 15 │ definition f of x under condition not b consequence equals x * x │ ‾‾‾‾‾ diff --git a/tests/test_func/bad/param_inconsistency.catala_en b/tests/test_func/bad/param_inconsistency.catala_en index 3b30b92c..eaa08329 100644 --- a/tests/test_func/bad/param_inconsistency.catala_en +++ b/tests/test_func/bad/param_inconsistency.catala_en @@ -18,13 +18,13 @@ $ catala typecheck Function argument name mismatch between declaration ('x') and definition ('y') Argument declared here: -┌─⯈ tests/test_func/bad/param_inconsistency.catala_en:4.42-4.43: +┌─⯈ param_inconsistency.catala_en:4.42-4.43: └─┐ 4 │ internal f1 content decimal depends on x content integer │ ‾ Defined here: -┌─⯈ tests/test_func/bad/param_inconsistency.catala_en:10.20-10.21: +┌─⯈ param_inconsistency.catala_en:10.20-10.21: └──┐ 10 │ definition f1 of y under condition not cond │ ‾ diff --git a/tests/test_func/bad/param_inconsistency2.catala_en b/tests/test_func/bad/param_inconsistency2.catala_en index 25b97ff8..de42fd26 100644 --- a/tests/test_func/bad/param_inconsistency2.catala_en +++ b/tests/test_func/bad/param_inconsistency2.catala_en @@ -17,13 +17,13 @@ $ catala typecheck Function argument name mismatch between declaration ('x') and definition ('y') Argument declared here: -┌─⯈ tests/test_func/bad/param_inconsistency2.catala_en:4.42-4.43: +┌─⯈ param_inconsistency2.catala_en:4.42-4.43: └─┐ 4 │ internal f1 content decimal depends on x content integer │ ‾ Defined here: -┌─⯈ tests/test_func/bad/param_inconsistency2.catala_en:9.30-9.31: +┌─⯈ param_inconsistency2.catala_en:9.30-9.31: └─┐ 9 │ exception definition f1 of y under condition not cond │ ‾ diff --git a/tests/test_func/bad/param_inconsistency3.catala_en b/tests/test_func/bad/param_inconsistency3.catala_en index 4072b062..be09466f 100644 --- a/tests/test_func/bad/param_inconsistency3.catala_en +++ b/tests/test_func/bad/param_inconsistency3.catala_en @@ -17,13 +17,13 @@ $ catala typecheck Function argument name mismatch between declaration ('x') and definition ('y') Argument declared here: -┌─⯈ tests/test_func/bad/param_inconsistency3.catala_en:4.42-4.43: +┌─⯈ param_inconsistency3.catala_en:4.42-4.43: └─┐ 4 │ internal f1 content decimal depends on x content integer │ ‾ Defined here: -┌─⯈ tests/test_func/bad/param_inconsistency3.catala_en:9.30-9.31: +┌─⯈ param_inconsistency3.catala_en:9.30-9.31: └─┐ 9 │ exception definition f1 of y under condition not cond │ ‾ diff --git a/tests/test_func/bad/recursive.catala_en b/tests/test_func/bad/recursive.catala_en index 8258ae81..54c0a5e0 100644 --- a/tests/test_func/bad/recursive.catala_en +++ b/tests/test_func/bad/recursive.catala_en @@ -13,7 +13,7 @@ $ catala Interpret -s RecursiveFunc [ERROR] The variable f is used in one of its definitions, but recursion is forbidden in Catala -┌─⯈ tests/test_func/bad/recursive.catala_en:8.28-8.29: +┌─⯈ recursive.catala_en:8.28-8.29: └─┐ 8 │ definition f of x equals f of x + 1 │ ‾ diff --git a/tests/test_func/good/closure_conversion.catala_en b/tests/test_func/good/closure_conversion.catala_en index 9b4cbb26..69a021d1 100644 --- a/tests/test_func/good/closure_conversion.catala_en +++ b/tests/test_func/good/closure_conversion.catala_en @@ -15,9 +15,9 @@ scope S: $ catala Lcalc --avoid_exceptions -O --closure_conversion type eoption = | ENone of unit | ESome of any -type S = { z: eoption integer; } - type S_in = { x_in: eoption bool; } + +type S = { z: eoption integer; } let topval closure_f : (closure_env, integer) → eoption integer = λ (env: closure_env) (y: integer) → diff --git a/tests/test_func/good/closure_return.catala_en b/tests/test_func/good/closure_return.catala_en index fea06f77..4e26c81c 100644 --- a/tests/test_func/good/closure_return.catala_en +++ b/tests/test_func/good/closure_return.catala_en @@ -13,11 +13,11 @@ scope S: $ catala Lcalc --avoid_exceptions -O --closure_conversion type eoption = | ENone of unit | ESome of any +type S_in = { x_in: eoption bool; } + type S = { f: eoption ((closure_env, integer) → eoption integer * closure_env); } - -type S_in = { x_in: eoption bool; } let topval closure_f : (closure_env, integer) → eoption integer = λ (env: closure_env) (y: integer) → diff --git a/tests/test_func/good/context_func.catala_en b/tests/test_func/good/context_func.catala_en index 467b95b5..9461537a 100644 --- a/tests/test_func/good/context_func.catala_en +++ b/tests/test_func/good/context_func.catala_en @@ -21,21 +21,21 @@ $ catala Scopelang -s B It is impossible to give a definition to a subscope variable not tagged as input or context. Incriminated subscope: -┌─⯈ tests/test_func/good/context_func.catala_en:9.3-9.4: +┌─⯈ context_func.catala_en:9.3-9.4: └─┐ 9 │ a scope A │ ‾ └─ Test Incriminated variable: -┌─⯈ tests/test_func/good/context_func.catala_en:5.10-5.11: +┌─⯈ context_func.catala_en:5.10-5.11: └─┐ 5 │ output f content integer depends on x content integer │ ‾ └─ Test Incriminated subscope variable definition: -┌─⯈ tests/test_func/good/context_func.catala_en:15.3-15.17: +┌─⯈ context_func.catala_en:15.3-15.17: └──┐ 15 │ definition a.f of x under condition b and x > 0 consequence equals x - 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -48,21 +48,21 @@ $ catala Dcalc -s A It is impossible to give a definition to a subscope variable not tagged as input or context. Incriminated subscope: -┌─⯈ tests/test_func/good/context_func.catala_en:9.3-9.4: +┌─⯈ context_func.catala_en:9.3-9.4: └─┐ 9 │ a scope A │ ‾ └─ Test Incriminated variable: -┌─⯈ tests/test_func/good/context_func.catala_en:5.10-5.11: +┌─⯈ context_func.catala_en:5.10-5.11: └─┐ 5 │ output f content integer depends on x content integer │ ‾ └─ Test Incriminated subscope variable definition: -┌─⯈ tests/test_func/good/context_func.catala_en:15.3-15.17: +┌─⯈ context_func.catala_en:15.3-15.17: └──┐ 15 │ definition a.f of x under condition b and x > 0 consequence equals x - 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -75,21 +75,21 @@ $ catala Dcalc -s B It is impossible to give a definition to a subscope variable not tagged as input or context. Incriminated subscope: -┌─⯈ tests/test_func/good/context_func.catala_en:9.3-9.4: +┌─⯈ context_func.catala_en:9.3-9.4: └─┐ 9 │ a scope A │ ‾ └─ Test Incriminated variable: -┌─⯈ tests/test_func/good/context_func.catala_en:5.10-5.11: +┌─⯈ context_func.catala_en:5.10-5.11: └─┐ 5 │ output f content integer depends on x content integer │ ‾ └─ Test Incriminated subscope variable definition: -┌─⯈ tests/test_func/good/context_func.catala_en:15.3-15.17: +┌─⯈ context_func.catala_en:15.3-15.17: └──┐ 15 │ definition a.f of x under condition b and x > 0 consequence equals x - 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_func/good/scope_call_func_struct_closure.catala_en b/tests/test_func/good/scope_call_func_struct_closure.catala_en index cefbbbf6..26c8fe89 100644 --- a/tests/test_func/good/scope_call_func_struct_closure.catala_en +++ b/tests/test_func/good/scope_call_func_struct_closure.catala_en @@ -49,23 +49,23 @@ type Result = { q: eoption integer; } +type SubFoo1_in = { x_in: eoption integer; } + type SubFoo1 = { x: eoption integer; y: eoption ((closure_env, integer) → eoption integer * closure_env); } +type SubFoo2_in = { x1_in: eoption integer; x2_in: eoption integer; } + type SubFoo2 = { x1: eoption integer; y: eoption ((closure_env, integer) → eoption integer * closure_env); } -type Foo = { z: eoption integer; } - -type SubFoo1_in = { x_in: eoption integer; } - -type SubFoo2_in = { x1_in: eoption integer; x2_in: eoption integer; } - type Foo_in = { b_in: eoption bool; } + +type Foo = { z: eoption integer; } let topval closure_y : (closure_env, integer) → eoption integer = λ (env: closure_env) (z: integer) → diff --git a/tests/test_io/bad/forgot_input.catala_en b/tests/test_io/bad/forgot_input.catala_en index 75a69a08..6923bf0f 100644 --- a/tests/test_io/bad/forgot_input.catala_en +++ b/tests/test_io/bad/forgot_input.catala_en @@ -20,14 +20,14 @@ $ catala Typecheck This subscope variable is a mandatory input but no definition was provided. Incriminated subscope: -┌─⯈ tests/test_io/bad/forgot_input.catala_en:9.3-9.4: +┌─⯈ forgot_input.catala_en:9.3-9.4: └─┐ 9 │ a scope A │ ‾ └─ Test Incriminated variable: -┌─⯈ tests/test_io/bad/forgot_input.catala_en:6.9-6.10: +┌─⯈ forgot_input.catala_en:6.9-6.10: └─┐ 6 │ input x content integer │ ‾ diff --git a/tests/test_io/bad/inputing_to_not_input.catala_en b/tests/test_io/bad/inputing_to_not_input.catala_en index f7964339..392aaca4 100644 --- a/tests/test_io/bad/inputing_to_not_input.catala_en +++ b/tests/test_io/bad/inputing_to_not_input.catala_en @@ -20,21 +20,21 @@ $ catala Typecheck It is impossible to give a definition to a subscope variable not tagged as input or context. Incriminated subscope: -┌─⯈ tests/test_io/bad/inputing_to_not_input.catala_en:8.3-8.4: +┌─⯈ inputing_to_not_input.catala_en:8.3-8.4: └─┐ 8 │ a scope A │ ‾ └─ Test Incriminated variable: -┌─⯈ tests/test_io/bad/inputing_to_not_input.catala_en:5.10-5.11: +┌─⯈ inputing_to_not_input.catala_en:5.10-5.11: └─┐ 5 │ output a content integer │ ‾ └─ Test Incriminated subscope variable definition: -┌─⯈ tests/test_io/bad/inputing_to_not_input.catala_en:14.3-14.17: +┌─⯈ inputing_to_not_input.catala_en:14.3-14.17: └──┐ 14 │ definition a.a equals 0 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_io/bad/redefining_input.catala_en b/tests/test_io/bad/redefining_input.catala_en index aa469500..6faf8a76 100644 --- a/tests/test_io/bad/redefining_input.catala_en +++ b/tests/test_io/bad/redefining_input.catala_en @@ -13,14 +13,14 @@ $ catala Typecheck It is impossible to give a definition to a scope variable tagged as input. Incriminated variable: -┌─⯈ tests/test_io/bad/redefining_input.catala_en:5.16-5.17: +┌─⯈ redefining_input.catala_en:5.16-5.17: └─┐ 5 │ input output a content integer │ ‾ └─ Test Incriminated variable definition: -┌─⯈ tests/test_io/bad/redefining_input.catala_en:8.3-8.15: +┌─⯈ redefining_input.catala_en:8.3-8.15: └─┐ 8 │ definition a equals 0 │ ‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_io/bad/using_non_output.catala_en b/tests/test_io/bad/using_non_output.catala_en index f624e436..2fb0f916 100644 --- a/tests/test_io/bad/using_non_output.catala_en +++ b/tests/test_io/bad/using_non_output.catala_en @@ -17,7 +17,7 @@ scope B: $ catala Typecheck [WARNING] This variable is dead code; it does not contribute to computing any of scope "A" outputs. Did you forget something? -┌─⯈ tests/test_io/bad/using_non_output.catala_en:5.12-5.13: +┌─⯈ using_non_output.catala_en:5.12-5.13: └─┐ 5 │ internal a content integer │ ‾ @@ -26,21 +26,21 @@ $ catala Typecheck The variable a.a cannot be used here, as it is not part of subscope a's results. Maybe you forgot to qualify it as an output? Incriminated variable usage: -┌─⯈ tests/test_io/bad/using_non_output.catala_en:14.13-14.16: +┌─⯈ using_non_output.catala_en:14.13-14.16: └──┐ 14 │ assertion a.a = 0 │ ‾‾‾ └─ Test Incriminated subscope variable declaration: -┌─⯈ tests/test_io/bad/using_non_output.catala_en:5.12-5.13: +┌─⯈ using_non_output.catala_en:5.12-5.13: └─┐ 5 │ internal a content integer │ ‾ └─ Test Incriminated subscope declaration: -┌─⯈ tests/test_io/bad/using_non_output.catala_en:8.3-8.4: +┌─⯈ using_non_output.catala_en:8.3-8.4: └─┐ 8 │ a scope A │ ‾ diff --git a/tests/test_modules/good/mod_def.catala_en b/tests/test_modules/good/mod_def.catala_en new file mode 100644 index 00000000..33e89205 --- /dev/null +++ b/tests/test_modules/good/mod_def.catala_en @@ -0,0 +1,26 @@ +# Test modules + inclusions 1 + +```catala-metadata +declaration enumeration Enum1: + -- Yes + -- No + -- Maybe + +declaration scope S: + output sr content money + output e1 content Enum1 + +declaration half content decimal + depends on x content integer + equals x / 2 +``` + +```catala +scope S: + definition sr equals $1,000 + definition e1 equals Maybe +``` + +```catala-test-inline +$ catala module --compile --plugin-dir=../../../_build/default/compiler/plugins --disable_warnings +``` diff --git a/tests/test_modules/good/mod_use.catala_en b/tests/test_modules/good/mod_use.catala_en new file mode 100644 index 00000000..22b29fe6 --- /dev/null +++ b/tests/test_modules/good/mod_use.catala_en @@ -0,0 +1,30 @@ +# Test modules + inclusions 2 + +```catala +declaration scope T2: + t1 scope Mod_def.S +# input i content Enum1 + output o1 content Mod_def.Enum1 + output o2 content Mod_def.Enum1 + output o3 content money + output o4 content decimal + +scope T2: + definition o1 equals Mod_def.Enum1.No + definition o2 equals t1.e1 + definition o3 equals t1.sr + definition o4 equals Mod_def.half of 10 + assertion o1 = Mod_def.Enum1.No + assertion o2 = Mod_def.Enum1.Maybe + assertion o3 = $1000 + assertion o4 = 5.0 +``` + +```catala-test-inline +$ catala interpret -s T2 --disable_warnings --use mod_def.catala_en +[RESULT] Computation successful! Results: +[RESULT] o1 = No () +[RESULT] o2 = Maybe () +[RESULT] o3 = $1,000.00 +[RESULT] o4 = 5.0 +``` diff --git a/tests/test_money/bad/no_mingle.catala_en b/tests/test_money/bad/no_mingle.catala_en index f3b5760e..f5eb1af3 100644 --- a/tests/test_money/bad/no_mingle.catala_en +++ b/tests/test_money/bad/no_mingle.catala_en @@ -18,21 +18,21 @@ $ catala Interpret -s A I don't know how to apply operator * on types money and money -┌─⯈ tests/test_money/bad/no_mingle.catala_en:12.26-12.27: +┌─⯈ no_mingle.catala_en:12.26-12.27: └──┐ 12 │ definition z equals (x * y) │ ‾ └─ Article Type money coming from expression: -┌─⯈ tests/test_money/bad/no_mingle.catala_en:5.21-5.26: +┌─⯈ no_mingle.catala_en:5.21-5.26: └─┐ 5 │ context x content money │ ‾‾‾‾‾ └─ Article Type money coming from expression: -┌─⯈ tests/test_money/bad/no_mingle.catala_en:6.21-6.26: +┌─⯈ no_mingle.catala_en:6.21-6.26: └─┐ 6 │ context y content money │ ‾‾‾‾‾ diff --git a/tests/test_name_resolution/bad/toplevel_defs.catala_en b/tests/test_name_resolution/bad/toplevel_defs.catala_en index 0260932e..a5213d30 100644 --- a/tests/test_name_resolution/bad/toplevel_defs.catala_en +++ b/tests/test_name_resolution/bad/toplevel_defs.catala_en @@ -16,7 +16,7 @@ $ catala typecheck [ERROR] Scope calls are not allowed outside of a scope -┌─⯈ tests/test_name_resolution/bad/toplevel_defs.catala_en:11.11-11.23: +┌─⯈ toplevel_defs.catala_en:11.11-11.23: └──┐ 11 │ equals (output of S1).a │ ‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_name_resolution/good/let_in2.catala_en b/tests/test_name_resolution/good/let_in2.catala_en index 75025f8e..d746a4ff 100644 --- a/tests/test_name_resolution/good/let_in2.catala_en +++ b/tests/test_name_resolution/good/let_in2.catala_en @@ -37,14 +37,14 @@ module S = struct type t = {a: bool} end -module SIn = struct +module S_in = struct type t = {a_in: unit -> bool} end -let s (s_in: SIn.t) : S.t = - let a_: unit -> bool = s_in.SIn.a_in in +let s (s_in: S_in.t) : S.t = + let a_: unit -> bool = s_in.S_in.a_in in let a_: bool = try (handle_default @@ -62,9 +62,8 @@ let s (s_in: SIn.t) : S.t = a_))))) with EmptyError -> (raise (NoValueProvided - {filename = "tests/test_name_resolution/good/let_in2.catala_en"; - start_line=5; start_column=18; end_line=5; end_column=19; - law_headings=["Article"]})) in + {filename = "let_in2.catala_en"; start_line=5; start_column=18; + end_line=5; end_column=19; law_headings=["Article"]})) in {S.a = a_} let () = Runtime_ocaml.Runtime.register_module "Let_in2" diff --git a/tests/test_name_resolution/good/toplevel_defs.catala_en b/tests/test_name_resolution/good/toplevel_defs.catala_en index 12ce43f7..31a81ae3 100644 --- a/tests/test_name_resolution/good/toplevel_defs.catala_en +++ b/tests/test_name_resolution/good/toplevel_defs.catala_en @@ -384,7 +384,7 @@ def s2(s2_in:S2In): law_headings=[]), [], temp_a_1, temp_a) except EmptyError: temp_a_2 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en", + raise NoValueProvided(SourcePosition(filename="toplevel_defs.catala_en", start_line=37, start_column=10, end_line=37, end_column=11, law_headings=["Test toplevel function defs"])) @@ -404,7 +404,7 @@ def s3(s3_in:S3In): law_headings=[]), [], temp_a_4, temp_a_3) except EmptyError: temp_a_5 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en", + raise NoValueProvided(SourcePosition(filename="toplevel_defs.catala_en", start_line=57, start_column=10, end_line=57, end_column=11, law_headings=["Test function def with two args"])) @@ -422,7 +422,7 @@ def s4(s4_in:S4In): law_headings=[]), [], temp_a_7, temp_a_6) except EmptyError: temp_a_8 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en", + raise NoValueProvided(SourcePosition(filename="toplevel_defs.catala_en", start_line=80, start_column=10, end_line=80, end_column=11, law_headings=["Test inline defs in toplevel defs"])) @@ -440,7 +440,7 @@ def s(s_in:SIn): law_headings=[]), [], temp_a_10, temp_a_9) except EmptyError: temp_a_11 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en", + raise NoValueProvided(SourcePosition(filename="toplevel_defs.catala_en", start_line=7, start_column=10, end_line=7, end_column=11, law_headings=["Test basic toplevel values defs"])) @@ -455,7 +455,7 @@ def s(s_in:SIn): law_headings=[]), [], temp_b_1, temp_b) except EmptyError: temp_b_2 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en", + raise NoValueProvided(SourcePosition(filename="toplevel_defs.catala_en", start_line=8, start_column=10, end_line=8, end_column=11, law_headings=["Test basic toplevel values defs"])) diff --git a/tests/test_proof/bad/array_length-empty.catala_en b/tests/test_proof/bad/array_length-empty.catala_en index 72066f25..736efca6 100644 --- a/tests/test_proof/bad/array_length-empty.catala_en +++ b/tests/test_proof/bad/array_length-empty.catala_en @@ -13,7 +13,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/array_length-empty.catala_en:6.10-6.11: +┌─⯈ array_length-empty.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/array_length-overlap.catala_en b/tests/test_proof/bad/array_length-overlap.catala_en index 981b663e..c49a4a56 100644 --- a/tests/test_proof/bad/array_length-overlap.catala_en +++ b/tests/test_proof/bad/array_length-overlap.catala_en @@ -14,7 +14,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/array_length-overlap.catala_en:6.10-6.11: +┌─⯈ array_length-overlap.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/assert-empty.catala_en b/tests/test_proof/bad/assert-empty.catala_en index 2fe7b4d9..1460b8c8 100644 --- a/tests/test_proof/bad/assert-empty.catala_en +++ b/tests/test_proof/bad/assert-empty.catala_en @@ -25,7 +25,7 @@ scope Foo: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [Foo.x] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/assert-empty.catala_en:4.11-4.12: +┌─⯈ assert-empty.catala_en:4.11-4.12: └─┐ 4 │ output x content integer │ ‾ diff --git a/tests/test_proof/bad/dates_get_year-empty.catala_en b/tests/test_proof/bad/dates_get_year-empty.catala_en index df86f265..2f94bddd 100644 --- a/tests/test_proof/bad/dates_get_year-empty.catala_en +++ b/tests/test_proof/bad/dates_get_year-empty.catala_en @@ -19,14 +19,14 @@ $ catala Proof --disable_counterexamples It is impossible to give a definition to a scope variable tagged as input. Incriminated variable: -┌─⯈ tests/test_proof/bad/dates_get_year-empty.catala_en:5.9-5.10: +┌─⯈ dates_get_year-empty.catala_en:5.9-5.10: └─┐ 5 │ input x content date │ ‾ └─ Test Incriminated variable definition: -┌─⯈ tests/test_proof/bad/dates_get_year-empty.catala_en:9.3-9.15: +┌─⯈ dates_get_year-empty.catala_en:9.3-9.15: └─┐ 9 │ definition x equals |2022-01-16| │ ‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_proof/bad/dates_get_year-overlap.catala_en b/tests/test_proof/bad/dates_get_year-overlap.catala_en index dca3c26a..65c84cb9 100644 --- a/tests/test_proof/bad/dates_get_year-overlap.catala_en +++ b/tests/test_proof/bad/dates_get_year-overlap.catala_en @@ -16,7 +16,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/dates_get_year-overlap.catala_en:6.10-6.11: +┌─⯈ dates_get_year-overlap.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/dates_simple-empty.catala_en b/tests/test_proof/bad/dates_simple-empty.catala_en index 21c8ee2e..4d7aecc3 100644 --- a/tests/test_proof/bad/dates_simple-empty.catala_en +++ b/tests/test_proof/bad/dates_simple-empty.catala_en @@ -15,7 +15,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/dates_simple-empty.catala_en:6.10-6.11: +┌─⯈ dates_simple-empty.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/dates_simple-overlap.catala_en b/tests/test_proof/bad/dates_simple-overlap.catala_en index ad495241..0603ca9d 100644 --- a/tests/test_proof/bad/dates_simple-overlap.catala_en +++ b/tests/test_proof/bad/dates_simple-overlap.catala_en @@ -16,7 +16,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/dates_simple-overlap.catala_en:6.10-6.11: +┌─⯈ dates_simple-overlap.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/duration-empty.catala_en b/tests/test_proof/bad/duration-empty.catala_en index ac710b8a..70d9985c 100644 --- a/tests/test_proof/bad/duration-empty.catala_en +++ b/tests/test_proof/bad/duration-empty.catala_en @@ -13,7 +13,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/duration-empty.catala_en:6.10-6.11: +┌─⯈ duration-empty.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/duration-overlap.catala_en b/tests/test_proof/bad/duration-overlap.catala_en index e3bad00d..4a84581a 100644 --- a/tests/test_proof/bad/duration-overlap.catala_en +++ b/tests/test_proof/bad/duration-overlap.catala_en @@ -14,7 +14,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/duration-overlap.catala_en:6.10-6.11: +┌─⯈ duration-overlap.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/enums-empty.catala_en b/tests/test_proof/bad/enums-empty.catala_en index 81d1ca84..9d522c92 100644 --- a/tests/test_proof/bad/enums-empty.catala_en +++ b/tests/test_proof/bad/enums-empty.catala_en @@ -25,13 +25,13 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/bad/enums-empty.catala_en:7.7-7.8: +┌─⯈ enums-empty.catala_en:7.7-7.8: └─┐ 7 │ -- C content boolean │ ‾ └─ Test [WARNING] [A.x] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/enums-empty.catala_en:15.10-15.11: +┌─⯈ enums-empty.catala_en:15.10-15.11: └──┐ 15 │ output x content integer │ ‾ diff --git a/tests/test_proof/bad/enums-nonbool-empty.catala_en b/tests/test_proof/bad/enums-nonbool-empty.catala_en index 5e19edb3..b35d1872 100644 --- a/tests/test_proof/bad/enums-nonbool-empty.catala_en +++ b/tests/test_proof/bad/enums-nonbool-empty.catala_en @@ -23,13 +23,13 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/bad/enums-nonbool-empty.catala_en:5.7-5.8: +┌─⯈ enums-nonbool-empty.catala_en:5.7-5.8: └─┐ 5 │ -- C content boolean │ ‾ └─ Test [WARNING] [A.x] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/enums-nonbool-empty.catala_en:13.10-13.11: +┌─⯈ enums-nonbool-empty.catala_en:13.10-13.11: └──┐ 13 │ output x content integer │ ‾ diff --git a/tests/test_proof/bad/enums-nonbool-overlap.catala_en b/tests/test_proof/bad/enums-nonbool-overlap.catala_en index abf9f561..e196fcd1 100644 --- a/tests/test_proof/bad/enums-nonbool-overlap.catala_en +++ b/tests/test_proof/bad/enums-nonbool-overlap.catala_en @@ -23,13 +23,13 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/bad/enums-nonbool-overlap.catala_en:5.7-5.8: +┌─⯈ enums-nonbool-overlap.catala_en:5.7-5.8: └─┐ 5 │ -- C content boolean │ ‾ └─ Test [WARNING] [A.x] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/enums-nonbool-overlap.catala_en:13.10-13.11: +┌─⯈ enums-nonbool-overlap.catala_en:13.10-13.11: └──┐ 13 │ output x content integer │ ‾ diff --git a/tests/test_proof/bad/enums-overlap.catala_en b/tests/test_proof/bad/enums-overlap.catala_en index 89e3ef2f..39090bc1 100644 --- a/tests/test_proof/bad/enums-overlap.catala_en +++ b/tests/test_proof/bad/enums-overlap.catala_en @@ -25,13 +25,13 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/bad/enums-overlap.catala_en:7.7-7.8: +┌─⯈ enums-overlap.catala_en:7.7-7.8: └─┐ 7 │ -- C content boolean │ ‾ └─ Test [WARNING] [A.x] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/enums-overlap.catala_en:15.10-15.11: +┌─⯈ enums-overlap.catala_en:15.10-15.11: └──┐ 15 │ output x content integer │ ‾ diff --git a/tests/test_proof/bad/enums_inj-empty.catala_en b/tests/test_proof/bad/enums_inj-empty.catala_en index b6b2d602..4bd7c2c1 100644 --- a/tests/test_proof/bad/enums_inj-empty.catala_en +++ b/tests/test_proof/bad/enums_inj-empty.catala_en @@ -18,13 +18,13 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C2" of enumeration "E" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/bad/enums_inj-empty.catala_en:6.6-6.8: +┌─⯈ enums_inj-empty.catala_en:6.6-6.8: └─┐ 6 │ -- C2 │ ‾‾ └─ Article [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/enums_inj-empty.catala_en:10.10-10.11: +┌─⯈ enums_inj-empty.catala_en:10.10-10.11: └──┐ 10 │ output y content integer │ ‾ diff --git a/tests/test_proof/bad/enums_inj-overlap.catala_en b/tests/test_proof/bad/enums_inj-overlap.catala_en index 1f6bf5ae..d17db509 100644 --- a/tests/test_proof/bad/enums_inj-overlap.catala_en +++ b/tests/test_proof/bad/enums_inj-overlap.catala_en @@ -19,7 +19,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/enums_inj-overlap.catala_en:10.10-10.11: +┌─⯈ enums_inj-overlap.catala_en:10.10-10.11: └──┐ 10 │ output y content integer │ ‾ diff --git a/tests/test_proof/bad/enums_unit-empty.catala_en b/tests/test_proof/bad/enums_unit-empty.catala_en index 6a28690c..ad02b33d 100644 --- a/tests/test_proof/bad/enums_unit-empty.catala_en +++ b/tests/test_proof/bad/enums_unit-empty.catala_en @@ -22,7 +22,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/enums_unit-empty.catala_en:10.10-10.11: +┌─⯈ enums_unit-empty.catala_en:10.10-10.11: └──┐ 10 │ output y content integer │ ‾ diff --git a/tests/test_proof/bad/enums_unit-overlap.catala_en b/tests/test_proof/bad/enums_unit-overlap.catala_en index 6e60e55b..e35dd758 100644 --- a/tests/test_proof/bad/enums_unit-overlap.catala_en +++ b/tests/test_proof/bad/enums_unit-overlap.catala_en @@ -22,7 +22,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/enums_unit-overlap.catala_en:10.10-10.11: +┌─⯈ enums_unit-overlap.catala_en:10.10-10.11: └──┐ 10 │ output y content integer │ ‾ diff --git a/tests/test_proof/bad/let_in_condition-empty.catala_en b/tests/test_proof/bad/let_in_condition-empty.catala_en index 341e041e..b3fe4534 100644 --- a/tests/test_proof/bad/let_in_condition-empty.catala_en +++ b/tests/test_proof/bad/let_in_condition-empty.catala_en @@ -14,7 +14,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.x] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/let_in_condition-empty.catala_en:5.10-5.11: +┌─⯈ let_in_condition-empty.catala_en:5.10-5.11: └─┐ 5 │ output x content boolean │ ‾ diff --git a/tests/test_proof/bad/money-empty.catala_en b/tests/test_proof/bad/money-empty.catala_en index 5de7fe03..167e0c69 100644 --- a/tests/test_proof/bad/money-empty.catala_en +++ b/tests/test_proof/bad/money-empty.catala_en @@ -17,7 +17,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/money-empty.catala_en:8.10-8.11: +┌─⯈ money-empty.catala_en:8.10-8.11: └─┐ 8 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/money-overlap.catala_en b/tests/test_proof/bad/money-overlap.catala_en index aa60442b..78ca8891 100644 --- a/tests/test_proof/bad/money-overlap.catala_en +++ b/tests/test_proof/bad/money-overlap.catala_en @@ -18,7 +18,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/money-overlap.catala_en:8.10-8.11: +┌─⯈ money-overlap.catala_en:8.10-8.11: └─┐ 8 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/no_vars-conflict.catala_en b/tests/test_proof/bad/no_vars-conflict.catala_en index 178a790c..099732da 100644 --- a/tests/test_proof/bad/no_vars-conflict.catala_en +++ b/tests/test_proof/bad/no_vars-conflict.catala_en @@ -18,7 +18,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/no_vars-conflict.catala_en:8.10-8.11: +┌─⯈ no_vars-conflict.catala_en:8.10-8.11: └─┐ 8 │ output y content integer │ ‾ diff --git a/tests/test_proof/bad/no_vars-empty.catala_en b/tests/test_proof/bad/no_vars-empty.catala_en index 6de8f150..c0767b33 100644 --- a/tests/test_proof/bad/no_vars-empty.catala_en +++ b/tests/test_proof/bad/no_vars-empty.catala_en @@ -17,7 +17,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/no_vars-empty.catala_en:7.10-7.11: +┌─⯈ no_vars-empty.catala_en:7.10-7.11: └─┐ 7 │ output y content integer │ ‾ diff --git a/tests/test_proof/bad/prolala_motivating_example.catala_en b/tests/test_proof/bad/prolala_motivating_example.catala_en index 5ecac7b9..058550fe 100644 --- a/tests/test_proof/bad/prolala_motivating_example.catala_en +++ b/tests/test_proof/bad/prolala_motivating_example.catala_en @@ -127,7 +127,7 @@ $ catala Proof --disable_counterexamples It is impossible to give a definition to a subscope variable not tagged as input or context. Incriminated subscope: -┌─⯈ tests/test_proof/bad/prolala_motivating_example.catala_en:56.3-56.14: +┌─⯈ prolala_motivating_example.catala_en:56.3-56.14: └──┐ 56 │ eligibility scope Eligibility │ ‾‾‾‾‾‾‾‾‾‾‾ @@ -135,7 +135,7 @@ Incriminated subscope: └─ Amount Incriminated variable: -┌─⯈ tests/test_proof/bad/prolala_motivating_example.catala_en:9.12-9.22: +┌─⯈ prolala_motivating_example.catala_en:9.12-9.22: └─┐ 9 │ internal is_student content boolean │ ‾‾‾‾‾‾‾‾‾‾ @@ -143,7 +143,7 @@ Incriminated variable: └─ Eligibility Incriminated subscope variable definition: -┌─⯈ tests/test_proof/bad/prolala_motivating_example.catala_en:64.3-64.36: +┌─⯈ prolala_motivating_example.catala_en:64.3-64.36: └──┐ 64 │ definition eligibility.is_student equals is_student │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_proof/bad/rationals-empty.catala_en b/tests/test_proof/bad/rationals-empty.catala_en index 528f013f..3ceba02c 100644 --- a/tests/test_proof/bad/rationals-empty.catala_en +++ b/tests/test_proof/bad/rationals-empty.catala_en @@ -13,7 +13,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/rationals-empty.catala_en:6.10-6.11: +┌─⯈ rationals-empty.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/rationals-overlap.catala_en b/tests/test_proof/bad/rationals-overlap.catala_en index 3f7a92ec..230c0bca 100644 --- a/tests/test_proof/bad/rationals-overlap.catala_en +++ b/tests/test_proof/bad/rationals-overlap.catala_en @@ -14,7 +14,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.y] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/rationals-overlap.catala_en:6.10-6.11: +┌─⯈ rationals-overlap.catala_en:6.10-6.11: └─┐ 6 │ output y content boolean │ ‾ diff --git a/tests/test_proof/bad/sat_solving.catala_en b/tests/test_proof/bad/sat_solving.catala_en index 7b5ce646..dad43c26 100644 --- a/tests/test_proof/bad/sat_solving.catala_en +++ b/tests/test_proof/bad/sat_solving.catala_en @@ -41,7 +41,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.x10] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/sat_solving.catala_en:15.10-15.13: +┌─⯈ sat_solving.catala_en:15.10-15.13: └──┐ 15 │ output x10 content boolean │ ‾‾‾ diff --git a/tests/test_proof/bad/structs-empty.catala_en b/tests/test_proof/bad/structs-empty.catala_en index 4f2b1cc0..2bc98ff6 100644 --- a/tests/test_proof/bad/structs-empty.catala_en +++ b/tests/test_proof/bad/structs-empty.catala_en @@ -22,7 +22,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.x] This variable might return an empty error: -┌─⯈ tests/test_proof/bad/structs-empty.catala_en:13.10-13.11: +┌─⯈ structs-empty.catala_en:13.10-13.11: └──┐ 13 │ output x content integer │ ‾ diff --git a/tests/test_proof/bad/structs-overlap.catala_en b/tests/test_proof/bad/structs-overlap.catala_en index 5bd9d0c4..ef032fea 100644 --- a/tests/test_proof/bad/structs-overlap.catala_en +++ b/tests/test_proof/bad/structs-overlap.catala_en @@ -22,7 +22,7 @@ scope A: ```catala-test-inline $ catala Proof --disable_counterexamples [WARNING] [A.x] At least two exceptions overlap for this variable: -┌─⯈ tests/test_proof/bad/structs-overlap.catala_en:13.10-13.11: +┌─⯈ structs-overlap.catala_en:13.10-13.11: └──┐ 13 │ output x content integer │ ‾ diff --git a/tests/test_proof/good/enums-arith.catala_en b/tests/test_proof/good/enums-arith.catala_en index 4fe972ee..1641f6b8 100644 --- a/tests/test_proof/good/enums-arith.catala_en +++ b/tests/test_proof/good/enums-arith.catala_en @@ -23,7 +23,7 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/good/enums-arith.catala_en:5.7-5.8: +┌─⯈ enums-arith.catala_en:5.7-5.8: └─┐ 5 │ -- C content boolean │ ‾ diff --git a/tests/test_proof/good/enums-nonbool.catala_en b/tests/test_proof/good/enums-nonbool.catala_en index 227d7d4e..94a00baf 100644 --- a/tests/test_proof/good/enums-nonbool.catala_en +++ b/tests/test_proof/good/enums-nonbool.catala_en @@ -23,7 +23,7 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/good/enums-nonbool.catala_en:5.7-5.8: +┌─⯈ enums-nonbool.catala_en:5.7-5.8: └─┐ 5 │ -- C content boolean │ ‾ diff --git a/tests/test_proof/good/enums.catala_en b/tests/test_proof/good/enums.catala_en index dbd08291..243cf17d 100644 --- a/tests/test_proof/good/enums.catala_en +++ b/tests/test_proof/good/enums.catala_en @@ -22,7 +22,7 @@ scope A: $ catala Proof --disable_counterexamples [WARNING] The constructor "C" of enumeration "T" is never used; maybe it's unnecessary? -┌─⯈ tests/test_proof/good/enums.catala_en:5.7-5.8: +┌─⯈ enums.catala_en:5.7-5.8: └─┐ 5 │ -- C content boolean │ ‾ diff --git a/tests/test_scope/bad/cycle_in_scope.catala_en b/tests/test_scope/bad/cycle_in_scope.catala_en index 6e5f847a..f8a5aa0c 100644 --- a/tests/test_scope/bad/cycle_in_scope.catala_en +++ b/tests/test_scope/bad/cycle_in_scope.catala_en @@ -21,21 +21,21 @@ Cyclic dependency detected between the following variables of scope A: z → x → y → z z is used here in the definition of x: -┌─⯈ tests/test_scope/bad/cycle_in_scope.catala_en:14.23-14.24: +┌─⯈ cycle_in_scope.catala_en:14.23-14.24: └──┐ 14 │ definition x equals z │ ‾ └─ Article x is used here in the definition of y: -┌─⯈ tests/test_scope/bad/cycle_in_scope.catala_en:11.32-11.33: +┌─⯈ cycle_in_scope.catala_en:11.32-11.33: └──┐ 11 │ definition y under condition x >= 0 consequence equals x │ ‾ └─ Article y is used here in the definition of z: -┌─⯈ tests/test_scope/bad/cycle_in_scope.catala_en:13.32-13.33: +┌─⯈ cycle_in_scope.catala_en:13.32-13.33: └──┐ 13 │ definition z under condition y < 1 consequence equals y │ ‾ diff --git a/tests/test_scope/bad/cyclic_scope_calls.catala_en b/tests/test_scope/bad/cyclic_scope_calls.catala_en index 2d3e1156..e750e574 100644 --- a/tests/test_scope/bad/cyclic_scope_calls.catala_en +++ b/tests/test_scope/bad/cyclic_scope_calls.catala_en @@ -33,19 +33,19 @@ Cyclic dependency detected between the following scopes: S4 → S3 → S2 → S4 S4 is used here in the definition of S3: -┌─⯈ tests/test_scope/bad/cyclic_scope_calls.catala_en:21.24-21.36: +┌─⯈ cyclic_scope_calls.catala_en:21.24-21.36: └──┐ 21 │ definition o equals (output of S4).o │ ‾‾‾‾‾‾‾‾‾‾‾‾ S3 is used here in the definition of S2: -┌─⯈ tests/test_scope/bad/cyclic_scope_calls.catala_en:18.43-18.55: +┌─⯈ cyclic_scope_calls.catala_en:18.43-18.55: └──┐ 18 │ definition o equals (output of S1).o + (output of S3).o │ ‾‾‾‾‾‾‾‾‾‾‾‾ S2 is used here in the definition of S4: -┌─⯈ tests/test_scope/bad/cyclic_scope_calls.catala_en:24.24-24.36: +┌─⯈ cyclic_scope_calls.catala_en:24.24-24.36: └──┐ 24 │ definition o equals (output of S2).o │ ‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_scope/bad/cyclic_scopes.catala_en b/tests/test_scope/bad/cyclic_scopes.catala_en index 3fb3a1c6..08d245b2 100644 --- a/tests/test_scope/bad/cyclic_scopes.catala_en +++ b/tests/test_scope/bad/cyclic_scopes.catala_en @@ -22,14 +22,14 @@ $ catala Interpret -s A Cyclic dependency detected between the following scopes: B → A → B B is used here in the definition of A: -┌─⯈ tests/test_scope/bad/cyclic_scopes.catala_en:5.3-5.4: +┌─⯈ cyclic_scopes.catala_en:5.3-5.4: └─┐ 5 │ b scope B │ ‾ └─ Article A is used here in the definition of B: -┌─⯈ tests/test_scope/bad/cyclic_scopes.catala_en:9.3-9.4: +┌─⯈ cyclic_scopes.catala_en:9.3-9.4: └─┐ 9 │ a scope A │ ‾ diff --git a/tests/test_scope/bad/scope.catala_en b/tests/test_scope/bad/scope.catala_en index 61f3dd3f..66f215ca 100644 --- a/tests/test_scope/bad/scope.catala_en +++ b/tests/test_scope/bad/scope.catala_en @@ -20,14 +20,14 @@ $ catala Interpret -s A There is a conflict between multiple valid consequences for assigning the same variable. This consequence has a valid justification: -┌─⯈ tests/test_scope/bad/scope.catala_en:13.57-13.61: +┌─⯈ scope.catala_en:13.57-13.61: └──┐ 13 │ definition b under condition not c consequence equals 1337 │ ‾‾‾‾ └─ Article This consequence has a valid justification: -┌─⯈ tests/test_scope/bad/scope.catala_en:14.57-14.58: +┌─⯈ scope.catala_en:14.57-14.58: └──┐ 14 │ definition b under condition not c consequence equals 0 │ ‾ diff --git a/tests/test_scope/bad/scope_call_duplicate.catala_en b/tests/test_scope/bad/scope_call_duplicate.catala_en index 270020cf..9888d931 100644 --- a/tests/test_scope/bad/scope_call_duplicate.catala_en +++ b/tests/test_scope/bad/scope_call_duplicate.catala_en @@ -19,7 +19,7 @@ $ catala dcalc -s Titi [ERROR] Duplicate definition of scope input variable 'bar' -┌─⯈ tests/test_scope/bad/scope_call_duplicate.catala_en:14.70-14.73: +┌─⯈ scope_call_duplicate.catala_en:14.70-14.73: └──┐ 14 │ definition fizz equals output of Toto with {--bar: 1 --baz: 2.1 -- bar: 3} │ ‾‾‾ diff --git a/tests/test_scope/bad/scope_call_extra.catala_en b/tests/test_scope/bad/scope_call_extra.catala_en index 83417173..de8c7b21 100644 --- a/tests/test_scope/bad/scope_call_extra.catala_en +++ b/tests/test_scope/bad/scope_call_extra.catala_en @@ -19,13 +19,13 @@ $ catala dcalc -s Titi [ERROR] Scope Toto has no input variable biz -┌─⯈ tests/test_scope/bad/scope_call_extra.catala_en:14.49-14.52: +┌─⯈ scope_call_extra.catala_en:14.49-14.52: └──┐ 14 │ definition fizz equals output of Toto with {--biz: 1} │ ‾‾‾ Scope Toto declared here -┌─⯈ tests/test_scope/bad/scope_call_extra.catala_en:2.19-2.23: +┌─⯈ scope_call_extra.catala_en:2.19-2.23: └─┐ 2 │ declaration scope Toto: │ ‾‾‾‾ diff --git a/tests/test_scope/bad/scope_call_missing.catala_en b/tests/test_scope/bad/scope_call_missing.catala_en index e4d66847..45ecf0f1 100644 --- a/tests/test_scope/bad/scope_call_missing.catala_en +++ b/tests/test_scope/bad/scope_call_missing.catala_en @@ -19,13 +19,13 @@ $ catala dcalc -s Titi [ERROR] Definition of input variable 'baz' missing in this scope call -┌─⯈ tests/test_scope/bad/scope_call_missing.catala_en:14.26-14.56: +┌─⯈ scope_call_missing.catala_en:14.26-14.56: └──┐ 14 │ definition fizz equals output of Toto with {--bar: 1} │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ Declaration of the missing input variable -┌─⯈ tests/test_scope/bad/scope_call_missing.catala_en:4.16-4.19: +┌─⯈ scope_call_missing.catala_en:4.16-4.19: └─┐ 4 │ input output baz content decimal │ ‾‾‾ diff --git a/tests/test_scope/bad/sub_vars_in_sub_var.catala_en b/tests/test_scope/bad/sub_vars_in_sub_var.catala_en index d6493c5f..d7fba088 100644 --- a/tests/test_scope/bad/sub_vars_in_sub_var.catala_en +++ b/tests/test_scope/bad/sub_vars_in_sub_var.catala_en @@ -18,7 +18,7 @@ $ catala Interpret -s A [ERROR] The subscope a is used when defining one of its inputs, but recursion is forbidden in Catala -┌─⯈ tests/test_scope/bad/sub_vars_in_sub_var.catala_en:13.28-13.31: +┌─⯈ sub_vars_in_sub_var.catala_en:13.28-13.31: └──┐ 13 │ definition a.y equals if a.x then 0 else 1 │ ‾‾‾ diff --git a/tests/test_scope/good/191_fix_record_name_confusion.catala_en b/tests/test_scope/good/191_fix_record_name_confusion.catala_en index 5f364ed6..a999ee51 100644 --- a/tests/test_scope/good/191_fix_record_name_confusion.catala_en +++ b/tests/test_scope/good/191_fix_record_name_confusion.catala_en @@ -33,32 +33,30 @@ module ScopeB = struct type t = {a: bool} end -module ScopeAIn = struct +module ScopeA_in = struct type t = unit end -module ScopeBIn = struct +module ScopeB_in = struct type t = unit end -let scope_a (scope_a_in: ScopeAIn.t) : ScopeA.t = +let scope_a (scope_a_in: ScopeA_in.t) : ScopeA.t = let a_: bool = try true with EmptyError -> (raise (NoValueProvided - {filename = "tests/test_scope/good/191_fix_record_name_confusion.catala_en"; - start_line=5; start_column=10; end_line=5; end_column=11; - law_headings=["Article"]})) in + {filename = "191_fix_record_name_confusion.catala_en"; start_line=5; + start_column=10; end_line=5; end_column=11; law_headings=["Article"]})) in {ScopeA.a = a_} -let scope_b (scope_b_in: ScopeBIn.t) : ScopeB.t = +let scope_b (scope_b_in: ScopeB_in.t) : ScopeB.t = let result_: ScopeA.t = scope_a (()) in let scope_a_dot_a_: bool = result_.ScopeA.a in let a_: bool = try scope_a_dot_a_ with EmptyError -> (raise (NoValueProvided - {filename = "tests/test_scope/good/191_fix_record_name_confusion.catala_en"; - start_line=8; start_column=10; end_line=8; end_column=11; - law_headings=["Article"]})) in + {filename = "191_fix_record_name_confusion.catala_en"; start_line=8; + start_column=10; end_line=8; end_column=11; law_headings=["Article"]})) in {ScopeB.a = a_} let () = Runtime_ocaml.Runtime.register_module "191_fix_record_name_confusion" diff --git a/tests/test_scope/good/nothing.catala_en b/tests/test_scope/good/nothing.catala_en index 5ab14826..994bfabb 100644 --- a/tests/test_scope/good/nothing.catala_en +++ b/tests/test_scope/good/nothing.catala_en @@ -9,7 +9,7 @@ declaration scope Foo2: $ catala Scalc -s Foo2 -O -t [WARNING] In scope "Foo2", the variable "bar" is declared but never defined; did you forget something? -┌─⯈ tests/test_scope/good/nothing.catala_en:5.10-5.13: +┌─⯈ nothing.catala_en:5.10-5.13: └─┐ 5 │ output bar content integer │ ‾‾‾ diff --git a/tests/test_scope/good/scope_call3.catala_en b/tests/test_scope/good/scope_call3.catala_en index 54dbe234..149b006a 100644 --- a/tests/test_scope/good/scope_call3.catala_en +++ b/tests/test_scope/good/scope_call3.catala_en @@ -18,27 +18,30 @@ scope RentComputation: ```catala-test-inline $ catala Interpret -t -s HousingComputation --debug -[DEBUG] Collecting rules... -[DEBUG] Reading files... -[DEBUG] Parsing tests/test_scope/good/scope_call3.catala_en +[DEBUG] - INIT - +[DEBUG] - SURFACE - +[DEBUG] Parsing scope_call3.catala_en +[DEBUG] - DESUGARED - [DEBUG] Name resolution... [DEBUG] Desugaring... [DEBUG] Disambiguating... [DEBUG] Linting... +[DEBUG] - SCOPELANG - +[DEBUG] - DCALC - [DEBUG] Typechecking... [DEBUG] Translating to default calculus... [DEBUG] Typechecking again... [DEBUG] Starting interpretation... [LOG] ≔ HousingComputation.f: [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:8.14-8.20: + ┌─⯈ scope_call3.catala_en:8.14-8.20: └─┐ 8 │ definition result equals f of 1 │ ‾‾‾‾‾‾ [LOG] → HousingComputation.f [LOG] ≔ HousingComputation.f.input0: 1 [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.14-7.15: + ┌─⯈ scope_call3.catala_en:7.14-7.15: └─┐ 7 │ definition f of x equals (output of RentComputation).f of x │ ‾ @@ -47,7 +50,7 @@ $ catala Interpret -t -s HousingComputation --debug [LOG] ≔ RentComputation.g: [LOG] ≔ RentComputation.f: [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.29-7.54: + ┌─⯈ scope_call3.catala_en:7.29-7.54: └─┐ 7 │ definition f of x equals (output of RentComputation).f of x │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ @@ -56,14 +59,14 @@ $ catala Interpret -t -s HousingComputation --debug [LOG] → RentComputation.f [LOG] ≔ RentComputation.f.input0: 1 [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:16.14-16.15: + ┌─⯈ scope_call3.catala_en:16.14-16.15: └──┐ 16 │ definition f of x equals g of (x + 1) │ ‾ [LOG] → RentComputation.g [LOG] ≔ RentComputation.g.input0: 2 [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:15.14-15.15: + ┌─⯈ scope_call3.catala_en:15.14-15.15: └──┐ 15 │ definition g of x equals x + 1 │ ‾ diff --git a/tests/test_scope/good/scope_call4.catala_en b/tests/test_scope/good/scope_call4.catala_en index 64e11950..f2dddf16 100644 --- a/tests/test_scope/good/scope_call4.catala_en +++ b/tests/test_scope/good/scope_call4.catala_en @@ -24,13 +24,16 @@ scope RentComputation: ```catala-test-inline $ catala Interpret -s RentComputation --debug -[DEBUG] Collecting rules... -[DEBUG] Reading files... -[DEBUG] Parsing tests/test_scope/good/scope_call4.catala_en +[DEBUG] - INIT - +[DEBUG] - SURFACE - +[DEBUG] Parsing scope_call4.catala_en +[DEBUG] - DESUGARED - [DEBUG] Name resolution... [DEBUG] Desugaring... [DEBUG] Disambiguating... [DEBUG] Linting... +[DEBUG] - SCOPELANG - +[DEBUG] - DCALC - [DEBUG] Typechecking... [DEBUG] Translating to default calculus... [DEBUG] Typechecking again... @@ -49,18 +52,21 @@ f2 = λ (x: integer) → ```catala-test-inline $ catala Interpret_Lcalc -s RentComputation --avoid_exceptions --optimize --debug -[DEBUG] Collecting rules... -[DEBUG] Reading files... -[DEBUG] Parsing tests/test_scope/good/scope_call4.catala_en +[DEBUG] - INIT - +[DEBUG] - SURFACE - +[DEBUG] Parsing scope_call4.catala_en +[DEBUG] - DESUGARED - [DEBUG] Name resolution... [DEBUG] Desugaring... [DEBUG] Disambiguating... [DEBUG] Linting... +[DEBUG] - SCOPELANG - +[DEBUG] - DCALC - [DEBUG] Typechecking... [DEBUG] Translating to default calculus... [DEBUG] Optimizing default calculus... [DEBUG] Typechecking again... -[DEBUG] Compiling program into lambda calculus... +[DEBUG] - LCALC - [DEBUG] Optimizing lambda calculus... [DEBUG] Starting interpretation... [DEBUG] End of interpretation diff --git a/tests/test_struct/bad/bug_107.catala_en b/tests/test_struct/bad/bug_107.catala_en index dc6ec813..859ca68a 100644 --- a/tests/test_struct/bad/bug_107.catala_en +++ b/tests/test_struct/bad/bug_107.catala_en @@ -22,14 +22,14 @@ $ catala Interpret -s A struct name "S" already defined First definition: -┌─⯈ tests/test_struct/bad/bug_107.catala_en:4.23-4.24: +┌─⯈ bug_107.catala_en:4.23-4.24: └─┐ 4 │ declaration structure S: │ ‾ └─ https://github.com/CatalaLang/catala/issues/107 Second definition: -┌─⯈ tests/test_struct/bad/bug_107.catala_en:8.23-8.24: +┌─⯈ bug_107.catala_en:8.23-8.24: └─┐ 8 │ declaration structure S: │ ‾ diff --git a/tests/test_struct/bad/empty_struct.catala_en b/tests/test_struct/bad/empty_struct.catala_en index fba0bd77..9d43f581 100644 --- a/tests/test_struct/bad/empty_struct.catala_en +++ b/tests/test_struct/bad/empty_struct.catala_en @@ -12,7 +12,7 @@ $ catala Typecheck [ERROR] The struct Foo does not have any fields; give it some for Catala to be able to accept it. -┌─⯈ tests/test_struct/bad/empty_struct.catala_en:4.23-4.26: +┌─⯈ empty_struct.catala_en:4.23-4.26: └─┐ 4 │ declaration structure Foo: │ ‾‾‾ diff --git a/tests/test_struct/bad/nested.catala_en b/tests/test_struct/bad/nested.catala_en index 419e68bc..659b5012 100644 --- a/tests/test_struct/bad/nested.catala_en +++ b/tests/test_struct/bad/nested.catala_en @@ -16,7 +16,7 @@ scope A: $ catala Interpret -s A [WARNING] The constructor "Rec" of enumeration "E" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/bad/nested.catala_en:6.6-6.9: +┌─⯈ nested.catala_en:6.6-6.9: └─┐ 6 │ -- Rec content E │ ‾‾‾ @@ -24,7 +24,7 @@ $ catala Interpret -s A [ERROR] The type E is defined using itself, which is forbidden since Catala does not provide recursive types -┌─⯈ tests/test_struct/bad/nested.catala_en:6.18-6.19: +┌─⯈ nested.catala_en:6.18-6.19: └─┐ 6 │ -- Rec content E │ ‾ diff --git a/tests/test_struct/bad/nested2.catala_en b/tests/test_struct/bad/nested2.catala_en index f7b5ac5b..4273e84d 100644 --- a/tests/test_struct/bad/nested2.catala_en +++ b/tests/test_struct/bad/nested2.catala_en @@ -17,21 +17,21 @@ declaration scope A: $ catala Interpret -s A [WARNING] In scope "A", the variable "x" is declared but never defined; did you forget something? -┌─⯈ tests/test_struct/bad/nested2.catala_en:13.10-13.11: +┌─⯈ nested2.catala_en:13.10-13.11: └──┐ 13 │ output x content E │ ‾ └─ Article [WARNING] The structure "S" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/bad/nested2.catala_en:4.23-4.24: +┌─⯈ nested2.catala_en:4.23-4.24: └─┐ 4 │ declaration structure S: │ ‾ └─ Article [WARNING] The enumeration "E" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/bad/nested2.catala_en:8.25-8.26: +┌─⯈ nested2.catala_en:8.25-8.26: └─┐ 8 │ declaration enumeration E: │ ‾ @@ -40,28 +40,28 @@ $ catala Interpret -s A Cyclic dependency detected between types! Cycle type S, declared: -┌─⯈ tests/test_struct/bad/nested2.catala_en:4.23-4.24: +┌─⯈ nested2.catala_en:4.23-4.24: └─┐ 4 │ declaration structure S: │ ‾ └─ Article Used here in the definition of another cycle type E: -┌─⯈ tests/test_struct/bad/nested2.catala_en:10.20-10.21: +┌─⯈ nested2.catala_en:10.20-10.21: └──┐ 10 │ -- Case2 content S │ ‾ └─ Article Cycle type E, declared: -┌─⯈ tests/test_struct/bad/nested2.catala_en:8.25-8.26: +┌─⯈ nested2.catala_en:8.25-8.26: └─┐ 8 │ declaration enumeration E: │ ‾ └─ Article Used here in the definition of another cycle type S: -┌─⯈ tests/test_struct/bad/nested2.catala_en:5.18-5.19: +┌─⯈ nested2.catala_en:5.18-5.19: └─┐ 5 │ data x content E │ ‾ diff --git a/tests/test_struct/bad/nonexisting_struct.catala_en b/tests/test_struct/bad/nonexisting_struct.catala_en index f7981c5c..17ddde2a 100644 --- a/tests/test_struct/bad/nonexisting_struct.catala_en +++ b/tests/test_struct/bad/nonexisting_struct.catala_en @@ -18,7 +18,7 @@ $ catala Interpret -s A [ERROR] No struct named Fo found -┌─⯈ tests/test_struct/bad/nonexisting_struct.catala_en:13.25-13.27: +┌─⯈ nonexisting_struct.catala_en:13.25-13.27: └──┐ 13 │ definition y equals x.Fo.f │ ‾‾ diff --git a/tests/test_struct/bad/wrong_qualified_field.catala_en b/tests/test_struct/bad/wrong_qualified_field.catala_en index 712e6574..c51523fa 100644 --- a/tests/test_struct/bad/wrong_qualified_field.catala_en +++ b/tests/test_struct/bad/wrong_qualified_field.catala_en @@ -22,7 +22,7 @@ $ catala Interpret -s A [ERROR] Field "g" does not belong to structure "Foo", but to "Bar" -┌─⯈ tests/test_struct/bad/wrong_qualified_field.catala_en:17.23-17.30: +┌─⯈ wrong_qualified_field.catala_en:17.23-17.30: └──┐ 17 │ definition y equals x.Foo.g │ ‾‾‾‾‾‾‾ diff --git a/tests/test_struct/good/ambiguous_fields.catala_en b/tests/test_struct/good/ambiguous_fields.catala_en index d73190c0..c16207b2 100644 --- a/tests/test_struct/good/ambiguous_fields.catala_en +++ b/tests/test_struct/good/ambiguous_fields.catala_en @@ -20,7 +20,7 @@ scope A: $ catala Interpret -s A [WARNING] The structure "Bar" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/good/ambiguous_fields.catala_en:7.23-7.26: +┌─⯈ ambiguous_fields.catala_en:7.23-7.26: └─┐ 7 │ declaration structure Bar: │ ‾‾‾ @@ -32,7 +32,7 @@ $ catala Interpret -s A $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [WARNING] The structure "Bar" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/good/ambiguous_fields.catala_en:7.23-7.26: +┌─⯈ ambiguous_fields.catala_en:7.23-7.26: └─┐ 7 │ declaration structure Bar: │ ‾‾‾ diff --git a/tests/test_struct/good/same_name_fields.catala_en b/tests/test_struct/good/same_name_fields.catala_en index e13a53bc..ff615959 100644 --- a/tests/test_struct/good/same_name_fields.catala_en +++ b/tests/test_struct/good/same_name_fields.catala_en @@ -20,7 +20,7 @@ scope A: $ catala Interpret -s A [WARNING] The structure "Bar" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/good/same_name_fields.catala_en:7.23-7.26: +┌─⯈ same_name_fields.catala_en:7.23-7.26: └─┐ 7 │ declaration structure Bar: │ ‾‾‾ @@ -33,7 +33,7 @@ $ catala Interpret -s A $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [WARNING] The structure "Bar" is never used; maybe it's unnecessary? -┌─⯈ tests/test_struct/good/same_name_fields.catala_en:7.23-7.26: +┌─⯈ same_name_fields.catala_en:7.23-7.26: └─┐ 7 │ declaration structure Bar: │ ‾‾‾ diff --git a/tests/test_typing/bad/err1.catala_en b/tests/test_typing/bad/err1.catala_en index 6abf5eaa..45fad72b 100644 --- a/tests/test_typing/bad/err1.catala_en +++ b/tests/test_typing/bad/err1.catala_en @@ -18,19 +18,19 @@ Error during typechecking, incompatible types: └─⯈ integer Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err1.catala_en:7.23-7.26: +┌─⯈ err1.catala_en:7.23-7.26: └─┐ 7 │ Structure { -- i: 4.1 -- e: y }; │ ‾‾‾ Type decimal coming from expression: -┌─⯈ tests/test_typing/bad/err1.catala_en:7.23-7.26: +┌─⯈ err1.catala_en:7.23-7.26: └─┐ 7 │ Structure { -- i: 4.1 -- e: y }; │ ‾‾‾ Type integer coming from expression: -┌─⯈ tests/test_typing/bad/common.catala_en:8.18-8.25: +┌─⯈ ./common.catala_en:8.18-8.25: └─┐ 8 │ data i content integer │ ‾‾‾‾‾‾‾ diff --git a/tests/test_typing/bad/err2.catala_en b/tests/test_typing/bad/err2.catala_en index 0a7d26c1..70f5abf2 100644 --- a/tests/test_typing/bad/err2.catala_en +++ b/tests/test_typing/bad/err2.catala_en @@ -18,19 +18,19 @@ Error during typechecking, incompatible types: └─⯈ collection Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err2.catala_en:10.39-10.42: +┌─⯈ err2.catala_en:10.39-10.42: └──┐ 10 │ definition a equals number of (z ++ 1.1) / 2 │ ‾‾‾ Type decimal coming from expression: -┌─⯈ tests/test_typing/bad/err2.catala_en:10.39-10.42: +┌─⯈ err2.catala_en:10.39-10.42: └──┐ 10 │ definition a equals number of (z ++ 1.1) / 2 │ ‾‾‾ Type collection coming from expression: -┌─⯈ tests/test_typing/bad/err2.catala_en:10.36-10.38: +┌─⯈ err2.catala_en:10.36-10.38: └──┐ 10 │ definition a equals number of (z ++ 1.1) / 2 │ ‾‾ diff --git a/tests/test_typing/bad/err3.catala_en b/tests/test_typing/bad/err3.catala_en index da62711e..95a26ef9 100644 --- a/tests/test_typing/bad/err3.catala_en +++ b/tests/test_typing/bad/err3.catala_en @@ -14,7 +14,7 @@ scope S: $ catala Typecheck [WARNING] The constructor "Dec" of enumeration "Enum" is never used; maybe it's unnecessary? -┌─⯈ tests/test_typing/bad/common.catala_en:4.6-4.9: +┌─⯈ ./common.catala_en:4.6-4.9: └─┐ 4 │ -- Dec content decimal │ ‾‾‾ @@ -24,19 +24,19 @@ Error during typechecking, incompatible types: └─⯈ decimal Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err3.catala_en:10.42-10.43: +┌─⯈ err3.catala_en:10.42-10.43: └──┐ 10 │ definition a equals number of (z ++ z) * 2 │ ‾ Type integer coming from expression: -┌─⯈ tests/test_typing/bad/err3.catala_en:10.42-10.43: +┌─⯈ err3.catala_en:10.42-10.43: └──┐ 10 │ definition a equals number of (z ++ z) * 2 │ ‾ Type decimal coming from expression: -┌─⯈ tests/test_typing/bad/common.catala_en:15.20-15.27: +┌─⯈ ./common.catala_en:15.20-15.27: └──┐ 15 │ output a content decimal │ ‾‾‾‾‾‾‾ @@ -49,7 +49,7 @@ Re-putting the same check again, to ensure that the `Typecheck` and `ocaml` subc $ catala ocaml [WARNING] The constructor "Dec" of enumeration "Enum" is never used; maybe it's unnecessary? -┌─⯈ tests/test_typing/bad/common.catala_en:4.6-4.9: +┌─⯈ ./common.catala_en:4.6-4.9: └─┐ 4 │ -- Dec content decimal │ ‾‾‾ @@ -59,19 +59,19 @@ Error during typechecking, incompatible types: └─⯈ decimal Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err3.catala_en:10.42-10.43: +┌─⯈ err3.catala_en:10.42-10.43: └──┐ 10 │ definition a equals number of (z ++ z) * 2 │ ‾ Type integer coming from expression: -┌─⯈ tests/test_typing/bad/err3.catala_en:10.42-10.43: +┌─⯈ err3.catala_en:10.42-10.43: └──┐ 10 │ definition a equals number of (z ++ z) * 2 │ ‾ Type decimal coming from expression: -┌─⯈ tests/test_typing/bad/common.catala_en:15.20-15.27: +┌─⯈ ./common.catala_en:15.20-15.27: └──┐ 15 │ output a content decimal │ ‾‾‾‾‾‾‾ diff --git a/tests/test_typing/bad/err4.catala_en b/tests/test_typing/bad/err4.catala_en index 8d64d655..87d4f5a0 100644 --- a/tests/test_typing/bad/err4.catala_en +++ b/tests/test_typing/bad/err4.catala_en @@ -12,19 +12,19 @@ Should be "catala Typecheck", see test err3 $ catala ocaml [WARNING] The structure "Structure" is never used; maybe it's unnecessary? -┌─⯈ tests/test_typing/bad/common.catala_en:7.23-7.32: +┌─⯈ ./common.catala_en:7.23-7.32: └─┐ 7 │ declaration structure Structure: │ ‾‾‾‾‾‾‾‾‾ [WARNING] The constructor "Dec" of enumeration "Enum" is never used; maybe it's unnecessary? -┌─⯈ tests/test_typing/bad/common.catala_en:4.6-4.9: +┌─⯈ ./common.catala_en:4.6-4.9: └─┐ 4 │ -- Dec content decimal │ ‾‾‾ [WARNING] The constructor "Dat" of enumeration "Enum" is never used; maybe it's unnecessary? -┌─⯈ tests/test_typing/bad/common.catala_en:5.6-5.9: +┌─⯈ ./common.catala_en:5.6-5.9: └─┐ 5 │ -- Dat content date │ ‾‾‾ @@ -34,19 +34,19 @@ Error during typechecking, incompatible types: └─⯈ Structure Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err4.catala_en:5.25-5.38: +┌─⯈ err4.catala_en:5.25-5.38: └─┐ 5 │ definition z equals [ Int content x ] │ ‾‾‾‾‾‾‾‾‾‾‾‾‾ Type Enum coming from expression: -┌─⯈ tests/test_typing/bad/err4.catala_en:5.25-5.38: +┌─⯈ err4.catala_en:5.25-5.38: └─┐ 5 │ definition z equals [ Int content x ] │ ‾‾‾‾‾‾‾‾‾‾‾‾‾ Type Structure coming from expression: -┌─⯈ tests/test_typing/bad/common.catala_en:14.31-14.40: +┌─⯈ ./common.catala_en:14.31-14.40: └──┐ 14 │ output z content collection Structure │ ‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_typing/bad/err5.catala_en b/tests/test_typing/bad/err5.catala_en index c5812a94..6fdacddd 100644 --- a/tests/test_typing/bad/err5.catala_en +++ b/tests/test_typing/bad/err5.catala_en @@ -18,19 +18,19 @@ Error during typechecking, incompatible types: └─⯈ Structure Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err5.catala_en:8.5-8.9: +┌─⯈ err5.catala_en:8.5-8.9: └─┐ 8 │ 1040 │ ‾‾‾‾ Type integer coming from expression: -┌─⯈ tests/test_typing/bad/err5.catala_en:8.5-8.9: +┌─⯈ err5.catala_en:8.5-8.9: └─┐ 8 │ 1040 │ ‾‾‾‾ Type Structure coming from expression: -┌─⯈ tests/test_typing/bad/err5.catala_en:6.5-6.46: +┌─⯈ err5.catala_en:6.5-6.46: └─┐ 6 │ Structure { -- i: 3 -- e: Int content x }; │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ diff --git a/tests/test_typing/bad/err6.catala_en b/tests/test_typing/bad/err6.catala_en index ea82cb4c..2338f121 100644 --- a/tests/test_typing/bad/err6.catala_en +++ b/tests/test_typing/bad/err6.catala_en @@ -34,19 +34,19 @@ Error during typechecking, incompatible types: └─⯈ integer Error coming from typechecking the following expression: -┌─⯈ tests/test_typing/bad/err6.catala_en:20.27-20.30: +┌─⯈ err6.catala_en:20.27-20.30: └──┐ 20 │ definition sub.x equals 44. │ ‾‾‾ Type decimal coming from expression: -┌─⯈ tests/test_typing/bad/err6.catala_en:20.27-20.30: +┌─⯈ err6.catala_en:20.27-20.30: └──┐ 20 │ definition sub.x equals 44. │ ‾‾‾ Type integer coming from expression: -┌─⯈ tests/test_typing/bad/common.catala_en:12.19-12.26: +┌─⯈ ./common.catala_en:12.19-12.26: └──┐ 12 │ input x content integer │ ‾‾‾‾‾‾‾ diff --git a/tests/test_variable_state/bad/def_no_state.catala_en b/tests/test_variable_state/bad/def_no_state.catala_en index 318e92f0..b196adac 100644 --- a/tests/test_variable_state/bad/def_no_state.catala_en +++ b/tests/test_variable_state/bad/def_no_state.catala_en @@ -15,14 +15,14 @@ $ catala Typecheck [ERROR] This definition does not indicate which state has to be considered for variable foo. -┌─⯈ tests/test_variable_state/bad/def_no_state.catala_en:10.14-10.17: +┌─⯈ def_no_state.catala_en:10.14-10.17: └──┐ 10 │ definition foo equals 2 │ ‾‾‾ └─ Test Variable declaration: -┌─⯈ tests/test_variable_state/bad/def_no_state.catala_en:5.10-5.13: +┌─⯈ def_no_state.catala_en:5.10-5.13: └─┐ 5 │ output foo content integer │ ‾‾‾ diff --git a/tests/test_variable_state/bad/double_same_state.catala_en b/tests/test_variable_state/bad/double_same_state.catala_en index e4a4aabf..1abb6a71 100644 --- a/tests/test_variable_state/bad/double_same_state.catala_en +++ b/tests/test_variable_state/bad/double_same_state.catala_en @@ -16,14 +16,14 @@ $ catala Typecheck There are two states with the same name for the same variable: this is ambiguous. Please change the name of either states. First instance of state "bar": -┌─⯈ tests/test_variable_state/bad/double_same_state.catala_en:6.11-6.14: +┌─⯈ double_same_state.catala_en:6.11-6.14: └─┐ 6 │ state bar │ ‾‾‾ └─ Test Second instance of state "bar": -┌─⯈ tests/test_variable_state/bad/double_same_state.catala_en:7.11-7.14: +┌─⯈ double_same_state.catala_en:7.11-7.14: └─┐ 7 │ state bar │ ‾‾‾ diff --git a/tests/test_variable_state/bad/no_cross_exceptions.catala_en b/tests/test_variable_state/bad/no_cross_exceptions.catala_en index 3b25e046..c1fb510a 100644 --- a/tests/test_variable_state/bad/no_cross_exceptions.catala_en +++ b/tests/test_variable_state/bad/no_cross_exceptions.catala_en @@ -19,7 +19,7 @@ $ catala Typecheck [ERROR] Unknown label for the scope variable foo.baz: "thing" -┌─⯈ tests/test_variable_state/bad/no_cross_exceptions.catala_en:14.13-14.18: +┌─⯈ no_cross_exceptions.catala_en:14.13-14.18: └──┐ 14 │ exception thing definition foo state baz under condition true consequence equals 3 │ ‾‾‾‾‾ diff --git a/tests/test_variable_state/bad/self_reference_first_state.catala_en b/tests/test_variable_state/bad/self_reference_first_state.catala_en index b00e2a30..f337277c 100644 --- a/tests/test_variable_state/bad/self_reference_first_state.catala_en +++ b/tests/test_variable_state/bad/self_reference_first_state.catala_en @@ -17,7 +17,7 @@ $ catala Typecheck [ERROR] It is impossible to refer to the variable you are defining when defining its first state. -┌─⯈ tests/test_variable_state/bad/self_reference_first_state.catala_en:10.35-10.38: +┌─⯈ self_reference_first_state.catala_en:10.35-10.38: └──┐ 10 │ definition foo state bar equals foo + 1 │ ‾‾‾ diff --git a/tests/test_variable_state/bad/state_cycle.catala_en b/tests/test_variable_state/bad/state_cycle.catala_en index 28546497..bd593e29 100644 --- a/tests/test_variable_state/bad/state_cycle.catala_en +++ b/tests/test_variable_state/bad/state_cycle.catala_en @@ -26,28 +26,28 @@ Cyclic dependency detected between the following variables of scope A: foofoo@bar → foofoo@baz → foo@bar → foo@baz → foofoo@bar foofoo@bar is used here in the definition of foofoo@baz: -┌─⯈ tests/test_variable_state/bad/state_cycle.catala_en:19.38-19.44: +┌─⯈ state_cycle.catala_en:19.38-19.44: └──┐ 19 │ definition foofoo state baz equals foofoo + 1 │ ‾‾‾‾‾‾ └─ Test foofoo@baz is used here in the definition of foo@bar: -┌─⯈ tests/test_variable_state/bad/state_cycle.catala_en:13.35-13.41: +┌─⯈ state_cycle.catala_en:13.35-13.41: └──┐ 13 │ definition foo state bar equals foofoo │ ‾‾‾‾‾‾ └─ Test foo@bar is used here in the definition of foo@baz: -┌─⯈ tests/test_variable_state/bad/state_cycle.catala_en:15.35-15.38: +┌─⯈ state_cycle.catala_en:15.35-15.38: └──┐ 15 │ definition foo state baz equals foo + 1 │ ‾‾‾ └─ Test foo@baz is used here in the definition of foofoo@bar: -┌─⯈ tests/test_variable_state/bad/state_cycle.catala_en:17.38-17.41: +┌─⯈ state_cycle.catala_en:17.38-17.41: └──┐ 17 │ definition foofoo state bar equals foo │ ‾‾‾ diff --git a/tests/test_variable_state/bad/unknown_state.catala_en b/tests/test_variable_state/bad/unknown_state.catala_en index d8ded016..a7597dcc 100644 --- a/tests/test_variable_state/bad/unknown_state.catala_en +++ b/tests/test_variable_state/bad/unknown_state.catala_en @@ -17,14 +17,14 @@ $ catala Typecheck [ERROR] This identifier is not a state declared for variable foo. -┌─⯈ tests/test_variable_state/bad/unknown_state.catala_en:12.24-12.28: +┌─⯈ unknown_state.catala_en:12.24-12.28: └──┐ 12 │ definition foo state basz equals foo + 1 │ ‾‾‾‾ └─ Test Variable declaration: -┌─⯈ tests/test_variable_state/bad/unknown_state.catala_en:5.10-5.13: +┌─⯈ unknown_state.catala_en:5.10-5.13: └─┐ 5 │ output foo content integer │ ‾‾‾