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

Module support: handle structs, enums and scope calls across modules (#497)

Browse Source
This commit is contained in:
Louis Gesbert 2023-09-01 14:35:58 +02:00 committed by GitHub
commit dcb057bc6f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
180 changed files with 2486 additions and 1702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/workflows/run-make-all.yml vendored
View File

@ -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

6
Makefile
View File

@ -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

163
build_system/clerk_driver.ml
View File

@ -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")

271
build_system/clerk_runtest.ml Normal file
View File

@ -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 <louis.gesbert@inria.fr>
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 "@[<hv 2>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 "@[<v 2>Running tests:@ %a@]"
(Format.pp_print_list (fun ppf t ->
Format.fprintf ppf "- @[<hov>%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

31
build_system/clerk_runtest.mli Normal file
View File

@ -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 <louis.gesbert@inria.fr>
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. *)

2
build_system/dune
View File

@ -14,7 +14,7 @@
cmdliner
re
ocolor)
(modules clerk_driver))
(modules clerk_runtest clerk_driver))
(rule
(target custom_linking.sexp)

14
compiler/catala_utils/map.ml
View File

@ -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

59
compiler/catala_utils/uid.ml
View File

@ -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 "@{<blue>%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@{<cyan>.@}" 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

34
compiler/catala_utils/uid.mli
View File

@ -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

498
compiler/dcalc/from_scopelang.ml
View File

@ -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 }

8
compiler/desugared/ast.ml
View File

@ -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

1
compiler/desugared/ast.mli
View File

@ -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} *)

7
compiler/desugared/dependency.ml
View File

@ -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 *)

53
compiler/desugared/disambiguate.ml
View File

@ -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

559
compiler/desugared/from_surface.ml
View File

@ -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

6
compiler/desugared/linting.ml
View File

@ -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))

207
compiler/desugared/name_resolution.ml
View File

@ -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 @{<yellow>\"%s\"@} already used" subscope
"Subscope name @{<yellow>\"%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 @{<yellow>\"%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

22
compiler/desugared/name_resolution.mli
View File

@ -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 *)

49
compiler/driver.ml
View File

@ -42,30 +42,35 @@ let get_lang options file =
@{<yellow>%s@}, and @{<bold>--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 ()

5
compiler/driver.mli
View File

@ -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 ->

19
compiler/lcalc/ast.ml
View File

@ -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

6
compiler/lcalc/closure_conversion.ml
View File

@ -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,

20
compiler/lcalc/compile_without_exceptions.ml
View File

@ -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

75
compiler/lcalc/to_ocaml.ml
View File

@ -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 "@[<hov 2>(%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 "@[<hov 2>| %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 "@[<hov 2>%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 "@[<hov 2>| %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@[<hov 2>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

2
compiler/lcalc/to_ocaml.mli
View File

@ -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 *)

98
compiler/plugins/api_web.ml
View File

@ -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
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
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 "@[<hv 2>(%a@ %a)@]"
format_typ_of_jsoo ti Format.pp_print_string i))
(List.combine args_names t1)
| _ ->
Format.fprintf fmt "@[<hov 2>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
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
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 "@[<hv 2>(%a@ %a)@]" format_typ_of_jsoo
ti Format.pp_print_string i))
(List.combine args_names t1)
| _ ->
Format.fprintf fmt "@[<hov 2>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
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%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
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%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) =

6
compiler/plugins/explain.ml
View File

@ -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 [@[<hv>%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

7
compiler/plugins/json_schema.ml
View File

@ -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 "@[<hov 2>\"%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
"@[<hov 2>\"kind\": {@\n\
\"type\": \"string\",@\n\

23
compiler/plugins/lazy_interp.ml
View File

@ -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 [@[<hv>%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

47
compiler/plugins/modules.ml
View File

@ -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 @{<bold>%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 @{<bold>%s@}." dir;
dir
| None ->
Message.raise_error
"@[<hov>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 @{<bold>%s@}..."
shared_out;
run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags);

4
compiler/scalc/from_lcalc.ml
View File

@ -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: @[<hov>%a@]@\n"
Print.var_debug v

10
compiler/scalc/print.ml
View File

@ -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 "@[<hov 2>%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 "@[<hov 2>%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 "@[<v 0>%a @[<hov 2>%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)

7
compiler/scalc/to_python.ml
View File

@ -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@[<hov 4>if %a@]" format_var tmp_var

76
compiler/scopelang/ast.ml
View File

@ -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 }

7
compiler/scopelang/ast.mli
View File

@ -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;
}

14
compiler/scopelang/dependency.ml
View File

@ -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

2
compiler/scopelang/dependency.mli
View File

@ -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

479
compiler/scopelang/from_desugared.ml
View File

@ -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 @{<yellow>\"%s\"@} does not belong to structure \
@{<yellow>\"%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;
}

4
compiler/scopelang/print.ml
View File

@ -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 "@[<hov 2>%a@ %a@ %a@ %a@ %a@]@\n@[<v 2> %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))

4
compiler/scopelang/print.mli
View File

@ -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 :

55
compiler/shared_ast/definitions.ml
View File

@ -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 }

128
compiler/shared_ast/expr.ml
View File

@ -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

38
compiler/shared_ast/expr.mli
View File

@ -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

60
compiler/shared_ast/interpreter.ml
View File

@ -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>@[<hov>%a@]" m Format.pp_print_text
(Dynlink.error_message dl_err))
modules

43
compiler/shared_ast/optimizations.ml
View File

@ -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)

28
compiler/shared_ast/print.ml
View File

@ -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 "@{<blue>%a@}" ModuleName.format m
let path ppf p =
Format.pp_print_list
~pp_sep:(fun _ () -> ())
(fun ppf m ->
Format.fprintf ppf "%a@{<cyan>.@}" 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 "@{<magenta>%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 "@{<magenta>%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 "@[<hov 2>%a@]" EnumName.format e
| Some ctx ->
let def = EnumName.Map.find e ctx.ctx_enums in
Format.fprintf fmt "@[<hov 2>%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 "@[<hov 2>%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 "@[<hov 2>%a%a%a@]"
(pp_color_string (List.hd colors))

3
compiler/shared_ast/print.mli
View File

@ -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

6
compiler/shared_ast/program.ml
View File

@ -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

6
compiler/shared_ast/program.mli
View File

@ -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 *)

124
compiler/shared_ast/typing.ml
View File

@ -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 "@[<hov 2>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: @[<hov>%a@]@,"
* (A.StructName.Map.format_keys ~pp_sep) env.structs;
* Format.fprintf ppf "enums: @[<hov>%a@]@,"
* (A.EnumName.Map.format_keys ~pp_sep) env.enums;
* Format.fprintf ppf "vars: @[<hov>%a@]@,"
* (Var.Map.format_keys ~pp_sep) env.vars; *)
Format.fprintf ppf "scopes: @[<hov>%a@]@,"
(A.ScopeName.Map.format_keys ~pp_sep)
env.scopes;
Format.fprintf ppf "topdefs: @[<hov>%a@]@,"
(A.TopdefName.Map.format_keys ~pp_sep)
env.toplevel_vars;
Format.fprintf ppf "@[<hv 2>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 @{<yellow>\"%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)
"@[<hov>Field @{<yellow>\"%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

6
compiler/shared_ast/typing.mli
View File

@ -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

8
compiler/shared_ast/var.ml
View File

@ -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

9
compiler/shared_ast/var.mli
View File

@ -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

9
compiler/surface/ast.ml
View File

@ -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

38
compiler/surface/parser.messages
View File

@ -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 (', <ident> content <type>')
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

2
compiler/surface/parser.mly
View File

@ -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;

29
compiler/surface/parser_driver.ml
View File

@ -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;
}

13
compiler/surface/parser_driver.mli
View File

@ -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. *)

16
compiler/verification/z3backend.real.ml
View File

@ -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)

6
examples/Makefile
View File

@ -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:

16
examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾

14
french_law/ocaml/api.ml
View File

@ -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;
}

4
french_law/ocaml/bench.ml
View File

@ -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;

4
tests/Makefile
View File

@ -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

12
tests/test_arithmetic/bad/division_by_zero.catala_en
View File

@ -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
│ ‾‾‾‾

4
tests/test_arithmetic/bad/logical_prio.catala_en
View File

@ -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
│ ‾‾

6
tests/test_array/bad/fold_error.catala_en
View File

@ -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
│ ‾‾

6
tests/test_bool/bad/bad_assert.catala_en
View File

@ -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
│ ‾

6
tests/test_bool/bad/test_xor_with_int.catala_en
View File

@ -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
│ ‾‾‾

4
tests/test_date/bad/rounding_option_conflict.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾

16
tests/test_date/bad/uncomparable_duration.catala_en
View File

@ -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
│ ‾‾‾‾‾

6
tests/test_default/bad/conflict.catala_en
View File

@ -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#
```

4
tests/test_default/bad/empty.catala_en
View File

@ -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
│ ‾

2
tests/test_default/bad/empty_with_rules.catala_en
View File

@ -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
│ ‾

4
tests/test_default/bad/typing_or_logical_error.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

4
tests/test_default/good/mutliple_definitions.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾

2
tests/test_enum/bad/ambiguous_cases.catala_en
View File

@ -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
│ ‾‾‾‾‾

2
tests/test_enum/bad/ambiguous_wildcard.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

4
tests/test_enum/bad/duplicate_case.catala_en
View File

@ -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
│ ‾‾‾‾‾

2
tests/test_enum/bad/empty.catala_en
View File

@ -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:
│ ‾‾‾

4
tests/test_enum/bad/missing_case.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

8
tests/test_enum/bad/not_ending_wildcard.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾

6
tests/test_enum/bad/quick_pattern_2.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

6
tests/test_enum/bad/quick_pattern_3.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

6
tests/test_enum/bad/quick_pattern_4.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

2
tests/test_enum/bad/quick_pattern_fail.catala_en
View File

@ -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
│ ‾‾‾‾‾

2
tests/test_enum/bad/too_many_cases.catala_en
View File

@ -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
│ ‾‾‾‾‾

2
tests/test_enum/bad/useless_wildcard.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

2
tests/test_enum/bad/wrong_cons.catala_en
View File

@ -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
│ ‾‾‾‾‾

6
tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en
View File

@ -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
│ ‾

2
tests/test_exception/bad/dangling_exception.catala_en
View File

@ -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
│ ‾‾‾‾‾‾

6
tests/test_exception/bad/exceptions_cycle.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

2
tests/test_exception/bad/missing_unlabeled_definition.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾

6
tests/test_exception/bad/one_ambiguous_exception.catala_en
View File

@ -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
│ ‾

2
tests/test_exception/bad/self_exception.catala_en
View File

@ -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
│ ‾‾‾‾‾‾

4
tests/test_exception/bad/two_exceptions.catala_en
View File

@ -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
│ ‾

8
tests/test_exception/good/double_definition.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾

12
tests/test_exception/good/groups_of_exceptions.catala_en
View File

@ -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
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

4
tests/test_func/bad/bad_func.catala_en
View File

@ -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
│ ‾‾‾‾‾

4
tests/test_func/bad/param_inconsistency.catala_en
View File

@ -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
│ ‾

Some files were not shown because too many files have changed in this diff Show More